From f0a2d51c57ffc55ec62c67a7d1397bfb9d1d18fc Mon Sep 17 00:00:00 2001 From: "John C. Burnham" Date: Sat, 1 Aug 2026 14:06:03 -0400 Subject: [PATCH 1/2] verify Ix.Tc checking and inductive ingress --- .github/fixtures/tc-parity-consts.txt | 19 + .github/scripts/check_tc_verify_sorries.pl | 7 +- .github/workflows/ci.yml | 19 + Ix/AuxGen/Recursor.lean | 67 +- Ix/Tc/Check.lean | 282 +- Ix/Tc/Driver.lean | 172 +- Ix/Tc/Env.lean | 8 + Ix/Tc/Inductive.lean | 560 +++- Ix/Tc/Ingress.lean | 67 +- Ix/Tc/Verify/Audit/Completed.lean | 2669 ++++++++++++----- Ix/Tc/Verify/Audit/Statements.lean | 85 +- Ix/Tc/Verify/Cache.lean | 166 +- Ix/Tc/Verify/Check/Acceptance.lean | 261 ++ Ix/Tc/Verify/Check/BinderRoundTrip.lean | 242 ++ Ix/Tc/Verify/Check/BlockAcceptance.lean | 262 ++ Ix/Tc/Verify/Check/BlockCache.lean | 113 + Ix/Tc/Verify/Check/BlockClassification.lean | 215 ++ Ix/Tc/Verify/Check/BlockDefinition.lean | 173 ++ Ix/Tc/Verify/Check/BlockExecution.lean | 383 +++ Ix/Tc/Verify/Check/BlockIdentity.lean | 280 ++ Ix/Tc/Verify/Check/BlockNatFixture.lean | 121 + Ix/Tc/Verify/Check/BlockOracle.lean | 93 + Ix/Tc/Verify/Check/BlockRouteFrame.lean | 124 + Ix/Tc/Verify/Check/BlockRouting.lean | 301 ++ Ix/Tc/Verify/Check/BlockTransaction.lean | 407 +++ Ix/Tc/Verify/Check/BoundedPipelines.lean | 474 +++ Ix/Tc/Verify/Check/CheckConstExecution.lean | 68 + Ix/Tc/Verify/Check/CheckConstTransaction.lean | 157 + Ix/Tc/Verify/Check/CheckerEvidence.lean | 174 ++ Ix/Tc/Verify/Check/DeclarationIngress.lean | 124 + Ix/Tc/Verify/Check/DeclarationValidation.lean | 129 + Ix/Tc/Verify/Check/DefEqBasicPolicy.lean | 411 +++ Ix/Tc/Verify/Check/DefEqCachePolicy.lean | 345 +++ Ix/Tc/Verify/Check/DefEqEtaPolicy.lean | 362 +++ Ix/Tc/Verify/Check/DefEqFinalWhnfPolicy.lean | 375 +++ Ix/Tc/Verify/Check/DefEqLazyDeltaPolicy.lean | 482 +++ Ix/Tc/Verify/Check/DefEqNatPolicy.lean | 193 ++ Ix/Tc/Verify/Check/DefEqPipelinePolicy.lean | 242 ++ .../Check/DefEqProjectionDeltaPolicy.lean | 437 +++ .../Verify/Check/DefEqPropositionPolicy.lean | 168 ++ Ix/Tc/Verify/Check/FullInference.lean | 96 + .../Check/FullInferenceApplications.lean | 460 +++ Ix/Tc/Verify/Check/FullInferenceBinders.lean | 657 ++++ Ix/Tc/Verify/Check/FullInferenceCache.lean | 198 ++ .../Verify/Check/FullInferenceDispatcher.lean | 175 ++ Ix/Tc/Verify/Check/FullInferenceKnot.lean | 230 ++ Ix/Tc/Verify/Check/FullInferenceLeaves.lean | 182 ++ .../Check/FullInferenceProjections.lean | 127 + Ix/Tc/Verify/Check/InferencePolicy.lean | 681 +++++ Ix/Tc/Verify/Check/MemberEvidence.lean | 499 +++ Ix/Tc/Verify/Check/NatAcceptance.lean | 587 ++++ Ix/Tc/Verify/Check/PositiveFuelSort.lean | 320 ++ Ix/Tc/Verify/Check/PreTranslation.lean | 115 + .../Check/PreTranslationCompatibility.lean | 171 ++ Ix/Tc/Verify/Check/PreTranslationIngress.lean | 381 +++ Ix/Tc/Verify/Check/PreTranslationOpening.lean | 190 ++ Ix/Tc/Verify/Check/PreTranslationScopes.lean | 374 +++ .../Check/ProjectionInferencePolicy.lean | 388 +++ Ix/Tc/Verify/Check/PublicBlocks.lean | 69 + Ix/Tc/Verify/Check/PublicStandalone.lean | 316 ++ Ix/Tc/Verify/Check/QuotientAdmission.lean | 260 ++ Ix/Tc/Verify/Check/QuotientBoundary.lean | 106 + Ix/Tc/Verify/Check/RecursiveMethodPolicy.lean | 81 + Ix/Tc/Verify/Check/ResetFrame.lean | 102 + Ix/Tc/Verify/Check/SafetyFrame.lean | 144 + Ix/Tc/Verify/Check/Scoped.lean | 77 + .../Verify/Check/ScopedBoundedPipelines.lean | 410 +++ Ix/Tc/Verify/Check/ScopedMemberEvidence.lean | 419 +++ .../Verify/Check/ScopedPositiveFuelAxiom.lean | 490 +++ .../Check/ScopedPositiveFuelCertificate.lean | 316 ++ .../Verify/Check/ScopedStandaloneDriver.lean | 262 ++ Ix/Tc/Verify/Check/SingletonInductive.lean | 297 ++ Ix/Tc/Verify/Check/StandaloneDriver.lean | 286 ++ .../Verify/Check/UncachedInferencePolicy.lean | 289 ++ .../Check/UniverseInstantiationPolicy.lean | 296 ++ Ix/Tc/Verify/Check/ValidationReach.lean | 407 +++ Ix/Tc/Verify/Check/ValidatorFrame.lean | 319 ++ Ix/Tc/Verify/Check/ValidatorSoundness.lean | 1225 ++++++++ Ix/Tc/Verify/Check/WhnfBasicHelperPolicy.lean | 458 +++ Ix/Tc/Verify/Check/WhnfBitVecPolicy.lean | 493 +++ Ix/Tc/Verify/Check/WhnfDecidablePolicy.lean | 354 +++ Ix/Tc/Verify/Check/WhnfDriverPolicy.lean | 550 ++++ Ix/Tc/Verify/Check/WhnfHelperPolicy.lean | 44 + Ix/Tc/Verify/Check/WhnfIotaBasePolicy.lean | 286 ++ .../Verify/Check/WhnfIotaDispatchPolicy.lean | 238 ++ .../Verify/Check/WhnfIotaRecursionPolicy.lean | 312 ++ Ix/Tc/Verify/Check/WhnfIotaScopePolicy.lean | 189 ++ .../Verify/Check/WhnfIotaSynthesisPolicy.lean | 346 +++ Ix/Tc/Verify/Check/WhnfNatArgumentPolicy.lean | 169 ++ Ix/Tc/Verify/Check/WhnfNatPolicy.lean | 468 +++ Ix/Tc/Verify/Check/WhnfNativePolicy.lean | 128 + Ix/Tc/Verify/Check/WhnfProjectionPolicy.lean | 272 ++ Ix/Tc/Verify/Check/WhnfReductionPolicy.lean | 600 ++++ Ix/Tc/Verify/DefEq.lean | 329 +- Ix/Tc/Verify/Driver/BooleanAcceptance.lean | 629 ++++ Ix/Tc/Verify/Driver/Dependencies.lean | 180 ++ Ix/Tc/Verify/Driver/Enumeration.lean | 563 ++++ Ix/Tc/Verify/Driver/Fixtures.lean | 181 ++ Ix/Tc/Verify/Driver/Model.lean | 369 +++ Ix/Tc/Verify/Driver/Serial.lean | 229 ++ Ix/Tc/Verify/Driver/SupportedAcceptance.lean | 543 ++++ .../Driver/SupportedAcceptanceFixtures.lean | 99 + Ix/Tc/Verify/Env.lean | 69 +- Ix/Tc/Verify/Execution.lean | 30 + Ix/Tc/Verify/Inductive.lean | 281 +- Ix/Tc/Verify/Inductive/Certificate.lean | 105 + .../Inductive/EnumerationAcceptance.lean | 637 ++++ .../Verify/Inductive/EnumerationFixture.lean | 1259 ++++++++ Ix/Tc/Verify/Inductive/IngressExecution.lean | 506 ++++ Ix/Tc/Verify/Inductive/IotaPattern.lean | 145 + .../Inductive/OccurrenceValidation.lean | 551 ++++ Ix/Tc/Verify/Inductive/RuleApplication.lean | 279 ++ .../Inductive/SingletonEnumeration.lean | 704 +++++ Ix/Tc/Verify/Inductive/SingletonFamily.lean | 471 +++ Ix/Tc/Verify/Inductive/SingletonIngress.lean | 313 ++ Ix/Tc/Verify/Inductive/SingletonOracle.lean | 121 + Ix/Tc/Verify/Inductive/SingletonRecursor.lean | 302 ++ .../Inductive/SpecializationIdentity.lean | 69 + Ix/Tc/Verify/Infer.lean | 6 + Ix/Tc/Verify/Infer/BinderScopes.lean | 77 +- Ix/Tc/Verify/Infer/CacheSoundness.lean | 19 + Ix/Tc/Verify/Infer/LetScopes.lean | 77 +- Ix/Tc/Verify/Ingress/AnonStructural.lean | 225 ++ Ix/Tc/Verify/Ingress/LiteralBlobs.lean | 465 +++ Ix/Tc/Verify/Ingress/Representation.lean | 264 ++ Ix/Tc/Verify/Ingress/SerializedBoolean.lean | 999 ++++++ Ix/Tc/Verify/Monad.lean | 20 + Ix/Tc/Verify/NatFixture.lean | 3 +- .../Verify/RecursiveMethods/CallDomains.lean | 486 +++ .../FiniteSupportBoundary.lean | 96 + Ix/Tc/Verify/RecursiveMethods/Inference.lean | 263 ++ Ix/Tc/Verify/RecursiveMethods/Public.lean | 221 ++ .../RecursiveMethods/ScopedCallDomains.lean | 317 ++ .../RecursiveMethods/ScopedInference.lean | 292 ++ .../RecursiveMethods/ScopedSortInference.lean | 238 ++ .../RecursiveMethods/SortInference.lean | 252 ++ Ix/Tc/Verify/ScopedSuffix/ClosedContext.lean | 194 ++ Ix/Tc/Verify/State.lean | 21 + Ix/Tc/Verify/Statements.lean | 200 +- Ix/Tc/Verify/Suffix.lean | 123 + Ix/Tc/Verify/Totalization.lean | 38 +- Ix/Tc/Verify/Whnf.lean | 61 +- Ix/Tc/Verify/Whnf/Delta/CacheSemantics.lean | 6 + Ix/Tc/Verify/Whnf/Iota/NatReduction.lean | 7 +- .../Verify/Whnf/Iota/RuleSuffixTransport.lean | 3 +- Ix/Tc/Verify/Whnf/Iota/SelectedRule.lean | 3 +- .../Verify/Whnf/NoDelta/StringPrimitive.lean | 5 +- Ix/Tc/Verify/World.lean | 127 +- Ix/Tc/Whnf.lean | 218 +- Tests/Ix/AuxGen/RecursorTests.lean | 85 +- Tests/Ix/Tc/CheckTests.lean | 365 ++- Tests/Ix/Tc/WhnfTests.lean | 15 + crates/compile/src/compile/aux_gen/nested.rs | 223 +- crates/ffi/blake3_native_decide.c | 108 + crates/kernel/src/check.rs | 612 +++- crates/kernel/src/constant.rs | 5 + crates/kernel/src/env.rs | 8 + crates/kernel/src/inductive.rs | 2302 +++++++++++--- crates/kernel/src/tc.rs | 9 +- crates/kernel/src/whnf.rs | 55 + lake-manifest.json | 6 +- lakefile.lean | 56 +- 162 files changed, 44277 insertions(+), 2008 deletions(-) create mode 100644 .github/fixtures/tc-parity-consts.txt create mode 100644 Ix/Tc/Verify/Check/Acceptance.lean create mode 100644 Ix/Tc/Verify/Check/BinderRoundTrip.lean create mode 100644 Ix/Tc/Verify/Check/BlockAcceptance.lean create mode 100644 Ix/Tc/Verify/Check/BlockCache.lean create mode 100644 Ix/Tc/Verify/Check/BlockClassification.lean create mode 100644 Ix/Tc/Verify/Check/BlockDefinition.lean create mode 100644 Ix/Tc/Verify/Check/BlockExecution.lean create mode 100644 Ix/Tc/Verify/Check/BlockIdentity.lean create mode 100644 Ix/Tc/Verify/Check/BlockNatFixture.lean create mode 100644 Ix/Tc/Verify/Check/BlockOracle.lean create mode 100644 Ix/Tc/Verify/Check/BlockRouteFrame.lean create mode 100644 Ix/Tc/Verify/Check/BlockRouting.lean create mode 100644 Ix/Tc/Verify/Check/BlockTransaction.lean create mode 100644 Ix/Tc/Verify/Check/BoundedPipelines.lean create mode 100644 Ix/Tc/Verify/Check/CheckConstExecution.lean create mode 100644 Ix/Tc/Verify/Check/CheckConstTransaction.lean create mode 100644 Ix/Tc/Verify/Check/CheckerEvidence.lean create mode 100644 Ix/Tc/Verify/Check/DeclarationIngress.lean create mode 100644 Ix/Tc/Verify/Check/DeclarationValidation.lean create mode 100644 Ix/Tc/Verify/Check/DefEqBasicPolicy.lean create mode 100644 Ix/Tc/Verify/Check/DefEqCachePolicy.lean create mode 100644 Ix/Tc/Verify/Check/DefEqEtaPolicy.lean create mode 100644 Ix/Tc/Verify/Check/DefEqFinalWhnfPolicy.lean create mode 100644 Ix/Tc/Verify/Check/DefEqLazyDeltaPolicy.lean create mode 100644 Ix/Tc/Verify/Check/DefEqNatPolicy.lean create mode 100644 Ix/Tc/Verify/Check/DefEqPipelinePolicy.lean create mode 100644 Ix/Tc/Verify/Check/DefEqProjectionDeltaPolicy.lean create mode 100644 Ix/Tc/Verify/Check/DefEqPropositionPolicy.lean create mode 100644 Ix/Tc/Verify/Check/FullInference.lean create mode 100644 Ix/Tc/Verify/Check/FullInferenceApplications.lean create mode 100644 Ix/Tc/Verify/Check/FullInferenceBinders.lean create mode 100644 Ix/Tc/Verify/Check/FullInferenceCache.lean create mode 100644 Ix/Tc/Verify/Check/FullInferenceDispatcher.lean create mode 100644 Ix/Tc/Verify/Check/FullInferenceKnot.lean create mode 100644 Ix/Tc/Verify/Check/FullInferenceLeaves.lean create mode 100644 Ix/Tc/Verify/Check/FullInferenceProjections.lean create mode 100644 Ix/Tc/Verify/Check/InferencePolicy.lean create mode 100644 Ix/Tc/Verify/Check/MemberEvidence.lean create mode 100644 Ix/Tc/Verify/Check/NatAcceptance.lean create mode 100644 Ix/Tc/Verify/Check/PositiveFuelSort.lean create mode 100644 Ix/Tc/Verify/Check/PreTranslation.lean create mode 100644 Ix/Tc/Verify/Check/PreTranslationCompatibility.lean create mode 100644 Ix/Tc/Verify/Check/PreTranslationIngress.lean create mode 100644 Ix/Tc/Verify/Check/PreTranslationOpening.lean create mode 100644 Ix/Tc/Verify/Check/PreTranslationScopes.lean create mode 100644 Ix/Tc/Verify/Check/ProjectionInferencePolicy.lean create mode 100644 Ix/Tc/Verify/Check/PublicBlocks.lean create mode 100644 Ix/Tc/Verify/Check/PublicStandalone.lean create mode 100644 Ix/Tc/Verify/Check/QuotientAdmission.lean create mode 100644 Ix/Tc/Verify/Check/QuotientBoundary.lean create mode 100644 Ix/Tc/Verify/Check/RecursiveMethodPolicy.lean create mode 100644 Ix/Tc/Verify/Check/ResetFrame.lean create mode 100644 Ix/Tc/Verify/Check/SafetyFrame.lean create mode 100644 Ix/Tc/Verify/Check/Scoped.lean create mode 100644 Ix/Tc/Verify/Check/ScopedBoundedPipelines.lean create mode 100644 Ix/Tc/Verify/Check/ScopedMemberEvidence.lean create mode 100644 Ix/Tc/Verify/Check/ScopedPositiveFuelAxiom.lean create mode 100644 Ix/Tc/Verify/Check/ScopedPositiveFuelCertificate.lean create mode 100644 Ix/Tc/Verify/Check/ScopedStandaloneDriver.lean create mode 100644 Ix/Tc/Verify/Check/SingletonInductive.lean create mode 100644 Ix/Tc/Verify/Check/StandaloneDriver.lean create mode 100644 Ix/Tc/Verify/Check/UncachedInferencePolicy.lean create mode 100644 Ix/Tc/Verify/Check/UniverseInstantiationPolicy.lean create mode 100644 Ix/Tc/Verify/Check/ValidationReach.lean create mode 100644 Ix/Tc/Verify/Check/ValidatorFrame.lean create mode 100644 Ix/Tc/Verify/Check/ValidatorSoundness.lean create mode 100644 Ix/Tc/Verify/Check/WhnfBasicHelperPolicy.lean create mode 100644 Ix/Tc/Verify/Check/WhnfBitVecPolicy.lean create mode 100644 Ix/Tc/Verify/Check/WhnfDecidablePolicy.lean create mode 100644 Ix/Tc/Verify/Check/WhnfDriverPolicy.lean create mode 100644 Ix/Tc/Verify/Check/WhnfHelperPolicy.lean create mode 100644 Ix/Tc/Verify/Check/WhnfIotaBasePolicy.lean create mode 100644 Ix/Tc/Verify/Check/WhnfIotaDispatchPolicy.lean create mode 100644 Ix/Tc/Verify/Check/WhnfIotaRecursionPolicy.lean create mode 100644 Ix/Tc/Verify/Check/WhnfIotaScopePolicy.lean create mode 100644 Ix/Tc/Verify/Check/WhnfIotaSynthesisPolicy.lean create mode 100644 Ix/Tc/Verify/Check/WhnfNatArgumentPolicy.lean create mode 100644 Ix/Tc/Verify/Check/WhnfNatPolicy.lean create mode 100644 Ix/Tc/Verify/Check/WhnfNativePolicy.lean create mode 100644 Ix/Tc/Verify/Check/WhnfProjectionPolicy.lean create mode 100644 Ix/Tc/Verify/Check/WhnfReductionPolicy.lean create mode 100644 Ix/Tc/Verify/Driver/BooleanAcceptance.lean create mode 100644 Ix/Tc/Verify/Driver/Dependencies.lean create mode 100644 Ix/Tc/Verify/Driver/Enumeration.lean create mode 100644 Ix/Tc/Verify/Driver/Fixtures.lean create mode 100644 Ix/Tc/Verify/Driver/Model.lean create mode 100644 Ix/Tc/Verify/Driver/Serial.lean create mode 100644 Ix/Tc/Verify/Driver/SupportedAcceptance.lean create mode 100644 Ix/Tc/Verify/Driver/SupportedAcceptanceFixtures.lean create mode 100644 Ix/Tc/Verify/Inductive/Certificate.lean create mode 100644 Ix/Tc/Verify/Inductive/EnumerationAcceptance.lean create mode 100644 Ix/Tc/Verify/Inductive/EnumerationFixture.lean create mode 100644 Ix/Tc/Verify/Inductive/IngressExecution.lean create mode 100644 Ix/Tc/Verify/Inductive/IotaPattern.lean create mode 100644 Ix/Tc/Verify/Inductive/OccurrenceValidation.lean create mode 100644 Ix/Tc/Verify/Inductive/RuleApplication.lean create mode 100644 Ix/Tc/Verify/Inductive/SingletonEnumeration.lean create mode 100644 Ix/Tc/Verify/Inductive/SingletonFamily.lean create mode 100644 Ix/Tc/Verify/Inductive/SingletonIngress.lean create mode 100644 Ix/Tc/Verify/Inductive/SingletonOracle.lean create mode 100644 Ix/Tc/Verify/Inductive/SingletonRecursor.lean create mode 100644 Ix/Tc/Verify/Inductive/SpecializationIdentity.lean create mode 100644 Ix/Tc/Verify/Ingress/AnonStructural.lean create mode 100644 Ix/Tc/Verify/Ingress/LiteralBlobs.lean create mode 100644 Ix/Tc/Verify/Ingress/Representation.lean create mode 100644 Ix/Tc/Verify/Ingress/SerializedBoolean.lean create mode 100644 Ix/Tc/Verify/RecursiveMethods/CallDomains.lean create mode 100644 Ix/Tc/Verify/RecursiveMethods/FiniteSupportBoundary.lean create mode 100644 Ix/Tc/Verify/RecursiveMethods/Inference.lean create mode 100644 Ix/Tc/Verify/RecursiveMethods/Public.lean create mode 100644 Ix/Tc/Verify/RecursiveMethods/ScopedCallDomains.lean create mode 100644 Ix/Tc/Verify/RecursiveMethods/ScopedInference.lean create mode 100644 Ix/Tc/Verify/RecursiveMethods/ScopedSortInference.lean create mode 100644 Ix/Tc/Verify/RecursiveMethods/SortInference.lean create mode 100644 Ix/Tc/Verify/ScopedSuffix/ClosedContext.lean create mode 100644 crates/ffi/blake3_native_decide.c diff --git a/.github/fixtures/tc-parity-consts.txt b/.github/fixtures/tc-parity-consts.txt new file mode 100644 index 000000000..c1fef41ac --- /dev/null +++ b/.github/fixtures/tc-parity-consts.txt @@ -0,0 +1,19 @@ +# Exact seed closures required by tc-pins. +Std.DTreeMap.Internal.Impl.minEntry!_eq_get!_minEntry? +Std.DTreeMap.Internal.Impl.Const.minEntry!_eq_get!_minEntry? +Std.DTreeMap.Internal.Impl.minKey!_eq_get!_minKey? +Std.Internal.List.minKey!_eq_head!_keys +# Pulls in _private.Init.Data.Char.Ordinal.«0».Char.succ?_eq._proof_1_8. +Char.succ?_eq +Std.DHashMap.Internal.Raw₀.insertMany_cons +Std.Tactic.BVDecide.BVExpr.Cache.Inv_insert +Std.Tactic.BVDecide.BVExpr.bitblast.blastUdiv.denote_blastDivSubtractShift_q + +# Definitions required by the genuine-pure side of tc-accel-diff. +BitVec.toNat +BitVec.ofNat +BitVec.ult +Nat.decLe +Nat.decEq +Decidable.isTrue +Decidable.isFalse diff --git a/.github/scripts/check_tc_verify_sorries.pl b/.github/scripts/check_tc_verify_sorries.pl index 457d2c363..3ffcb4742 100644 --- a/.github/scripts/check_tc_verify_sorries.pl +++ b/.github/scripts/check_tc_verify_sorries.pl @@ -17,12 +17,7 @@ my $repo_root = abs_path(File::Spec->catdir($RealBin, '..', '..')); my $verify_root = File::Spec->catdir($repo_root, 'Ix', 'Tc', 'Verify'); -my %expected = ( - "Ix/Tc/Verify/Statements.lean\0TcM.whnf.wf" => 1, - "Ix/Tc/Verify/Statements.lean\0TcM.infer.wf" => 1, - "Ix/Tc/Verify/Statements.lean\0TcM.isDefEq.wf" => 1, - "Ix/Tc/Verify/Statements.lean\0TcM.checkConst.wf" => 1, -); +my %expected = (); sub mask_chunk { my ($chunk) = @_; diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 12d67a36a..d1f072b71 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -66,6 +66,25 @@ jobs: run: lake build Ix.Tc.Verify.Audit.Completed Ix.Tc.Verify.Audit.Statements - name: Build Ix.Tc formal verification run: lake build IxTcVerify + # The verification release claim includes executable adversarial and + # production-parity evidence. Its exact pin/accelerator seed closure is + # deliberately separate from the much smaller zkVM smoke fixture. Doing + # this after lean-action avoids another Lean build/cache consumer and + # keeps lean-test independent of the zkVM artifact producer. + - name: Test Ix.Tc unit and adversarial fixtures + run: lake test --wfail -- tc-unit + - name: Compile Ix.Tc parity fixture + run: >- + lake exe ix compile Ix.lean + --consts-file .github/fixtures/tc-parity-consts.txt + --out tc-parity.ixe + - name: Test Ix.Tc production parity and scale + run: >- + lake test --wfail -- --ignored + tc-pins tc-accel-diff tc-anon-diff tc-roundtrip tc-init + tc-tutorial lean4lean + env: + IX_PINS_IXE: tc-parity.ixe - name: Check codegen'd IxVM kernel is up to date run: lake exe ix codegen --check - name: Test Ix CLI diff --git a/Ix/AuxGen/Recursor.lean b/Ix/AuxGen/Recursor.lean index 7fe0f2209..d456cf872 100644 --- a/Ix/AuxGen/Recursor.lean +++ b/Ix/AuxGen/Recursor.lean @@ -193,49 +193,6 @@ def abstractSpecParamsToBVars (specParams : Array Expr) m.insert d.fvarName i specParams.map fun sp => batchAbstract sp fvarMap n 0 -/-- Mirrors Rust `level_max_raw` (aux_gen/nested.rs:1989, local fn inside - `maximize_occurrence_levels`): `max(a, b)` with only zero elimination, - matching Lean's `mkLevelMax` behavior. -/ -def levelMaxRaw (a b : Level) : Level := - if a == b then a - else if a matches .zero _ then b - else if b matches .zero _ then a - else Level.mkMax a b - -/-- Mirrors Rust `maximize_occurrence_levels` (aux_gen/nested.rs:1958). - - Maximize occurrence levels across all auxiliaries sharing the same - external inductive name: pointwise `levelMaxRaw` of - `occurrenceLevelArgs` across all auxiliaries with the same `name`, - then apply the merged levels to all of them. -/ -def maximizeOccurrenceLevels (flat : Array FvarFlatMember) (nOriginals : Nat) : - Array FvarFlatMember := Id.run do - -- Group auxiliary members by external inductive name. - let mut maxLevels : Std.HashMap Name (Array Level) := {} - for entry in flat.extract nOriginals flat.size do - -- Rust `entry().or_insert_with(occ)` then pointwise max when lengths - -- match; on the fresh insert the max is `max(x, x) = x`. - let merged := (maxLevels.get? entry.name).getD entry.occurrenceLevelArgs - let merged := - if merged.size == entry.occurrenceLevelArgs.size then - (merged.zip entry.occurrenceLevelArgs).map fun (m, e) => levelMaxRaw m e - else merged - maxLevels := maxLevels.insert entry.name merged - -- Apply the maximized levels to all auxiliaries. - let mut out : Array FvarFlatMember := #[] - for (entry, i) in flat.zipIdx do - if i < nOriginals then - out := out.push entry - else - match maxLevels.get? entry.name with - | some merged => - if merged.size == entry.occurrenceLevelArgs.size then - out := out.push { entry with occurrenceLevelArgs := merged } - else - out := out.push entry - | none => out := out.push entry - return out - /-- Mirrors Rust `try_detect_nested_fvar` (aux_gen/nested.rs:2003). Check if a field domain contains a nested inductive occurrence and, if @@ -245,10 +202,12 @@ def maximizeOccurrenceLevels (flat : Array FvarFlatMember) (nOriginals : Nat) : mentions an original block inductive. Rust mutates `flat`/`aux_seen` in place; here they are passed and returned. -/ def tryDetectNestedFVar (dom : Expr) (blockNames : Std.HashSet Name) - (flat : Array FvarFlatMember) (auxSeen : Array (Name × Array Address)) + (flat : Array FvarFlatMember) + (auxSeen : Array (Name × Array Address × Array Address)) (overlay : Option (Std.HashMap Name ConstantInfo)) (blockParamFvarNames : Array Name) : - CompileM (Array FvarFlatMember × Array (Name × Array Address)) := do + CompileM + (Array FvarFlatMember × Array (Name × Array Address × Array Address)) := do -- Peel foralls structurally to get to the result type. Note: NOT -- forallTelescope — peeled binders introduce BVars in the body, which -- `hasInvalidSpecRef` flags if they leak into a spec_param. @@ -292,14 +251,17 @@ def tryDetectNestedFVar (dom : Expr) (blockNames : Std.HashSet Name) if hasInvalidSpecRef sp blockParamFvarNames then return (flat, auxSeen) - -- Dedup by (ext ind name, spec_param content hashes). FVar naming is - -- deterministic (_bp_0, _bp_1, ...) so hashing in FVar form is stable. + -- Dedup by the complete nested application identity. Universe arguments + -- remain distinct even when the family and term-parameter spine agree. + let levelHashes : Array Address := headLevels.map (·.getHash) let specHashes : Array Address := specParams.map (·.getHash) - if auxSeen.any (fun (name, hashes) => - name == headName && hashes.size == specHashes.size + if auxSeen.any (fun (name, levels, hashes) => + name == headName && levels.size == levelHashes.size + && (levels.zip levelHashes).all fun (a, b) => a == b + && hashes.size == specHashes.size && (hashes.zip specHashes).all fun (a, b) => a == b) then return (flat, auxSeen) - let auxSeen := auxSeen.push (headName, specHashes) + let auxSeen := auxSeen.push (headName, levelHashes, specHashes) -- Use the raw levels from the Const node in the constructor type. let flat := flat.push @@ -336,7 +298,7 @@ an inductive)") let blockParamFvarNames : Array Name := blockParamDecls.map (·.fvarName) let mut flat : Array FvarFlatMember := #[] - let mut auxSeen : Array (Name × Array Address) := #[] + let mut auxSeen : Array (Name × Array Address × Array Address) := #[] let blockNameSet : Std.HashSet Name := orderedOriginals.foldl (init := {}) (·.insert ·) @@ -396,9 +358,6 @@ inductive)") flat := flat' auxSeen := auxSeen' - -- Maximize occurrence levels per external inductive name. - flat := maximizeOccurrenceLevels flat orderedOriginals.size - -- Convert FVar-form spec_params back to BVar form for the output. return flat.map fun entry => { name := entry.name diff --git a/Ix/Tc/Check.lean b/Ix/Tc/Check.lean index c884d6d0f..e67880081 100644 --- a/Ix/Tc/Check.lean +++ b/Ix/Tc/Check.lean @@ -34,6 +34,13 @@ inductive CheckBlockKind where | recursor deriving BEq, Repr, Inhabited +/-- State update performed when a coordinated check publishes its captured +verdict. All fields except `env.blockCheckResults` are preserved exactly. -/ +def TcState.withBlockCheckResult (state : TcState m) (block : KId m) + (result : Except (TcError m) Unit) : TcState m := + { state with env := { state.env with blockCheckResults := + state.env.blockCheckResults.insert block result } } + namespace RecM -- ### Safety lattice @@ -105,31 +112,183 @@ def countForalls (ty : KExpr m) : RecM m Nat := do modify fun s => { s with lctx := s.lctx.truncate saved } return .done n) maxWhnfFuel.toNat (ty, 0) +/-- Implicit binder metadata for canonical primitive types. Binder metadata is + hash-neutral in `KExpr`; retaining Lean's source binder info here makes the + builder readable and keeps meta-mode egress faithful. -/ +@[inline] def quotImplicitBi : {m : Mode} → m.F Lean.BinderInfo := + Mode.fieldWith fun _ => .implicit + +@[inline] def canonicalVar (idx : UInt64) : KExpr m := + .mkVar idx anonN + +@[inline] def canonicalAll (bi : m.F Lean.BinderInfo) + (dom body : KExpr m) : KExpr m := + .mkAll anonN bi dom body + +@[inline] def canonicalArrow (dom body : KExpr m) : KExpr m := + canonicalAll anonBi dom body + +/-- `α → α → Prop` at a point where `α` is `Var(0)`. -/ +def canonicalQuotRelation : KExpr m := + canonicalArrow (canonicalVar 0) + (canonicalArrow (canonicalVar 1) (.mkSort .mkZero)) + +/-- Exact semantic type required of the `Eq` prerequisite used by + `Environment.addQuot`. -/ +def canonicalEqType : KExpr m := + let u : KUniv m := .mkParam 0 anonN + canonicalAll quotImplicitBi (.mkSort u) + (canonicalAll anonBi (canonicalVar 0) + (canonicalAll anonBi (canonicalVar 1) (.mkSort .mkZero))) + +/-- Exact semantic type required of the `Eq.refl` prerequisite used by + `Environment.addQuot`. -/ +def canonicalEqReflType (p : Primitives m) : KExpr m := + let u : KUniv m := .mkParam 0 anonN + let result := KExpr.mkAppN (.mkConst p.eq #[u]) + #[canonicalVar 1, canonicalVar 0, canonicalVar 0] + canonicalAll quotImplicitBi (.mkSort u) + (canonicalAll anonBi (canonicalVar 0) result) + +/-- Canonical type installed by Lean's `Environment.addQuot` for each + reserved quotient primitive. Names and binder info are metadata; the + de Bruijn structure, universes, primitive heads, and domains form the + semantic acceptance contract. -/ +def canonicalQuotType (p : Primitives m) (kind : Ix.QuotKind) : KExpr m := + let u : KUniv m := .mkParam 0 anonN + let v : KUniv m := .mkParam 1 anonN + let sortU : KExpr m := .mkSort u + let prop : KExpr m := .mkSort .mkZero + match kind with + | .type => + canonicalAll quotImplicitBi sortU + (canonicalAll anonBi canonicalQuotRelation sortU) + | .ctor => + let result := KExpr.mkAppN (.mkConst p.quotType #[u]) + #[canonicalVar 2, canonicalVar 1] + canonicalAll quotImplicitBi sortU + (canonicalAll anonBi canonicalQuotRelation + (canonicalAll anonBi (canonicalVar 1) result)) + | .lift => + let fTy := canonicalArrow (canonicalVar 2) (canonicalVar 1) + let rab := KExpr.mkAppN (canonicalVar 4) + #[canonicalVar 1, canonicalVar 0] + let fa := KExpr.mkApp (canonicalVar 3) (canonicalVar 2) + let fb := KExpr.mkApp (canonicalVar 3) (canonicalVar 1) + let faEqFb := KExpr.mkAppN (.mkConst p.eq #[v]) + #[canonicalVar 4, fa, fb] + let hTy := canonicalAll anonBi (canonicalVar 3) + (canonicalAll anonBi (canonicalVar 4) + (canonicalArrow rab faEqFb)) + let quotR := KExpr.mkAppN (.mkConst p.quotType #[u]) + #[canonicalVar 4, canonicalVar 3] + canonicalAll quotImplicitBi sortU + (canonicalAll quotImplicitBi canonicalQuotRelation + (canonicalAll quotImplicitBi (.mkSort v) + (canonicalAll anonBi fTy + (canonicalAll anonBi hTy + (canonicalArrow quotR (canonicalVar 3)))))) + | .ind => + let quotRD2 := KExpr.mkAppN (.mkConst p.quotType #[u]) + #[canonicalVar 1, canonicalVar 0] + let betaTy := canonicalArrow quotRD2 prop + let quotMkA := KExpr.mkAppN (.mkConst p.quotCtor #[u]) + #[canonicalVar 3, canonicalVar 2, canonicalVar 0] + let mkMinor := canonicalAll anonBi (canonicalVar 2) + (KExpr.mkApp (canonicalVar 1) quotMkA) + let quotRD4 := KExpr.mkAppN (.mkConst p.quotType #[u]) + #[canonicalVar 3, canonicalVar 2] + let result := KExpr.mkApp (canonicalVar 2) (canonicalVar 0) + canonicalAll quotImplicitBi sortU + (canonicalAll quotImplicitBi canonicalQuotRelation + (canonicalAll quotImplicitBi betaTy + (canonicalAll anonBi mkMinor + (canonicalAll quotImplicitBi quotRD4 result)))) + +/-! ### Block classification data -/ + +/-- Accumulator used while production classifies one complete physical block. +Keeping it named exposes the homogeneous-kind check to verification without +changing the order or error behavior of member lookups. -/ +structure BlockClassFlags where + sawDefn : Bool := false + sawRecr : Bool := false + sawInductiveLike : Bool := false + deriving Repr, Inhabited + +namespace BlockClassFlags + +/-- The initial empty shape census. -/ +def empty : BlockClassFlags := ⟨false, false, false⟩ + +/-- Record the declaration shape of one loaded member, or reject a shape +which is intentionally outside coordinated checking. -/ +def note (flags : BlockClassFlags) (member : KId m) (c : KConst m) : + Except (TcError m) BlockClassFlags := + match c with + | .defn .. => .ok { flags with sawDefn := true } + | .recr .. => .ok { flags with sawRecr := true } + | .indc .. | .ctor .. => .ok { flags with sawInductiveLike := true } + | .axio .. | .quot .. => + .error (.other s!"unsupported check block {member}: axiom/quotient member") + +/-- Convert the complete shape census to the one supported homogeneous +checker branch. -/ +def finish (flags : BlockClassFlags) : Except (TcError m) CheckBlockKind := + match flags.sawDefn, flags.sawInductiveLike, flags.sawRecr with + | true, false, false => .ok .defn + | false, true, false => .ok .inductive' + | false, false, true => .ok .recursor + | _, _, _ => + .error (.other "unsupported mixed check block: expected only definitions, only inductives/constructors, or only recursors") + +end BlockClassFlags + mutual -/-- `Eq` must exist with 1 universe param, 2 params, and `Eq.refl` as its - single constructor (prerequisite for sound quot reduction). -/ +/-- `Eq` and `Eq.refl` must have the exact metadata and semantic types checked + by Lean before it installs the quotient primitives. -/ def checkEqType : RecM m Unit := do let p ← prims let eqC? := (← get).env.consts.fold (init := none) - fun acc id c => if id.addr == p.eq.addr then some c else acc - let some eqC := eqC? + fun acc id c => if id.addr == p.eq.addr then some (id, c) else acc + let some (_, eqC) := eqC? | throw (.other "check_eq_type: Eq not found in environment") match eqC with - | .indc (lvls := lvls) (params := params) (ctors := ctors) .. => + | .indc (lvls := lvls) (params := params) (indices := indices) + (isUnsafe := isUnsafe) (ty := ty) (ctors := ctors) .. => if lvls != 1 then throw (.other s!"check_eq_type: Eq expects 1 universe param, got {lvls}") if params != 2 then throw (.other s!"check_eq_type: Eq expects 2 params (α, a), got {params}") + if indices != 1 then + throw (.other s!"check_eq_type: Eq expects 1 index, got {indices}") + if isUnsafe then + throw (.other "check_eq_type: Eq must be safe") if ctors.size != 1 then throw (.other s!"check_eq_type: Eq expects 1 constructor, got {ctors.size}") if ctors[0]!.addr != p.eqRefl.addr then throw (.other "check_eq_type: Eq's constructor is not Eq.refl") + if ty.addr != (canonicalEqType (m := m)).addr then + throw (.other "check_eq_type: Eq type is not canonical") | _ => throw (.other "check_eq_type: Eq not found or not inductive") + let reflC? := (← get).env.consts.fold (init := none) + fun acc id c => if id.addr == p.eqRefl.addr then some c else acc + let some reflC := reflC? + | throw (.other "check_eq_type: Eq.refl not found") + match reflC with + | .ctor (isUnsafe := isUnsafe) (lvls := lvls) (induct := induct) + (cidx := cidx) (params := params) (fields := fields) (ty := ty) .. => + if isUnsafe || lvls != 1 || induct.addr != p.eq.addr || cidx != 0 + || params != 2 || fields != 0 then + throw (.other "check_eq_type: Eq.refl metadata is not canonical") + if ty.addr != (canonicalEqReflType p).addr then + throw (.other "check_eq_type: Eq.refl type is not canonical") + | _ => throw (.other "check_eq_type: Eq.refl not found or not a constructor") /-- Quot structure: address ↔ kind consistency against the primitive table, - universe counts (1/1/2/1), Eq shape for `lift`, and minimum forall - counts (2/3/6/5). -/ + universe counts (1/1/2/1), exact Eq/Eq.refl prerequisites for `lift`, + and the complete canonical type installed by Lean's `addQuot`. -/ def checkQuot (id : KId m) (kind : Ix.QuotKind) (lvls : UInt64) (ty : KExpr m) : RecM m Unit := do let p ← prims @@ -147,39 +306,34 @@ def checkQuot (id : KId m) (kind : Ix.QuotKind) (lvls : UInt64) | .type | .ctor | .ind => 1 if lvls != expectedLvls then throw (.other s!"check_quot: {repr kind} expects {expectedLvls} universe params, got {lvls}") + if ty.addr != (canonicalQuotType p kind).addr then + throw (.other s!"check_quot: {repr kind} type is not canonical") if kind == .lift then checkEqType - let expectedForalls : Nat := match kind with - | .type => 2 - | .ctor => 3 - | .lift => 6 - | .ind => 5 - let nForalls ← countForalls ty - if nForalls < expectedForalls then - throw (.other s!"check_quot: {repr kind} expects at least {expectedForalls} foralls, got {nForalls}") -- ### Block classification / coordination +/-- Ordered recursive form of the classifier's member loop. -/ +def collectBlockClassFlags (members : List (KId m)) + (flags : BlockClassFlags := BlockClassFlags.empty) : + RecM m BlockClassFlags := do + match members with + | [] => pure flags + | member :: rest => + let c ← TcM.getConst member + match flags.note member c with + | .error err => throw err + | .ok next => collectBlockClassFlags rest next +termination_by members.length + def classifyBlock (members : Array (KId m)) : RecM m CheckBlockKind := do if members.isEmpty then throw (.other "empty check block") - let mut sawDefn := false - let mut sawRecr := false - let mut sawInductiveLike := false - for member in members do - match (← TcM.getConst member) with - | .defn .. => sawDefn := true - | .recr .. => sawRecr := true - | .indc .. | .ctor .. => sawInductiveLike := true - | .axio .. | .quot .. => - throw (.other s!"unsupported check block {member}: axiom/quotient member") - match sawDefn, sawInductiveLike, sawRecr with - | true, false, false => return .defn - | false, true, false => return .inductive' - | false, false, true => return .recursor - | _, _, _ => - throw (.other "unsupported mixed check block: expected only definitions, only inductives/constructors, or only recursors") + let flags ← collectBlockClassFlags members.toList + match flags.finish with + | .ok kind => pure kind + | .error err => throw err def coordinatedBlockIfKind (block : KId m) (expected : CheckBlockKind) : RecM m (Option (KId m)) := do @@ -208,27 +362,40 @@ def coordinatedCheckBlockForConst (id : KId m) : -- ### Checking +/-- Capture the exact outcome of a fresh block body without publishing it. +The non-backtracking checker monad retains the body's post-state on either +outcome; `checkCoordinatedBlock` performs the sole cache insertion afterward. -/ +def captureBlockCheckResult (block requested : KId m) : + RecM m (Except (TcError m) Unit) := + try + checkBlockBody block requested + pure (Except.ok ()) + catch e => + pure (Except.error e) + +/-- Execute the coordinated suffix after routing has selected an exact +physical block. Naming this boundary keeps the cache-hit and fresh-body +transactions visible to verification: a fresh verdict is inserted only +after `checkBlockBody` has returned, and an error verdict is then replayed as +the call's error. -/ +def checkCoordinatedBlock (block requested : KId m) : RecM m Unit := do + if let some result := (← get).env.blockCheckResults[block]? then + match result with + | .ok () => return () + | .error e => throw e + let result ← captureBlockCheckResult block requested + modify fun s => s.withBlockCheckResult block result + match result with + | .ok () => return () + | .error e => throw e + /-- Type-check a single constant (block-coordinated when applicable; results memoized in `blockCheckResults` so failures replay per member). -/ def checkConst (id : KId m) : RecM m Unit := do let c ← TcM.getConst id - if let some block ← coordinatedBlockFor c then - if let some result := (← get).env.blockCheckResults[block]? then - match result with - | .ok () => return () - | .error e => throw e - let result ← - try - checkBlockBody block id - pure (Except.ok ()) - catch e => - pure (Except.error e) - modify fun s => { s with env := { s.env with - blockCheckResults := s.env.blockCheckResults.insert block result } } - match result with - | .ok () => return () - | .error e => throw e - checkConstMemberFresh id + match (← coordinatedBlockFor c) with + | some block => checkCoordinatedBlock block id + | none => checkConstMemberFresh id def checkConstMemberFresh (id : KId m) : RecM m Unit := do TcM.reset (m := m) @@ -257,9 +424,11 @@ def checkConstMember (id : KId m) (c : KConst m) : RecM m Unit := do checkNoUnsafeRefs ty safety checkNoUnsafeRefs val safety | .quot (ty := ty) (kind := kind) (lvls := lvls) .. => + -- Reject a forged reserved primitive before invoking inference or + -- reduction on attacker-controlled syntax. + checkQuot id kind lvls ty let t ← infer ty let _ ← ensureSortDirect t - checkQuot id kind lvls ty | .recr (ty := ty) .. => let t ← infer ty let _ ← ensureSortDirect t @@ -273,10 +442,10 @@ def checkConstMember (id : KId m) (c : KConst m) : RecM m Unit := do let _ ← ensureSortDirect t checkCtorAgainstInductiveMember id induct -def checkBlockBody (block : KId m) (requested : KId m) : - RecM m Unit := do - let members := (← TcM.tryGetBlock block).getD #[requested] - let kind ← classifyBlock members +/-- Execute the validation/checking phase after block lookup and +classification have fixed the complete member array and homogeneous kind. -/ +def checkClassifiedBlock (kind : CheckBlockKind) (block : KId m) + (members : Array (KId m)) : RecM m Unit := do if kind != .defn then for member in members do let c ← TcM.getConst member @@ -294,6 +463,13 @@ def checkBlockBody (block : KId m) (requested : KId m) : | .inductive' => checkInductiveBlock block members | .recursor => checkRecursorBlock block members +def checkBlockBody (block : KId m) (requested : KId m) : + RecM m Unit := do + let some members ← TcM.tryGetBlock block + | throw (.other s!"coordinated check block {block} disappeared while checking {requested}") + let kind ← classifyBlock members + checkClassifiedBlock kind block members + -- ### Inductive machinery (validation and recursor generation in Ix.Tc.Inductive) def checkInductiveMember (id : KId m) : RecM m Unit := diff --git a/Ix/Tc/Driver.lean b/Ix/Tc/Driver.lean index a0f12dccf..7bfec0914 100644 --- a/Ix/Tc/Driver.lean +++ b/Ix/Tc/Driver.lean @@ -62,44 +62,80 @@ def provenTargets : AnonWorkItem → Array Address end AnonWorkItem -/-- Enumerate the anon-mode kernel work set from `env.consts` (see module - doc). Errors only on a corrupted env. -/ -def buildAnonWork (env : Ixon.Env) : Except IngressErr (Array AnonWorkItem) := do - let mut work : Array AnonWorkItem := #[] - -- Ascending address order for deterministic run order. - let keys := env.consts.keys.toArray.qsort fun a b => a.cmpBytes b == .lt - for addr in keys do - let some lc := env.consts[addr]? - | throw s!"buildAnonWork: missing const at {addr}" - let tag ← match lc.peekTag with - | .ok t => pure t - | .error e => throw s!"buildAnonWork: peekTag {addr}: {e}" - match tag with - | .iPrj | .cPrj | .rPrj | .dPrj => - -- Skip — covered by parent block. - pure () - | .defn | .recr | .axio | .quot => - work := work.push (.standalone addr) - | .muts => +/-- Projection addresses contributed by one member of a Muts block, in the +exact flattened order used by ingress and block coordination. -/ +def anonMemberTargets (blockAddr : Address) (index : Nat) + (member : Ixon.MutConst) : Array Address := + let idx := index.toUInt64 + match member with + | .defn _ => #[defnProjAddr blockAddr idx] + | .recr _ => #[recrProjAddr blockAddr idx] + | .indc ind => + #[indcProjAddr blockAddr idx] ++ + (Array.range ind.ctors.size).map fun ctorIndex => + ctorProjAddr blockAddr idx ctorIndex.toUInt64 + +/-- Exact flattened projection target array for a Muts block. -/ +def anonBlockTargets (blockAddr : Address) + (members : Array Ixon.MutConst) : Array Address := + (Array.range members.size).flatMap fun index => + anonMemberTargets blockAddr index members[index]! + +namespace AnonWorkItem + +/-- Pure work classification after a constant has been materialized. -/ +def ofConstantInfo (addr : Address) : Ixon.ConstantInfo → Option AnonWorkItem + | .iPrj _ | .cPrj _ | .rPrj _ | .dPrj _ => none + | .defn _ | .recr _ | .axio _ | .quot _ => some (.standalone addr) + | .muts members => + let targets := anonBlockTargets addr members + match targets[0]? with + | none => none + | some primary => some (.block addr primary targets) + +end AnonWorkItem + +/-- The cheap leading-byte tag corresponding to a materialized constant. -/ +def constantInfoTag : Ixon.ConstantInfo → Ixon.ConstTag + | .defn _ => .defn + | .recr _ => .recr + | .axio _ => .axio + | .quot _ => .quot + | .muts _ => .muts + | .iPrj _ => .iPrj + | .cPrj _ => .cPrj + | .rPrj _ => .rPrj + | .dPrj _ => .dPrj + +/-- Deterministic source-key order shared by the implementation and E1's +coverage certificate. -/ +def orderedAnonConstAddrs (env : Ixon.Env) : Array Address := + env.consts.keys.toArray.qsort fun a b => a.cmpBytes b == .lt + +/-- Classify one source key. Non-Muts entries retain the cheap tag-only +path; only a Muts body is materialized to enumerate its projections. -/ +def buildAnonWorkItem (env : Ixon.Env) (addr : Address) : + Except IngressErr (Option AnonWorkItem) := do + let some lc := env.consts.get? addr + | throw s!"buildAnonWork: missing const at {addr}" + let tag ← match lc.peekTag with + | .ok t => pure t + | .error e => throw s!"buildAnonWork: peekTag {addr}: {e}" + match tag with + | .iPrj | .cPrj | .rPrj | .dPrj => return none + | .defn | .recr | .axio | .quot => return some (.standalone addr) + | .muts => let constant ← match lc.get with | .ok c => pure c | .error e => throw s!"buildAnonWork: materialize Muts {addr}: {e}" - let .muts members := constant.info + let .muts _ := constant.info | throw s!"buildAnonWork: Tag muts but ConstantInfo differs at {addr}" - let mut targets : Array Address := #[] - for h : i in [0:members.size] do - let idx := i.toUInt64 - match members[i] with - | .defn _ => targets := targets.push (defnProjAddr addr idx) - | .recr _ => targets := targets.push (recrProjAddr addr idx) - | .indc ind => - targets := targets.push (indcProjAddr addr idx) - for cidx in [0:ind.ctors.size] do - targets := targets.push (ctorProjAddr addr idx cidx.toUInt64) - if targets.isEmpty then - continue - work := work.push (.block addr targets[0]! targets) - return work + return AnonWorkItem.ofConstantInfo addr constant.info + +/-- Enumerate the anon-mode kernel work set from `env.consts` (see module + doc). Errors only on a corrupted env. -/ +def buildAnonWork (env : Ixon.Env) : Except IngressErr (Array AnonWorkItem) := do + orderedAnonConstAddrs env |>.filterMapM (buildAnonWorkItem env) /-- The ingress-block address that owns `addr`: a projection maps to its Muts block; anything else is its own block. -/ @@ -191,6 +227,14 @@ structure CheckResult where err? : Option String deriving Repr, Inhabited +/-- Explicit accumulator for the serial anonymous driver. Naming this +state makes the production loop available to E1's trace theorem without +changing its persistent-checker semantics. -/ +structure AnonCheckLoopState where + results : Array CheckResult + checker : TcState .anon + sinceClear : Nat + /-- Fresh anon checker state over `ixonEnv` with the lazy fault hook installed (constants ingress on demand as typechecking discovers them). Mirrors Rust `TypeChecker::new_with_lazy_anon`. -/ @@ -200,6 +244,45 @@ def TcState.newLazyAnon (ixonEnv : Ixon.Env) (verify : Bool := true) : prims := .ofAnonAddrs lazyFault := some fun addr => ingressAnonAddrShallow ixonEnv addr verify } +/-- Finish one serial item after the checker has produced its next concrete +state and verdict. -/ +def finishAnonCheckItem (cfg : CheckCfg) (before : AnonCheckLoopState) + (item : AnonWorkItem) (checker : TcState .anon) + (err? : Option String) : AnonCheckLoopState := + let results := before.results ++ item.targets.map fun target => + ⟨target, err?⟩ + let sinceClear := before.sinceClear + 1 + if cfg.clearEvery != 0 && sinceClear ≥ cfg.clearEvery then + { results + checker := { checker with env := checker.env.clearReductionCaches } + sinceClear := 0 } + else + { results, checker, sinceClear } + +/-- Execute one work item with the exact success/error handling used by the +serial driver. -/ +def runAnonCheckItem (cfg : CheckCfg) (before : AnonCheckLoopState) + (item : AnonWorkItem) : AnonCheckLoopState := + let primary : KId .anon := ⟨item.primary, ()⟩ + match (TcM.checkConst primary).run before.checker with + | .ok () checker => finishAnonCheckItem cfg before item checker none + | .error err checker => + finishAnonCheckItem cfg before item checker (some (toString err)) + +/-- Proof-visible recursive form of the production serial loop. -/ +def runAnonCheckList (cfg : CheckCfg) : + List AnonWorkItem → AnonCheckLoopState → AnonCheckLoopState + | [], state => state + | item :: rest, state => + runAnonCheckList cfg rest (runAnonCheckItem cfg state item) + +/-- Initial serial checker state for one Ixon environment. -/ +def initialAnonCheckLoopState (ixonEnv : Ixon.Env) (cfg : CheckCfg) : + AnonCheckLoopState := + { results := #[] + checker := TcState.newLazyAnon ixonEnv cfg.verifyHashes + sinceClear := 0 } + /-- Check every anon work item of `ixonEnv` with one persistent kernel env (lazy faulting makes the cross-item constant reuse pay off) and a fresh checker state per item. Verdicts are fanned to every target the item @@ -207,25 +290,8 @@ def TcState.newLazyAnon (ixonEnv : Ixon.Env) (verify : Bool := true) : def checkEnvAnon (ixonEnv : Ixon.Env) (cfg : CheckCfg := {}) : Except IngressErr (Array CheckResult) := do let work ← buildAnonWork ixonEnv - let mut results : Array CheckResult := #[] - let mut st := TcState.newLazyAnon ixonEnv cfg.verifyHashes - let mut sinceClear := 0 - for item in work do - let primary : KId .anon := ⟨item.primary, ()⟩ - let err? ← match (TcM.checkConst primary).run st with - | .ok () st' => - st := st' - pure none - | .error e st' => - st := st' - pure (some (toString e)) - for target in item.targets do - results := results.push ⟨target, err?⟩ - sinceClear := sinceClear + 1 - if cfg.clearEvery != 0 && sinceClear ≥ cfg.clearEvery then - st := { st with env := st.env.clearReductionCaches } - sinceClear := 0 - return results + return (runAnonCheckList cfg work.toList + (initialAnonCheckLoopState ixonEnv cfg)).results /-! ### Kernel ↔ Ixon roundtrip driver diff --git a/Ix/Tc/Env.lean b/Ix/Tc/Env.lean index f855304cd..84da2cc2f 100644 --- a/Ix/Tc/Env.lean +++ b/Ix/Tc/Env.lean @@ -80,6 +80,14 @@ end InternTable /-- Generated recursor, cached after inductive validation. -/ structure GeneratedRecursor (m : Mode) where indAddr : Address + /-- Canonical universe/term arities derived from the validated flat + inductive block. -/ + lvls : UInt64 + params : UInt64 + motives : UInt64 + minors : UInt64 + indices : UInt64 + isUnsafe : Bool ty : KExpr m rules : Array (RecRule m) diff --git a/Ix/Tc/Inductive.lean b/Ix/Tc/Inductive.lean index 3de498b72..dd5efd2de 100644 --- a/Ix/Tc/Inductive.lean +++ b/Ix/Tc/Inductive.lean @@ -61,7 +61,55 @@ structure FlatBlockMember (m : Mode) where occurrenceUs : Array (KUniv m) deriving Inhabited -instance : Inhabited (GeneratedRecursor m) := ⟨⟨default, default, #[]⟩⟩ +/-- One mutually-recursive family active during constructor positivity + checking. `concreteUs = none` denotes the root declaration's own + `Param(0), …` universe sequence; nested families retain the concrete + specialization at which they were encountered. -/ +structure PositivityGroup (m : Mode) where + addrs : Array Address + params : Array (KExpr m) + concreteUs : Option (Array (KUniv m)) + deriving Inhabited + +/-- Exact identity of one flattened nested-inductive specialization. + +Universe arguments are load-bearing: Lean may generate two auxiliaries for +the same external family and term-parameter spine when a phantom universe +parameter differs between occurrences. -/ +structure NestedSpecializationKey where + family : Address + universes : Array Address + parameters : Array Address + deriving BEq, Inhabited + +namespace NestedSpecializationKey + +/-- Exact flat-block identity of one concrete nested-family application. -/ +def ofApplication (family : Address) (universes : Array (KUniv m)) + (parameters : Array (KExpr m)) : NestedSpecializationKey := + { family + universes := universes.map (·.addr) + parameters := parameters.map (·.addr) } + +end NestedSpecializationKey + +/-- The exact flat-block key represented by a nested positivity group. +The root group has no concrete specialization and therefore no auxiliary key. -/ +def PositivityGroup.nestedSpecializationKey? + (group : PositivityGroup m) (family : Address) : + Option NestedSpecializationKey := + group.concreteUs.map fun universes => + NestedSpecializationKey.ofApplication family universes group.params + +/-- The flat-block key of the parameter prefix of one nested application. -/ +def nestedApplicationSpecializationKey (family : Address) + (universes : Array (KUniv m)) (args : Array (KExpr m)) + (nParams : Nat) : NestedSpecializationKey := + NestedSpecializationKey.ofApplication family universes + (args.extract 0 nParams) + +instance : Inhabited (GeneratedRecursor m) := + ⟨⟨default, 0, 0, 0, 0, 0, false, default, #[]⟩⟩ namespace RecM @@ -76,6 +124,23 @@ def sortedDedupIds (ids : Array (KId m)) : Array (KId m) := Id.run do | none => out := out.push id return out +/-- Sum declaration-derived natural-number counts while retaining the UInt64 + representation bound used by serialized metadata and de Bruijn indices. -/ +def checkedNatMetadataSum (label : String) (parts : Array Nat) : + RecM m UInt64 := do + let total := parts.foldl (· + ·) 0 + if total < UInt64.size then + return total.toUInt64 + throw (.other s!"{label} metadata sum overflow") + +/-- Sum attacker-controlled declaration arities without permitting UInt64 + wraparound. Reducer and recursor-generation paths consume these sums as + binder/major indices, so the combined value must describe the same layout + as the individual metadata fields. -/ +def checkedMetadataSum (label : String) (parts : Array UInt64) : + RecM m UInt64 := + checkedNatMetadataSum label (parts.map (·.toNat)) + /-- Sum of pending universe constructors in the validation worklist. -/ def univWorkSize : List (KUniv m) → Nat | [] => 0 @@ -292,7 +357,9 @@ def computeKTarget (indId : KId m) : RecM m Bool := do let blockInds ← discoverBlockInductives block if blockInds.size != 1 then return false - let resultLevel ← getResultSortLevel ty (indParams + indIndices).toNat + let indArity ← checkedMetadataSum "inductive params + indices" + #[indParams, indIndices] + let resultLevel ← getResultSortLevel ty indArity.toNat if !univEq resultLevel .mkZero then return false if ctors.size != 1 then @@ -331,50 +398,177 @@ def checkParamAgreement (indTy ctorTy : KExpr m) (nParams : Nat) : position in any constructor field. -/ def checkPositivity (ctorTy : KExpr m) (nParams : Nat) (blockAddrs : Array Address) : RecM m Unit := do - let mut ty := ctorTy - for _ in [0:nParams] do - let w ← whnf ty - match w with - | .all _ _ _ body _ => ty := body - | _ => return () - runBounded (fun ty => do - let w ← whnf ty - match w with - | .all _ _ dom body _ => - checkPositivityDomain dom blockAddrs - return .next body - | _ => return .done ()) maxWhnfFuel.toNat ty + let saved := (← get).lctx.size + let result ← + try + -- Open the shared parameter binders so recursive applications can be + -- compared with stable fvars, including below dependent field binders. + let mut ty := ctorTy + let mut paramFVars : Array (KExpr m) := Array.mkEmpty nParams + for _ in [0:nParams] do + let w ← whnf ty + match w with + | .all _ _ dom body _ => + let (open', fv, _) ← TcM.openBinderAnonWithFV dom body + paramFVars := paramFVars.push fv + ty := open' + | _ => return () + let groups : Array (PositivityGroup m) := + #[{ addrs := blockAddrs, params := paramFVars, concreteUs := none }] + runBounded (fun ty => do + let w ← whnf ty + match w with + | .all _ _ dom body _ => + checkPositivityDomain dom groups blockAddrs + let (open', _) ← TcM.openBinderAnon dom body + return .next open' + | _ => return .done ()) maxWhnfFuel.toNat ty + pure (Except.ok ()) + catch e => pure (Except.error e) + modify fun s => { s with lctx := s.lctx.truncate saved } + match result with + | .ok () => return () + | .error e => throw e + +/-- Pure universe-specialization guard shared by recursive-occurrence + validation and its proof layer. `none` is the root block's symbolic + `Param(0), ...` specialization; nested groups retain the concrete + occurrence universes. -/ +def positiveUniverseArgumentsAgree (group : PositivityGroup m) + (us : Array (KUniv m)) : Bool := + match group.concreteUs with + | some expected => + expected.size == us.size && + (List.range us.size).all fun i => univEq expected[i]! us[i]! + | none => + (List.range us.size).all fun i => + univEq us[i]! (.mkParam i.toUInt64 anonN : KUniv m) + +/-- Structurally recursive presentation of the stateful parameter-comparison + loop. `index` is the next source position and `remaining` is the exact + number of comparisons still required. -/ +def checkPositiveParametersFrom (id : KId m) + (args params : Array (KExpr m)) : Nat → Nat → RecM m Unit + | _, 0 => pure () + | index, remaining + 1 => do + if !(← isDefEq args[index]! params[index]!) then + throw (.other s!"positivity: recursive occurrence {id} has non-uniform parameter {index}: expected {params[index]!}, got {args[index]!}") + checkPositiveParametersFrom id args params (index + 1) remaining + +/-- The exact stateful parameter-comparison loop used by positivity. Naming + it separately exposes the successful recursive `isDefEq` trace to E2c + without changing the production comparison order or diagnostics. -/ +def checkPositiveParameters (id : KId m) (args params : Array (KExpr m)) + (nParams : Nat) : RecM m Unit := + checkPositiveParametersFrom id args params 0 nParams + +/-- Pure root-index guard. The slice begins exactly after the uniform + parameter prefix established by `checkPositiveParameters`. -/ +def positiveIndicesIndependent (args : Array (KExpr m)) (nParams : Nat) + (rootAddrs : Array Address) : Bool := + (args.extract nParams args.size).all fun index => + !exprMentionsAnyAddr index rootAddrs + +/-- The stateless prefix of recursive-application validation. Keeping the + original error values here makes the production control flow and the E2c + success characterization share one definition. -/ +def checkPositiveRecursiveApplicationPreconditions + (us : Array (KUniv m)) (args : Array (KExpr m)) + (group : PositivityGroup m) (nParams nIndices lvls : Nat) : + Except (TcError m) Unit := + if args.size = nParams + nIndices then + if us.size = lvls then + if positiveUniverseArgumentsAgree group us = true then + if group.params.size = nParams then + .ok () + else + .error (.other + "positivity: recursive occurrence parameter arity disagrees with its family") + else + .error (.other + "positivity: recursive occurrence has non-uniform universe arguments") + else + .error (.other + s!"positivity: recursive occurrence has wrong universe count: expected {lvls}, got {us.size}") + else + .error (.other + s!"positivity: recursive occurrence has wrong argument count: expected {nParams + nIndices}, got {args.size}") + +/-- Validate the already-resolved inductive header of an active recursive + application. Separating the lookup/match from these guards gives E2c an + exact successful-branch seam while preserving their production order. -/ +def checkPositiveRecursiveApplicationHeader (id : KId m) + (us : Array (KUniv m)) (args : Array (KExpr m)) + (group : PositivityGroup m) (rootAddrs : Array Address) + (nParams nIndices lvls : Nat) : RecM m Unit := do + match checkPositiveRecursiveApplicationPreconditions us args group nParams + nIndices lvls with + | .error err => throw err + | .ok () => + checkPositiveParameters id args group.params nParams + if !positiveIndicesIndependent args nParams rootAddrs then + throw (.other "positivity: recursive occurrence index mentions an active inductive") + +/-- Validate an application of an active recursive family: exact application + arity, uniform universe/parameter specialization, and index independence. -/ +def checkPositiveRecursiveApplication (id : KId m) (us : Array (KUniv m)) + (args : Array (KExpr m)) (groups : Array (PositivityGroup m)) + (rootAddrs : Array Address) : RecM m Unit := do + let some group := groups.find? (fun group => group.addrs.contains id.addr) + | throw (.other "positivity: missing recursive-family context") + match (← TcM.getConst id) with + | .indc (params := params) (indices := indices) (lvls := lvls) .. => + checkPositiveRecursiveApplicationHeader id us args group rootAddrs + params.toNat indices.toNat lvls.toNat + | _ => throw (.other "positivity: recursive head is not an inductive") + +/-- Test exact nested-family specialization. The same external inductive may + have multiple active groups when flattening discovers it at distinct + parameter specializations. -/ +def positivityGroupMatches (group : PositivityGroup m) (family : Address) + (us : Array (KUniv m)) (args : Array (KExpr m)) + (nParams : Nat) : Bool := + group.params.size == nParams && + group.nestedSpecializationKey? family == + some (nestedApplicationSpecializationKey family us args nParams) /-- Field-domain positivity: recurse through foralls (negative-position mentions reject), then require either a direct block-inductive application or a valid nested-inductive application (recursively checked with the augmented address set). -/ def checkPositivityDomain (dom : KExpr m) - (blockAddrs : Array Address) : RecM m Unit := - checkPositivityDomainFuel maxWhnfFuel.toNat dom blockAddrs + (groups : Array (PositivityGroup m)) + (activeAddrs : Array Address) : RecM m Unit := + checkPositivityDomainFuel maxWhnfFuel.toNat dom groups activeAddrs /-- Explicit call-depth bound for nested positivity. The old mutual recursion had no termination guard; exhausting this adversarial-input bound is the same local-loop failure used by bounded reduction. Sibling fields reuse the bound, so this measures nesting depth rather than total work. -/ def checkPositivityDomainFuel : - Nat → KExpr m → Array Address → RecM m Unit - | 0, _, _ => throw .maxRecDepth - | fuel + 1, dom, blockAddrs => do - if !exprMentionsAnyAddr dom blockAddrs then + Nat → KExpr m → Array (PositivityGroup m) → Array Address → RecM m Unit + | 0, _, _, _ => throw .maxRecDepth + | fuel + 1, dom, groups, activeAddrs => do + -- A helper family can occur at an unrelated specialization while it is on + -- the nested traversal stack. Only expressions that still contain the + -- original block are recursive occurrences for this positivity check. + let some rootGroup := groups[0]? + | throw (.other "positivity: missing root-family context") + let rootAddrs := rootGroup.addrs + if !exprMentionsAnyAddr dom rootAddrs then return () let w ← whnf dom match w with | .all _ _ innerDom innerBody _ => -- Inductive in the domain of a Pi = negative position. - if exprMentionsAnyAddr innerDom blockAddrs then + if exprMentionsAnyAddr innerDom rootAddrs then throw (.other "strict positivity violation") -- H4: open with an fvar so whnf works on dependent types. let saved := (← get).lctx.size let (innerOpen, _) ← TcM.openBinderAnon innerDom innerBody let result ← try - checkPositivityDomainFuel fuel innerOpen blockAddrs + checkPositivityDomainFuel fuel innerOpen groups activeAddrs pure (Except.ok ()) catch e => pure (Except.error e) @@ -386,32 +580,48 @@ def checkPositivityDomainFuel : let (head, args) := w.collectSpine match head with | .const id us _ => - if blockAddrs.contains id.addr then - return () + if rootAddrs.contains id.addr then + return (← checkPositiveRecursiveApplication id us args groups rootAddrs) -- Nested inductive: external inductive whose params mention the block. - let (nParams, block, ctors) ← match (← TcM.getConst id) with - | .indc (params := params) (block := block) (ctors := ctors) .. => - pure (params.toNat, block, ctors) + let (nParams, nIndices, lvls, block, ctors) ← + match (← TcM.getConst id) with + | .indc (params := params) (indices := indices) (lvls := lvls) + (block := block) (ctors := ctors) .. => + pure (params.toNat, indices.toNat, lvls.toNat, block, ctors) | _ => throw (.other "positivity: not a valid inductive app") + if args.size != nParams + nIndices || us.size != lvls then + throw (.other "positivity: malformed nested inductive application") + -- Repeated exact specialization closes an already-validated auxiliary + -- edge. The same address at a different specialization is a new + -- auxiliary, as in the two Array specializations of Lean.Doc.Block. + for group in groups do + if group.addrs.contains id.addr && + positivityGroupMatches group id.addr us args nParams then + for index in args.extract nParams args.size do + if exprMentionsAnyAddr index rootAddrs then + throw (.other "positivity: recursive occurrence index mentions an active inductive") + return () let hasNestedRef := (args.extract 0 (min nParams args.size)).any - (exprMentionsAnyAddr · blockAddrs) + (exprMentionsAnyAddr · rootAddrs) if !hasNestedRef then throw (.other "positivity: not a valid inductive app") -- Index args (after params) must not mention block inductives. for arg in args.extract nParams args.size do - if exprMentionsAnyAddr arg blockAddrs then + if exprMentionsAnyAddr arg rootAddrs then throw (.other "positivity: index mentions block inductive") -- Augmented address set: block + the external inductive's block. - let mut augmented := blockAddrs - for extId in (← discoverBlockInductives block) do - if !augmented.contains extId.addr then - augmented := augmented.push extId.addr + let extBlockInductives ← discoverBlockInductives block + let extAddrs := extBlockInductives.map (·.addr) + let augmented := activeAddrs ++ extAddrs let paramArgs := args.extract 0 (min nParams args.size) + let augmentedGroups := groups.push + { addrs := extAddrs, params := paramArgs, concreteUs := some us } for ctorId in ctors do let ctorTy ← match (← TcM.getConst ctorId) with | .ctor (ty := ty) .. => pure ty | _ => throw (.other "positivity: nested ctor not found") - checkNestedCtorFieldsFuel fuel ctorTy nParams paramArgs us augmented + checkNestedCtorFieldsFuel fuel ctorTy nParams paramArgs us + augmentedGroups augmented | _ => throw (.other "positivity: not a valid inductive app") /-- Nested-inductive field positivity: instantiate universes, strip the @@ -420,15 +630,16 @@ def checkPositivityDomainFuel : remaining field domain against the augmented address set. -/ def checkNestedCtorFields (ctorTy : KExpr m) (nParams : Nat) (paramArgs : Array (KExpr m)) (us : Array (KUniv m)) - (augmentedAddrs : Array Address) : RecM m Unit := + (groups : Array (PositivityGroup m)) + (activeAddrs : Array Address) : RecM m Unit := checkNestedCtorFieldsFuel maxWhnfFuel.toNat ctorTy nParams paramArgs us - augmentedAddrs + groups activeAddrs def checkNestedCtorFieldsFuel : Nat → KExpr m → Nat → Array (KExpr m) → Array (KUniv m) → - Array Address → RecM m Unit - | 0, _, _, _, _, _ => throw .maxRecDepth - | fuel + 1, ctorTy, nParams, paramArgs, us, augmentedAddrs => do + Array (PositivityGroup m) → Array Address → RecM m Unit + | 0, _, _, _, _, _, _ => throw .maxRecDepth + | fuel + 1, ctorTy, nParams, paramArgs, us, groups, activeAddrs => do let mut ty ← TcM.instantiateUnivParams ctorTy us for _ in [0:nParams] do let w ← whnf ty @@ -438,25 +649,26 @@ def checkNestedCtorFieldsFuel : -- Var(0) = innermost = LAST param after stripping; simulSubst maps -- Var(i) ↦ substs[i], so reverse the param order. ty ← TcM.runIntern (simulSubst ty paramArgs.reverse 0) - checkNestedCtorFieldsLoopFuel fuel ty augmentedAddrs + checkNestedCtorFieldsLoopFuel fuel ty groups activeAddrs def checkNestedCtorFieldsLoop (ty : KExpr m) - (augmentedAddrs : Array Address) : RecM m Unit := - checkNestedCtorFieldsLoopFuel maxWhnfFuel.toNat ty augmentedAddrs + (groups : Array (PositivityGroup m)) + (activeAddrs : Array Address) : RecM m Unit := + checkNestedCtorFieldsLoopFuel maxWhnfFuel.toNat ty groups activeAddrs def checkNestedCtorFieldsLoopFuel : - Nat → KExpr m → Array Address → RecM m Unit - | 0, _, _ => throw .maxRecDepth - | fuel + 1, ty, augmentedAddrs => do + Nat → KExpr m → Array (PositivityGroup m) → Array Address → RecM m Unit + | 0, _, _, _ => throw .maxRecDepth + | fuel + 1, ty, groups, activeAddrs => do let w ← whnf ty match w with | .all _ _ dom body _ => - checkPositivityDomainFuel fuel dom augmentedAddrs + checkPositivityDomainFuel fuel dom groups activeAddrs let saved := (← get).lctx.size let (open', _) ← TcM.openBinderAnon dom body let result ← try - checkNestedCtorFieldsLoopFuel fuel open' augmentedAddrs + checkNestedCtorFieldsLoopFuel fuel open' groups activeAddrs pure (Except.ok ()) catch e => pure (Except.error e) @@ -555,6 +767,34 @@ def checkCtorReturnType (ctorTy : KExpr m) -- ### Member / block validation +/-- Validate the constructor header fields which Lean derives from the parent + inductive declaration. Ix consumes these fields operationally (`cidx` for + iota dispatch, arities for applications/projections, and `isUnsafe` for + the safety lattice), so a well-typed constructor telescope alone is not a + sufficient admission check. -/ +def checkCtorMetadataAgainstParent (ctorId inductId : KId m) + (expectedCidx indParams : Nat) (indLvls : UInt64) + (indIsUnsafe : Bool) : RecM m (KExpr m × Nat) := do + let (ctorTy, ctorInduct, ctorCidx, ctorParams, ctorFields, ctorLvls, + ctorIsUnsafe) ← match (← TcM.getConst ctorId) with + | .ctor (ty := ty) (induct := induct) (cidx := cidx) + (params := params) (fields := fields) (lvls := lvls) + (isUnsafe := isUnsafe) .. => + pure (ty, induct, cidx.toNat, params.toNat, fields.toNat, lvls, + isUnsafe) + | _ => throw (.other "check_inductive: constructor not found") + if ctorInduct != inductId then + throw (.other "check_inductive: ctor parent mismatch") + if ctorLvls != indLvls then + throw (.other s!"check_inductive: ctor universe arity mismatch: expected {indLvls}, got {ctorLvls}") + if ctorIsUnsafe != indIsUnsafe then + throw (.other s!"check_inductive: ctor safety mismatch: expected {indIsUnsafe}, got {ctorIsUnsafe}") + if ctorParams != indParams then + throw (.other s!"check_inductive: ctor params mismatch: expected {indParams}, got {ctorParams}") + if ctorCidx != expectedCidx then + throw (.other s!"check_inductive: ctor cidx mismatch: expected {expectedCidx}, got {ctorCidx}") + return (ctorTy, ctorFields) + /-- Validate an inductive and every one of its constructors (S3/S3b peer agreement + A1–A4). The Rust tail (recursor-generation trigger) lands with P9. -/ @@ -569,19 +809,29 @@ def checkInductiveMemberImpl (id : KId m) : RecM m Unit := do let blockInds ← discoverBlockInductives block let blockAddrs := blockInds.map (·.addr) -- Result sort must exist even for ctor-less inductives. - let indLevel ← getResultSortLevel ty (params + indices).toNat + let indArity ← checkedMetadataSum "inductive params + indices" + #[params, indices] + let indLevel ← getResultSortLevel ty indArity.toNat -- S3/S3b, memoized per block (transitive agreement). if !(← get).env.blockPeerAgreementCache.contains block then for peerId in blockInds do if peerId.addr == id.addr then continue - let (peerParams, peerIndices, peerTy) ← match (← TcM.getConst peerId) with - | .indc (params := pp) (indices := pi) (ty := pty) .. => - pure (pp, pi, pty) + let (peerParams, peerIndices, peerLvls, peerIsUnsafe, peerTy) ← + match (← TcM.getConst peerId) with + | .indc (params := pp) (indices := pi) (lvls := pl) + (isUnsafe := pu) (ty := pty) .. => + pure (pp, pi, pl, pu, pty) | _ => continue - let peerLevel ← getResultSortLevel peerTy (peerParams + peerIndices).toNat + let peerArity ← checkedMetadataSum "inductive params + indices" + #[peerParams, peerIndices] + let peerLevel ← getResultSortLevel peerTy peerArity.toNat if !univEq indLevel peerLevel then throw (.other "mutually inductive types must live in the same universe") + if peerLvls != lvls then + throw (.other s!"mutual peers must declare the same universe arity: self={lvls}, peer={peerLvls}") + if peerIsUnsafe != isUnsafe then + throw (.other "mutual inductives must share the same safety flag") if peerParams != params then throw (.other s!"mutual peers must declare the same number of parameters: self={params}, peer={peerParams}") checkParamAgreement ty peerTy params.toNat @@ -590,15 +840,8 @@ def checkInductiveMemberImpl (id : KId m) : RecM m Unit := do -- Per-constructor A1–A4. for h : expectedCidx in [0:ctors.size] do let ctorId := ctors[expectedCidx] - let (ctorParams, ctorFields, ctorCidx, ctorTy) ← - match (← TcM.getConst ctorId) with - | .ctor (params := cp) (fields := cf) (cidx := cc) (ty := cty) .. => - pure (cp.toNat, cf.toNat, cc.toNat, cty) - | _ => throw (.other "check_inductive: constructor not found") - if ctorParams != params.toNat then - throw (.other s!"check_inductive: ctor params mismatch: expected {params.toNat}, got {ctorParams}") - if ctorCidx != expectedCidx then - throw (.other s!"check_inductive: ctor cidx mismatch: expected {expectedCidx}, got {ctorCidx}") + let (ctorTy, ctorFields) ← checkCtorMetadataAgainstParent ctorId id + expectedCidx params.toNat lvls isUnsafe checkParamAgreement ty ctorTy params.toNat if !isUnsafe then checkPositivity ctorTy params.toNat blockAddrs @@ -614,18 +857,29 @@ def checkInductiveMemberImpl (id : KId m) : RecM m Unit := do declared parent. -/ def checkCtorAgainstInductiveMemberImpl (ctorId inductId : KId m) : RecM m Unit := do - let (ctorTy, ctorFields) ← match (← TcM.getConst ctorId) with - | .ctor (ty := ty) (fields := fields) .. => pure (ty, fields.toNat) - | _ => throw (.other "check_ctor: not a constructor") - let (indParams, indIndices, indLvls, indBlock, indIsUnsafe, indTy) ← + let (indParams, indIndices, indLvls, indBlock, indIsUnsafe, indTy, + indCtors) ← match (← TcM.getConst inductId) with | .indc (params := params) (indices := indices) (lvls := lvls) - (block := block) (isUnsafe := isUnsafe) (ty := ty) .. => - pure (params, indices, lvls, block, isUnsafe, ty) + (block := block) (isUnsafe := isUnsafe) (ty := ty) + (ctors := ctors) .. => + pure (params, indices, lvls, block, isUnsafe, ty, ctors) | _ => throw (.other "check_ctor: parent inductive not found") + let mut expectedCidx? : Option Nat := none + for h : idx in [0:indCtors.size] do + if indCtors[idx] == ctorId then + if expectedCidx?.isSome then + throw (.other "check_inductive: ctor listed more than once by parent") + expectedCidx? := some idx + let some expectedCidx := expectedCidx? + | throw (.other "check_inductive: ctor not listed by parent") + let (ctorTy, ctorFields) ← checkCtorMetadataAgainstParent ctorId inductId + expectedCidx indParams.toNat indLvls indIsUnsafe let blockInds ← discoverBlockInductives indBlock let blockAddrs := blockInds.map (·.addr) - let indLevel ← getResultSortLevel indTy (indParams + indIndices).toNat + let indArity ← checkedMetadataSum "inductive params + indices" + #[indParams, indIndices] + let indLevel ← getResultSortLevel indTy indArity.toNat checkParamAgreement indTy ctorTy indParams.toNat if !indIsUnsafe then checkPositivity ctorTy indParams.toNat blockAddrs @@ -640,6 +894,12 @@ def checkInductiveBlockImpl (block : KId m) (members : Array (KId m)) : RecM m Unit := do let mut indIds : Array (KId m) := #[] let mut ctorIds : Array (KId m) := #[] + -- SECURITY INVARIANT (Lean #14576): infer each original stored member + -- type, including every constructor type, before building or consulting + -- any flattened/nested-inductive representation. A lossy nested rewrite + -- can erase phantom parameter arguments; checking only that rewritten + -- form would let an ill-typed argument disappear. Keep this pass in full + -- inference mode and over the untouched `ty` values. for member in members do TcM.reset (m := m) let c ← TcM.getConst member @@ -671,6 +931,8 @@ def checkInductiveBlockImpl (block : KId m) (members : Array (KId m)) : (offset 1 for large eliminators). -/ def mkIndUnivs (indLvls offset : UInt64) : RecM m (Array (KUniv m)) := do + let _ ← checkedMetadataSum "generated recursor universe arity" + #[indLvls, offset] let mut out : Array (KUniv m) := Array.mkEmpty indLvls.toNat for i in [0:indLvls.toNat] do out := out.push (← TcM.internUniv (m := m) (.mkParam (i.toUInt64 + offset) anonN)) @@ -681,9 +943,9 @@ def mkIndUnivs (indLvls offset : UInt64) : `IO.Ref` is not a nested occurrence). -/ def tryDetectNestedCore (dom : KExpr m) (blockAddrs : Array Address) (flat : Array (FlatBlockMember m)) - (auxSeen : Array (Address × Array Address)) (univOffset : UInt64) + (auxSeen : Array NestedSpecializationKey) (univOffset : UInt64) (paramDepth : Nat) (nRecParams : UInt64) : - RecM m (Array (FlatBlockMember m) × Array (Address × Array Address)) := do + RecM m (Array (FlatBlockMember m) × Array NestedSpecializationKey) := do let cur ← runBounded (fun cur => do match cur with | .all _ _ innerDom body _ => @@ -717,18 +979,21 @@ def tryDetectNestedCore (dom : KExpr m) (blockAddrs : Array Address) return (flat, auxSeen) let specParams := args.extract 0 extNParams -- S7: reject param args depending on field/domain-local binders. + let paramBound ← checkedNatMetadataSum "nested parameter scope" + #[paramDepth, nRecParams.toNat] let s7ok := specParams.all fun sp => - !sp.hasFVars && sp.lbr ≤ paramDepth.toUInt64 + nRecParams + !sp.hasFVars && sp.lbr ≤ paramBound if !s7ok then return (flat, auxSeen) - let specHashes := specParams.map (·.addr) - if auxSeen.any (fun (a, s) => a == headId.addr && s == specHashes) then - return (flat, auxSeen) - let auxSeen' := auxSeen.push (headId.addr, specHashes) - let auxUs ← mkIndUnivs extLvls univOffset let occurrenceUs := match head with | .const _ us _ => us | _ => #[] + let specialization := NestedSpecializationKey.ofApplication headId.addr + occurrenceUs specParams + if auxSeen.contains specialization then + return (flat, auxSeen) + let auxSeen' := auxSeen.push specialization + let auxUs ← mkIndUnivs extLvls univOffset let flat' := flat.push { id := headId, isAux := true, specParams, ownParams := extParams, nIndices := extIndices, @@ -736,13 +1001,13 @@ def tryDetectNestedCore (dom : KExpr m) (blockAddrs : Array Address) return (flat', auxSeen') /-- Detect whether `dom` is a nested inductive occurrence; if so append an - auxiliary entry (dedup by `(extAddr, specParam addrs)`). Returns the - updated `(flat, auxSeen)`; lctx restored. -/ + auxiliary entry (dedup by family, universe, and parameter addresses). + Returns the updated `(flat, auxSeen)`; lctx restored. -/ def tryDetectNested (dom : KExpr m) (blockAddrs : Array Address) (flat : Array (FlatBlockMember m)) - (auxSeen : Array (Address × Array Address)) (univOffset : UInt64) + (auxSeen : Array NestedSpecializationKey) (univOffset : UInt64) (paramDepth : Nat) (nRecParams : UInt64) : - RecM m (Array (FlatBlockMember m) × Array (Address × Array Address)) := do + RecM m (Array (FlatBlockMember m) × Array NestedSpecializationKey) := do let savedLctx := (← get).lctx.size let result ← tryDetectNestedCore dom blockAddrs flat auxSeen univOffset paramDepth nRecParams @@ -756,7 +1021,7 @@ def buildFlatBlock (blockInds : Array (KId m)) RecM m (Array (FlatBlockMember m)) := do let allBlockAddrs := blockInds.map (·.addr) let mut flat : Array (FlatBlockMember m) := #[] - let mut auxSeen : Array (Address × Array Address) := #[] + let mut auxSeen : Array NestedSpecializationKey := #[] for indId in blockInds do match (← TcM.getConst indId) with | .indc (params := ownParams) (indices := nIndices) (ctors := ctors) @@ -840,9 +1105,11 @@ def tryReplaceAuxRefForSort (e : KExpr m) if !matched then continue let mut result ← TcM.intern (.mkConst auxIds[idx]! blockUs) + let paramBase ← checkedMetadataSum "auxiliary parameter index" + #[localDepth, nBlockParams] for pi in [0:nBlockParams.toNat] do let p ← TcM.intern (m := m) - (.mkVar (localDepth + nBlockParams - 1 - pi.toUInt64) anonN) + (.mkVar (paramBase - 1 - pi.toUInt64) anonN) result ← TcM.intern (.mkApp result p) for idxArg in args.extract own args.size do result ← TcM.intern (.mkApp result idxArg) @@ -1102,11 +1369,13 @@ def buildMotiveTypeFlat (member : FlatBlockMember m) let nIdx := member.nIndices.toNat -- Major type at depth = nIdx. let mut majorTy ← TcM.intern (.mkConst member.id member.occurrenceUs) - let depth := nIdx.toUInt64 + let depth ← checkedNatMetadataSum "generated motive index depth" #[nIdx] if !member.isAux then + let paramBase ← checkedNatMetadataSum "generated motive parameter depth" + #[nRecParams, nIdx] for i in [0:nRecParams] do let v ← TcM.intern (m := m) - (.mkVar ((nRecParams.toUInt64 - 1 - i.toUInt64) + depth) anonN) + (.mkVar (paramBase - 1 - i.toUInt64) anonN) majorTy ← TcM.intern (.mkApp majorTy v) else for sp in member.specParams do @@ -1490,7 +1759,8 @@ def findPeerRecursors (blockId : KId m) | some (.recr (params := p) (motives := mo) (minors := mi) (indices := ix) (ty := ty) ..) => pure (p, mo, mi, ix, ty) | _ => return none - let skip := params + motives + minors + indices + let skip ← checkedMetadataSum "recursor major index" + #[params, motives, minors, indices] let majorId? ← try pure (some (← getMajorInductiveId ty skip)) catch @@ -1545,7 +1815,12 @@ def buildRuleIh (fieldIdx nFields totalLams : UInt64) let peerRec := peerRecs[targetBi]! let peerRecLvls ← match (← TcM.tryGetConst peerRec) with | some (.recr (lvls := lvls) ..) => pure lvls - | _ => pure (if isLarge then flat[targetBi]!.lvls + 1 else flat[targetBi]!.lvls) + | _ => + if isLarge then + checkedMetadataSum "generated recursor universe arity" + #[flat[targetBi]!.lvls, 1] + else + pure flat[targetBi]!.lvls let mut recLvls : Array (KUniv m) := Array.mkEmpty peerRecLvls.toNat for i in [0:peerRecLvls.toNat] do recLvls := recLvls.push (← TcM.internUniv (m := m) (.mkParam i.toUInt64 anonN)) @@ -1556,7 +1831,8 @@ def buildRuleIh (fieldIdx nFields totalLams : UInt64) let innerW ← whnf inner let (_, innerArgs) := innerW.collectSpine let idxArgs := innerArgs.extract targetNParams innerArgs.size - let depth := totalLams + nXs + let depth ← checkedMetadataSum "generated recursor induction-hypothesis depth" + #[totalLams, nXs] let mut ih ← TcM.intern (.mkConst peerRec recLvls) for pi in [0:nRecParams] do ih ← TcM.intern (.mkApp ih (← TcM.intern (m := m) @@ -1570,7 +1846,9 @@ def buildRuleIh (fieldIdx nFields totalLams : UInt64) - mi.toUInt64) anonN))) for idx in idxArgs do ih ← TcM.intern (.mkApp ih idx) - let fieldBase := nFields - 1 - fieldIdx + nXs + let fieldOffset := nFields - 1 - fieldIdx + let fieldBase ← checkedMetadataSum "generated recursor wrapped-field index" + #[fieldOffset, nXs] let mut fieldApp ← TcM.intern (m := m) (.mkVar fieldBase anonN) for xi in [0:nXs.toNat] do fieldApp ← TcM.intern (.mkApp fieldApp (← TcM.intern (m := m) @@ -1594,6 +1872,9 @@ def buildRuleRhs (memberIdx ctorLocalIdx : Nat) (ctorId : KId m) let nMotives := flat.size let nMinors := flat.foldl (fun acc mem => acc + mem.ctors.size) 0 let pmm := nRecParams + nMotives + nMinors + let pmm64 ← checkedNatMetadataSum + "generated recursor params + motives + minors" + #[nRecParams, nMotives, nMinors] -- Pass 1: count fields. let ctorTyInst ← TcM.instantiateUnivParams ctorTyRaw member.occurrenceUs let mut countTy := ctorTyInst @@ -1609,11 +1890,16 @@ def buildRuleRhs (memberIdx ctorLocalIdx : Nat) (ctorId : KId m) return .next (body, nFields + 1) | _ => return .done nFields) maxWhnfFuel.toNat (countTy, (0 : UInt64)) - let totalLams := pmm.toUInt64 + nFields + let totalLams ← checkedMetadataSum "generated recursor rule lambdas" + #[pmm64, nFields] -- Pass 2: body = minor[globalIdx] fields ihs. let globalMinorIdx := (flat.extract 0 memberIdx).foldl (fun acc mem => acc + mem.ctors.size) 0 + ctorLocalIdx - let minorVarIdx := nFields + (nMinors - 1 - globalMinorIdx).toUInt64 + if globalMinorIdx ≥ nMinors then + throw (.other "generated recursor global minor index out of range") + let minorVarIdx ← checkedNatMetadataSum + "generated recursor minor variable index" + #[nFields.toNat, nMinors - 1 - globalMinorIdx] let mut body ← TcM.intern (m := m) (.mkVar minorVarIdx anonN) for fi in [0:nFields.toNat] do body ← TcM.intern (.mkApp body (← TcM.intern (m := m) @@ -1664,7 +1950,8 @@ def buildRuleRhs (memberIdx ctorLocalIdx : Nat) (ctorId : KId m) match w with | .all _ _ dom _ _ => pure dom | _ => pure (KExpr.mkSort .mkZero) - let fieldDomLift := (nMinors - globalMinorIdx).toUInt64 + let fieldDomLift ← checkedNatMetadataSum + "generated recursor field-domain lift" #[nMinors - globalMinorIdx] let mut fieldDomains : Array (KExpr m) := Array.mkEmpty nFields.toNat let mut minorCur := minorDomain for fi in [0:nFields.toNat] do @@ -1709,19 +1996,31 @@ def generateBlockRecursors (blockId : KId m) : RecM m Unit := do let mut indInfos : Array (KId m × UInt64 × UInt64 × Array (KId m) × KExpr m) := #[] let mut nParams : UInt64 := 0 + let (blockLvls, blockIsUnsafe) ← match (← TcM.getConst blockInds[0]!) with + | .indc (lvls := lvls) (isUnsafe := isUnsafe) .. => + pure (lvls, isUnsafe) + | _ => throw (.other "generate_block_recursors: not an inductive") for h : i in [0:blockInds.size] do let indId := blockInds[i] match (← TcM.getConst indId) with | .indc (params := params) (indices := indices) (ctors := ctors) - (ty := ty) .. => + (lvls := lvls) (isUnsafe := isUnsafe) (ty := ty) .. => if i == 0 then nParams := params + if lvls != blockLvls then + throw (.other "mutual peers must declare the same universe arity") + if isUnsafe != blockIsUnsafe then + throw (.other "mutual inductives must share the same safety flag") indInfos := indInfos.push (indId, params, indices, ctors, ty) | _ => throw (.other "generate_block_recursors: not an inductive") + let firstIndArity ← checkedMetadataSum "inductive params + indices" + #[indInfos[0]!.2.1, indInfos[0]!.2.2.1] let resultLevel ← getResultSortLevel indInfos[0]!.2.2.2.2 - (indInfos[0]!.2.1 + indInfos[0]!.2.2.1).toNat + firstIndArity.toNat let isLarge ← isLargeEliminator resultLevel indInfos let univOffset : UInt64 := if isLarge then 1 else 0 + let recLvls ← checkedMetadataSum "generated recursor universe arity" + #[blockLvls, univOffset] let elimLevel : KUniv m ← if isLarge then TcM.internUniv (m := m) (.mkParam 0 anonN) else @@ -1756,12 +2055,23 @@ def generateBlockRecursors (blockId : KId m) : RecM m Unit := do motiveTypes := motiveTypes.push (← buildMotiveTypeFlat mem nParams.toNat elimLevel) -- Recursor types for every flat member. + let nMotives := flat.size.toUInt64 + let nMinors ← checkedMetadataSum "generated recursor minors" + (flat.map fun mem => mem.ctors.size.toUInt64) let mut generated : Array (GeneratedRecursor m) := Array.mkEmpty flat.size for di in [0:flat.size] do let recType ← buildRecType di flatIndInfos flatIds flat motiveTypes univOffset generated := generated.push - { indAddr := flat[di]!.id.addr, ty := recType, rules := #[] } + { indAddr := flat[di]!.id.addr + lvls := recLvls + params := nParams + motives := nMotives + minors := nMinors + indices := flat[di]!.nIndices + isUnsafe := blockIsUnsafe + ty := recType + rules := #[] } -- Rules from co-resident peer recursors (when alignment sanity holds). let peerRecs ← findPeerRecursors blockId flat if let some peers := peerRecs then @@ -1841,8 +2151,11 @@ def populateRecursorRulesFromBlock (indBlockId recBlockId : KId m) : (fun (g, mem) => g.rules.size == mem.ctors.size) then return () let nMotives := flat.size.toUInt64 - let nMinors := flat.foldl (fun acc mem => acc + mem.ctors.size.toUInt64) 0 - let prefixBase := nParams64 + nMotives + nMinors + let nMinors ← checkedMetadataSum "generated recursor minors" + (flat.map fun mem => mem.ctors.size.toUInt64) + let prefixBase ← checkedMetadataSum + "generated recursor params + motives + minors" + #[nParams64, nMotives, nMinors] if recIds.size != flat.size then throw (.other s!"populate_recursor_rules_from_block: rec_ids/flat count mismatch: rec_ids={recIds.size} flat={flat.size}") -- Verify canonical alignment via major-domain signatures. @@ -1856,9 +2169,11 @@ def populateRecursorRulesFromBlock (indBlockId recBlockId : KId m) : | .recr (params := p) (motives := mo) (minors := mi) (indices := ix) (ty := ty) .. => pure (p, mo, mi, ix, ty) | _ => throw (.other s!"populate_recursor_rules_from_block: rec_ids[{gi}]={rid} is not a recursor") - let genMajor ← recursorMajorDomainForAddr genRec.ty - (prefixBase + flat[gi]!.nIndices) targetAddr - let storedSkip := params + motives + minors + indices + let genSkip ← checkedMetadataSum "generated recursor major index" + #[prefixBase, flat[gi]!.nIndices] + let genMajor ← recursorMajorDomainForAddr genRec.ty genSkip targetAddr + let storedSkip ← checkedMetadataSum "recursor major index" + #[params, motives, minors, indices] let storedMajor ← recursorMajorDomainForAddr ty storedSkip targetAddr let signaturesMatch ← match genMajor, storedMajor with | some g, some s => majorDomainSignatureEq g s @@ -1910,7 +2225,7 @@ def gatherPeerMajors (recBlock : KId m) : RecM m (Array (KId m)) := do | .recr (params := p) (motives := mo) (minors := mi) (indices := ix) (ty := ty) .. => pure (p, mo, mi, ix, ty) | _ => continue - let skip := p + mo + mi + ix + let skip ← checkedMetadataSum "recursor major index" #[p, mo, mi, ix] let major? ← try pure (some (← getMajorInductiveId peerTy skip)) catch @@ -1949,33 +2264,20 @@ def checkInductive (id : KId m) : RecM m Unit := do | .ok () => return () | .error e => throw e -/-- Coherence-only recursor gate: major inductive passes A1–A4 and the - declared K flag matches the constructive computation. -/ -def checkRecursorCoherence (id : KId m) : RecM m Unit := do - let (ty, declaredK, params, motives, minors, indices) ← - match (← TcM.getConst id) with - | .recr (ty := ty) (k := k) (params := p) (motives := mo) (minors := mi) - (indices := ix) .. => pure (ty, k, p, mo, mi, ix) - | _ => throw (.other "check_recursor_coherence: not a recursor") - let skip := params + motives + minors + indices - let indId ← getMajorInductiveId ty skip - if let some (.indc ..) ← TcM.tryGetConst indId then - checkInductive indId - let computedK ← computeKTarget indId - if declaredK != computedK then - throw (.other s!"check_recursor_coherence: K-target mismatch: declared k={declaredK}, computed k={computedK}") - /-- Validate a recursor against the generated canonical form (type def-eq + per-rule field count and RHS def-eq), with signature-based aux - disambiguation and the canonical-aux coherence fallback. -/ + disambiguation. Every successful path compares both type and rules. -/ def checkRecursorMemberImpl (id : KId m) : RecM m Unit := do - let (recBlock, ty, declaredK, params, motives, minors, indices) ← + let (recBlock, ty, declaredK, declaredLvls, declaredIsUnsafe, params, + motives, minors, indices) ← match (← TcM.getConst id) with | .recr (block := block) (ty := ty) (k := k) (params := p) - (motives := mo) (minors := mi) (indices := ix) .. => - pure (block, ty, k, p, mo, mi, ix) + (lvls := lvls) (isUnsafe := isUnsafe) (motives := mo) + (minors := mi) (indices := ix) .. => + pure (block, ty, k, lvls, isUnsafe, p, mo, mi, ix) | _ => throw (.other "check_recursor: not a recursor") - let skip := params + motives + minors + indices + let skip ← checkedMetadataSum "recursor major index" + #[params, motives, minors, indices] let indId ← getMajorInductiveId ty skip -- Coherence gate: the major inductive must itself pass A1–A4. if let some (.indc ..) ← TcM.tryGetConst indId then @@ -2017,7 +2319,8 @@ def checkRecursorMemberImpl (id : KId m) : RecM m Unit := do -- Signature-first selection (dedups aux recursors sharing a major head). let storedPos := (← get).env.blocks[recBlock]?.bind (·.findIdx? (fun mem => mem == id)) - let prefixSkip := params + motives + minors + let prefixSkip ← checkedMetadataSum "recursor params + motives + minors" + #[params, motives, minors] let storedMajor ← recursorMajorDomainForAddr ty prefixSkip indId.addr let mut signatureMatches : Array Nat := #[] if let some storedMajorD := storedMajor then @@ -2036,11 +2339,14 @@ def checkRecursorMemberImpl (id : KId m) : RecM m Unit := do <|> (generated.findIdx? (·.indAddr == indId.addr)) match selectedIdx.bind (generated[·]?) with | some g => + if declaredLvls != g.lvls then + throw (.other s!"check_recursor: universe arity mismatch: stored={declaredLvls}, generated={g.lvls}") + if declaredIsUnsafe != g.isUnsafe then + throw (.other s!"check_recursor: safety mismatch: stored={declaredIsUnsafe}, generated={g.isUnsafe}") + if params != g.params || motives != g.motives || minors != g.minors + || indices != g.indices then + throw (.other s!"check_recursor: arity metadata mismatch: stored=(params={params}, motives={motives}, minors={minors}, indices={indices}), generated=(params={g.params}, motives={g.motives}, minors={g.minors}, indices={g.indices})") if !(← isDefEq g.ty ty) then - let selectedBySignature := selectedIdx.any (signatureMatches.contains ·) - if (← get).env.recursorAuxOrder == .canonical && motives > 1 - && selectedBySignature then - return (← checkRecursorCoherence id) throw (.other "check_recursor: type mismatch") let genRules := g.rules let storedRules ← match (← TcM.getConst id) with diff --git a/Ix/Tc/Ingress.lean b/Ix/Tc/Ingress.lean index a3c4cc147..276ed54c1 100644 --- a/Ix/Tc/Ingress.lean +++ b/Ix/Tc/Ingress.lean @@ -336,22 +336,30 @@ def insertStandaloneEntries (entries : Array Entry) : IngressM Unit := do modifyGet fun env => ((), entries.foldl (init := env) fun env (id, c) => (env.insert id c).insertBlock id #[id]) +/-- Insert the flat entry array into the constant map, in production's exact +left-to-right last-write-wins order. -/ +def insertEntriesState (env : AnonEnv) (entries : Array Entry) : AnonEnv := + entries.toList.foldl (fun env (id, c) => env.insert id c) env + /-- Muts registration: `blocks[blockId] = [m0, m0.ctors…, m1, …]` (flat, in - generation order), block id read from the first entry's `block` field. -/ -def insertMutsEntries (entries : Array Entry) : IngressM Unit := do - guardReserved entries +generation order), block id read from the first entry's `block` field. -/ +def insertMutsEntriesState (env : AnonEnv) (entries : Array Entry) : AnonEnv := let blockId? := entries[0]?.bind fun (_, c) => match c with | .defn (block := b) .. => some b | .recr (block := b) .. => some b | .indc (block := b) .. => some b | _ => none - modifyGet fun env => Id.run do - let mut env := env - if let some bid := blockId? then - env := env.insertBlock bid (entries.map (·.1)) - for (id, c) in entries do - env := env.insert id c - return ((), env) + let env := match blockId? with + | some bid => env.insertBlock bid (entries.map (·.1)) + | none => env + insertEntriesState env entries + +/-- Effectful wrapper around `insertMutsEntriesState`. Keeping the exact +pure state transition named makes successful ingress executions available to +the verification layer without changing the runtime behavior. -/ +def insertMutsEntries (entries : Array Entry) : IngressM Unit := do + guardReserved entries + modifyGet fun env => ((), insertMutsEntriesState env entries) /-- Convert a `Definition`. `mutCtx` resolves `Expr.recur`; standalone callers pass `#[selfId]` (self-recursive standalones encode their @@ -445,13 +453,21 @@ def ingressAnonStandalone (ixonEnv : Ixon.Env) (addr : Address) insertStandaloneEntries entries return selfId -/-- Anon ingress for an entire Muts block: every member (and every ctor of - every inductive member) lands under its deterministic projection address. - Verifies each computed address exists in `ixonEnv.consts` (missing ⇒ - corrupted env). Returns the member KIds in order; the first is the - block's "primary". -/ -def ingressAnonBlock (ixonEnv : Ixon.Env) (blockConstant : Ixon.Constant) - (blockAddr : Address) : IngressM (Array (KId .anon)) := do +/-- Proof-visible result of converting and inserting an entire anonymous +Muts block. `memberKids` is the public top-level member array returned by the +legacy API; `allEntries` additionally retains constructors and the exact +converted constants inserted into the kernel environment. -/ +structure AnonBlockIngressTrace where + memberKids : Array (KId .anon) + allEntries : Array Entry + deriving Inhabited + +/-- Convert an entire Muts block without publishing it. Splitting conversion +from insertion makes the atomic publication tail explicit to verification; +the public wrapper below preserves the original all-or-error behavior. -/ +def prepareAnonBlock (ixonEnv : Ixon.Env) + (blockConstant : Ixon.Constant) (blockAddr : Address) : + IngressM AnonBlockIngressTrace := do let .muts members := blockConstant.info | throw s!"ingressAnonBlock: {blockAddr} is not a Muts block" let blockId : KId .anon := ⟨blockAddr, ()⟩ @@ -506,8 +522,21 @@ def ingressAnonBlock (ixonEnv : Ixon.Env) (blockConstant : Ixon.Constant) let entries ← ingressAnonInductive ixonEnv ind selfId blockConstant blockId idx ctorAddrs mutCtx allEntries := allEntries ++ entries - insertMutsEntries allEntries - return memberKids + return { memberKids, allEntries } + +/-- Traced anon ingress for an entire Muts block: convert every member, then +atomically publish the exact flat entry array returned in the trace. -/ +def ingressAnonBlockWithTrace (ixonEnv : Ixon.Env) + (blockConstant : Ixon.Constant) (blockAddr : Address) : + IngressM AnonBlockIngressTrace := do + let trace ← prepareAnonBlock ixonEnv blockConstant blockAddr + insertMutsEntries trace.allEntries + return trace + +/-- Compatibility projection of `ingressAnonBlockWithTrace`. -/ +def ingressAnonBlock (ixonEnv : Ixon.Env) (blockConstant : Ixon.Constant) + (blockAddr : Address) : IngressM (Array (KId .anon)) := do + return (← ingressAnonBlockWithTrace ixonEnv blockConstant blockAddr).memberKids /-- Anon shallow ingress for a single address — the lazy fault path. For a projection, fetches the parent block and ingresses the whole block (with diff --git a/Ix/Tc/Verify/Audit/Completed.lean b/Ix/Tc/Verify/Audit/Completed.lean index 66309d1b7..ca5c28b61 100644 --- a/Ix/Tc/Verify/Audit/Completed.lean +++ b/Ix/Tc/Verify/Audit/Completed.lean @@ -1,4 +1,26 @@ import Ix.Tc.Verify.Audit.Basic +import Ix.Tc.Verify.Check.Acceptance +import Ix.Tc.Verify.Check.BoundedPipelines +import Ix.Tc.Verify.Check.CheckerEvidence +import Ix.Tc.Verify.Check.FullInferenceApplications +import Ix.Tc.Verify.Check.FullInferenceBinders +import Ix.Tc.Verify.Check.FullInferenceCache +import Ix.Tc.Verify.Check.FullInferenceDispatcher +import Ix.Tc.Verify.Check.FullInferenceProjections +import Ix.Tc.Verify.Check.MemberEvidence +import Ix.Tc.Verify.Check.NatAcceptance +import Ix.Tc.Verify.Check.BlockNatFixture +import Ix.Tc.Verify.Check.PreTranslationScopes +import Ix.Tc.Verify.Check.PositiveFuelSort +import Ix.Tc.Verify.Check.ScopedPositiveFuelCertificate +import Ix.Tc.Verify.Check.SingletonInductive +import Ix.Tc.Verify.Inductive.EnumerationAcceptance +import Ix.Tc.Verify.Check.ProjectionInferencePolicy +import Ix.Tc.Verify.Check.ResetFrame +import Ix.Tc.Verify.Check.SafetyFrame +import Ix.Tc.Verify.Check.PublicStandalone +import Ix.Tc.Verify.Check.PublicBlocks +import Ix.Tc.Verify.Check.ValidatorFrame import Ix.Tc.Verify.Ctx import Ix.Tc.Verify.Decl import Ix.Tc.Verify.DefEq @@ -46,16 +68,25 @@ 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.Driver.Fixtures +import Ix.Tc.Verify.Driver.BooleanAcceptance +import Ix.Tc.Verify.Driver.SupportedAcceptanceFixtures 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.Inductive.Certificate +import Ix.Tc.Verify.Inductive.SpecializationIdentity +import Ix.Tc.Verify.Ingress.LiteralBlobs +import Ix.Tc.Verify.Ingress.SerializedBoolean 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.RecursiveMethods.FiniteSupportBoundary +import Ix.Tc.Verify.RecursiveMethods.Public import Ix.Tc.Verify.Support import Ix.Tc.Verify.Totalization import Ix.Tc.Verify.Whnf @@ -104,6 +135,15 @@ private def levelNative : Array Lean.Name := expressionNative.push (nativeAxiom `Ix.Tc.Level `Ix.Tc.KUniv.mkSucc._native.native_decide.ax_1) +private def occurrenceValidationNative : Array Lean.Name := blake3Native.push + (nativeAxiom `Ix.Tc.Level + `Ix.Tc.KUniv.mkSucc._native.native_decide.ax_1) + +private def specializationIdentityNative : Array Lean.Name := + occurrenceValidationNative.push + (nativeAxiom `Ix.Tc.Verify.Inductive.SpecializationIdentity + `Ix.Tc.SpecializationIdentityFixture.semanticUniverseEquality_does_not_collapse_specializationNative._native.native_decide.ax_1_1) + private def univOnlyNative : Array Lean.Name := #[ nativeAxiom `Ix.Tc.Level `Ix.Tc.KUniv.mkSucc._native.native_decide.ax_1 @@ -172,20 +212,653 @@ private def inductiveNative : Array Lean.Name := (inferNative.push (nativeAxiom `Ix.Environment `Ix.Name.mkStr._native.native_decide.ax_1)).push (nativeAxiom `Ix.Tc.Inductive - `Ix.Tc.RecM.canonicalAuxOrder._native.native_decide.ax_17) + `Ix.Tc.RecM.canonicalAuxOrder._native.native_decide.ax_15) + +private def enumerationFixtureNativeAxiom (name : Lean.Name) : Lean.Name := + nativeAxiom `Ix.Tc.Verify.Inductive.EnumerationFixture name + +private def enumerationAcceptanceNativeAxiom (name : Lean.Name) : Lean.Name := + nativeAxiom `Ix.Tc.Verify.Inductive.EnumerationAcceptance name + +private def booleanAcceptanceNativeAxiom (name : Lean.Name) : Lean.Name := + nativeAxiom `Ix.Tc.Verify.Driver.BooleanAcceptance name + +private def serializedBooleanNativeAxiom (name : Lean.Name) : Lean.Name := + nativeAxiom `Ix.Tc.Verify.Ingress.SerializedBoolean name + +private def literalBlobsNativeAxiom (name : Lean.Name) : Lean.Name := + nativeAxiom `Ix.Tc.Verify.Ingress.LiteralBlobs name + +/- The concrete Boolean E2b witness deliberately evaluates the real ingress, +checker, content-address, scoping, and finite catalog computations. Keep every +fixture-local native proof explicit rather than treating the witness as one +opaque executable assumption. -/ +private def booleanEnumerationNative : Array Lean.Name := inductiveNative ++ #[ + enumerationAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyBlockLoadedNative._native.native_decide.ax_1_1, + enumerationAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyBodySucceededNative._native.native_decide.ax_1_1, + enumerationAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyClassificationSucceededNative._native.native_decide.ax_1_1, + enumerationAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyDirectOwnerNative._native.native_decide.ax_1_1, + enumerationAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyKernelSucceededNative._native.native_decide.ax_1_1, + enumerationAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.recursorBlockLoadedNative._native.native_decide.ax_1_1, + enumerationAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.recursorBlockLoadedAfterFamilyNative._native.native_decide.ax_1_1, + enumerationAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.recursorBodySucceededNative._native.native_decide.ax_1_1, + enumerationAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.recursorClassificationSucceededNative._native.native_decide.ax_1_1, + enumerationAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.recursorKernelSucceededNative._native.native_decide.ax_1_1, + enumerationAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.recursorOwnerNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.catalogFalseNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.catalogFalseNative._native.native_decide.ax_1_2, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.catalogFamilyNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.catalogRecursorNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.catalogRecursorNative._native.native_decide.ax_1_2, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.catalogRecursorNative._native.native_decide.ax_1_3, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.catalogRecursorNative._native.native_decide.ax_1_4, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.catalogTrueNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.catalogTrueNative._native.native_decide.ax_1_2, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.catalogTrueNative._native.native_decide.ax_1_3, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.enumerationShapeNative._native.native_decide.ax_1_6, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.enumerationShapeNative._native.native_decide.ax_1_7, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.falseEntryNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.falseRuleBinderCoreNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.falseRuleFieldsNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.falseRuleRawNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.falseRuleScopedNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.falseRuleSizeBoundNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.falseShapeNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.falseSourceTypeNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.falseTypeNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.falseTypeNative._native.native_decide.ax_1_2, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyConstructorCountNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyEntriesSizeNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyEntriesUniqueNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyEntryAtOneNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyEntryAtTwoNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyEntryAtZeroNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyEntryIdsNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyEntryNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyIngressSucceededNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyMemberKidsNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyShapeNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyTypeNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.generationCtorPairOne._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.generationCtorPairZero._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.nameOfFalseNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.nameOfFamilyNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.nameOfRecursorNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.nameOfTrueNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.recursorEntriesSizeNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.recursorEntriesUniqueNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.recursorEntryIdsNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.recursorEntryNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.recursorIngressSucceededNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.recursorMemberKidsNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.recursorRulesSizeNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.recursorShapeNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.recursorTypeRawNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.sourceConstructorOne._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.sourceConstructorZero._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.trueEntryNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.trueRuleBinderCoreNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.trueRuleFieldsNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.trueRuleRawNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.trueRuleScopedNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.trueRuleSizeBoundNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.trueShapeNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.trueSourceTypeNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.trueTypeNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.trueTypeNative._native.native_decide.ax_1_2 +] + +/- The E3-S family-body bridge consumes only the family-side slice of the +full end-to-end Boolean witness. Keep this narrower than +`booleanEnumerationNative`: in particular it must not inherit the executable +recursor run, kernel-run, generated-rule, or recursor-ingress facts merely +because the larger E2b witness uses them. -/ +private def booleanFamilyBodyNative : Array Lean.Name := inductiveNative ++ #[ + enumerationAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyBlockLoadedNative._native.native_decide.ax_1_1, + enumerationAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyBodySucceededNative._native.native_decide.ax_1_1, + enumerationAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyClassificationSucceededNative._native.native_decide.ax_1_1, + enumerationAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyDirectOwnerNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.catalogFalseNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.catalogFalseNative._native.native_decide.ax_1_2, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.catalogFamilyNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.catalogTrueNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.catalogTrueNative._native.native_decide.ax_1_2, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.catalogTrueNative._native.native_decide.ax_1_3, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.falseEntryNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.falseShapeNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.falseSourceTypeNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.falseTypeNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.falseTypeNative._native.native_decide.ax_1_2, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyConstructorCountNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyEntriesSizeNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyEntriesUniqueNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyEntryAtOneNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyEntryAtTwoNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyEntryAtZeroNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyEntryIdsNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyEntryNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyIngressSucceededNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyMemberKidsNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyShapeNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyTypeNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.nameOfFalseNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.nameOfFamilyNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.nameOfTrueNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.recursorEntriesSizeNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.recursorShapeNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.sourceConstructorOne._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.sourceConstructorZero._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.trueEntryNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.trueShapeNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.trueSourceTypeNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.trueTypeNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.trueTypeNative._native.native_decide.ax_1_2 +] + +/-- Exact evaluator boundary of the final E3-S Boolean whole-driver witness. +This is intentionally narrower than `booleanEnumerationNative`: the release +root consumes the generated Theory certificate and exact physical links, but +does not inherit the earlier standalone body/kernel executions as semantic +authority for the serial run. -/ +def booleanDriverNative : Array Lean.Name := inductiveNative ++ #[ + booleanAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.buildAnonWorkNative._native.native_decide.ax_1_1, + booleanAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.checkEnvAnonNative._native.native_decide.ax_1_1, + booleanAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.falseProjectionEntry._native.native_decide.ax_1_1, + booleanAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.falseProjectionEntry._native.native_decide.ax_1_2, + booleanAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.falseProjectionEntry._native.native_decide.ax_1_3, + booleanAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyBlockEntry._native.native_decide.ax_1_1, + booleanAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyBlockEntry._native.native_decide.ax_1_2, + booleanAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyBlockEntry._native.native_decide.ax_1_3, + booleanAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyProjectionEntry._native.native_decide.ax_1_1, + booleanAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyProjectionEntry._native.native_decide.ax_1_2, + booleanAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyProjectionEntry._native.native_decide.ax_1_3, + booleanAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyTargetsNonemptyNative._native.native_decide.ax_1_1, + booleanAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.recursorBlockEntry._native.native_decide.ax_1_1, + booleanAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.recursorBlockEntry._native.native_decide.ax_1_2, + booleanAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.recursorBlockEntry._native.native_decide.ax_1_3, + booleanAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.recursorProjectionEntry._native.native_decide.ax_1_1, + booleanAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.recursorProjectionEntry._native.native_decide.ax_1_2, + booleanAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.recursorProjectionEntry._native.native_decide.ax_1_3, + booleanAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.recursorTargetsNonemptyNative._native.native_decide.ax_1_1, + booleanAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.sourceAddressesNative._native.native_decide.ax_1_1, + booleanAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.sourceAddressesNodupNative._native.native_decide.ax_1_1, + booleanAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.sourceKeysNative._native.native_decide.ax_1_1, + booleanAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.trueProjectionEntry._native.native_decide.ax_1_1, + booleanAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.trueProjectionEntry._native.native_decide.ax_1_2, + booleanAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.trueProjectionEntry._native.native_decide.ax_1_3, + enumerationAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyBlockLoadedNative._native.native_decide.ax_1_1, + enumerationAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyDirectOwnerNative._native.native_decide.ax_1_1, + enumerationAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.recursorBlockLoadedNative._native.native_decide.ax_1_1, + enumerationAcceptanceNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.recursorOwnerNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.catalogFalseNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.catalogFalseNative._native.native_decide.ax_1_2, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.catalogFamilyNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.catalogRecursorNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.catalogRecursorNative._native.native_decide.ax_1_2, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.catalogRecursorNative._native.native_decide.ax_1_3, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.catalogRecursorNative._native.native_decide.ax_1_4, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.catalogTrueNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.catalogTrueNative._native.native_decide.ax_1_2, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.catalogTrueNative._native.native_decide.ax_1_3, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.enumerationShapeNative._native.native_decide.ax_1_6, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.enumerationShapeNative._native.native_decide.ax_1_7, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.falseEntryNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.falseRuleBinderCoreNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.falseRuleFieldsNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.falseRuleRawNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.falseRuleScopedNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.falseRuleSizeBoundNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.falseShapeNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.falseSourceTypeNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.falseTypeNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.falseTypeNative._native.native_decide.ax_1_2, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyConstructorCountNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyEntriesSizeNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyEntriesUniqueNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyEntryAtOneNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyEntryAtTwoNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyEntryAtZeroNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyEntryIdsNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyEntryNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyIngressSucceededNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyMemberKidsNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyShapeNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.familyTypeNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.generationCtorPairOne._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.generationCtorPairZero._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.nameOfFalseNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.nameOfFamilyNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.nameOfRecursorNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.nameOfTrueNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.recursorEntriesSizeNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.recursorEntriesUniqueNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.recursorEntryIdsNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.recursorEntryNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.recursorIngressSucceededNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.recursorMemberKidsNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.recursorRulesSizeNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.recursorShapeNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.recursorTypeRawNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.sourceConstructorOne._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.sourceConstructorZero._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.trueEntryNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.trueRuleBinderCoreNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.trueRuleFieldsNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.trueRuleRawNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.trueRuleScopedNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.trueRuleSizeBoundNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.trueShapeNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.trueSourceTypeNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.trueTypeNative._native.native_decide.ax_1_1, + enumerationFixtureNativeAxiom + `Ix.Tc.BooleanEnumerationFixture.trueTypeNative._native.native_decide.ax_1_2 +] + +/-- Exact evaluator boundary of the serialized T0 Boolean certificate. Each +closed computation is named so changes in the byte, eager, lazy, dependency, +or driver slices are visible independently in the trust manifest. -/ +def serializedBooleanNative : Array Lean.Name := booleanDriverNative ++ #[ + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.blobKeysNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.buildAnonWorkNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.checkEnvAnonNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.decodeSucceededNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.eagerBlockKeysClassifiedNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.eagerFalseNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.eagerFamilyBlockNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.eagerFamilyNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.eagerKeysClassifiedNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.eagerRecursorBlockNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.eagerRecursorNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.eagerSucceededNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.eagerTrueNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.eagerWorkNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.encodeSucceededNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.falseProjectionEntry._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.falseProjectionEntry._native.native_decide.ax_1_2, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.falseProjectionHashNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.falseProjectionLookupNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.familyBlockEntry._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.familyBlockEntry._native.native_decide.ax_1_2, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.familyBlockHashNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.familyBlockLookupNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.familyProjectionEntry._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.familyProjectionEntry._native.native_decide.ax_1_2, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.familyProjectionHashNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.familyProjectionLookupNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.familyTargetsNonemptyNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.lazyFalseLoadedNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.lazyFamilyBlockKeysNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.lazyFamilyBlockNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.lazyFamilyKeysClassifiedNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.lazyFamilyLoadedNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.lazyFamilySucceededNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.lazyFinalBlockKeysClassifiedNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.lazyFinalFalseNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.lazyFinalFamilyBlockNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.lazyFinalFamilyNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.lazyFinalRecursorBlockNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.lazyFinalRecursorNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.lazyFinalTrueNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.lazyRecursorKeysClassifiedNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.lazyRecursorSucceededNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.lazyTrueLoadedNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.originalFalseProjectionLookupNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.originalFamilyBlockLookupNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.originalFamilyProjectionLookupNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.originalRecursorBlockLookupNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.originalRecursorProjectionLookupNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.originalTrueProjectionLookupNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.recursorBlockEntry._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.recursorBlockEntry._native.native_decide.ax_1_2, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.recursorBlockHashNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.recursorBlockLookupNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.recursorProjectionEntry._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.recursorProjectionEntry._native.native_decide.ax_1_2, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.recursorProjectionHashNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.recursorProjectionLookupNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.recursorTargetsNonemptyNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.sourceAddressesNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.sourceAddressesNodupNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.sourceKeysNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.trueProjectionEntry._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.trueProjectionEntry._native.native_decide.ax_1_2, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.trueProjectionHashNative._native.native_decide.ax_1_1, + serializedBooleanNativeAxiom + `Ix.Tc.BooleanSerialized.trueProjectionLookupNative._native.native_decide.ax_1_1 +] + +/- Exact evaluator boundary of the non-vacuous literal/blob T0 fixture. -/ +private def literalRoundTripNative : Array Lean.Name := nameNative ++ #[ + literalBlobsNativeAxiom + `Ix.Tc.SerializedLiteralBlobs.blobKeysClassifiedNative._native.native_decide.ax_1_1, + literalBlobsNativeAxiom + `Ix.Tc.SerializedLiteralBlobs.decodeSucceededNative._native.native_decide.ax_1_1, + literalBlobsNativeAxiom + `Ix.Tc.SerializedLiteralBlobs.encodeSucceededNative._native.native_decide.ax_1_1, + literalBlobsNativeAxiom + `Ix.Tc.SerializedLiteralBlobs.natBlobHashNative._native.native_decide.ax_1_1, + literalBlobsNativeAxiom + `Ix.Tc.SerializedLiteralBlobs.natBlobLookupNative._native.native_decide.ax_1_1, + literalBlobsNativeAxiom + `Ix.Tc.SerializedLiteralBlobs.natEntry._native.native_decide.ax_1_1, + literalBlobsNativeAxiom + `Ix.Tc.SerializedLiteralBlobs.natEntry._native.native_decide.ax_1_2, + literalBlobsNativeAxiom + `Ix.Tc.SerializedLiteralBlobs.natHashNative._native.native_decide.ax_1_1, + literalBlobsNativeAxiom + `Ix.Tc.SerializedLiteralBlobs.natLoadedNative._native.native_decide.ax_1_1, + literalBlobsNativeAxiom + `Ix.Tc.SerializedLiteralBlobs.natLookupNative._native.native_decide.ax_1_1, + literalBlobsNativeAxiom + `Ix.Tc.SerializedLiteralBlobs.natSucceededNative._native.native_decide.ax_1_1, + literalBlobsNativeAxiom + `Ix.Tc.SerializedLiteralBlobs.sourceAddressesClassifiedNative._native.native_decide.ax_1_1, + literalBlobsNativeAxiom + `Ix.Tc.SerializedLiteralBlobs.sourceAddressesNodupNative._native.native_decide.ax_1_1, + literalBlobsNativeAxiom + `Ix.Tc.SerializedLiteralBlobs.sourceKeysClassifiedNative._native.native_decide.ax_1_1, + literalBlobsNativeAxiom + `Ix.Tc.SerializedLiteralBlobs.stringBlobHashNative._native.native_decide.ax_1_1, + literalBlobsNativeAxiom + `Ix.Tc.SerializedLiteralBlobs.stringBlobLookupNative._native.native_decide.ax_1_1, + literalBlobsNativeAxiom + `Ix.Tc.SerializedLiteralBlobs.stringEntry._native.native_decide.ax_1_1, + literalBlobsNativeAxiom + `Ix.Tc.SerializedLiteralBlobs.stringEntry._native.native_decide.ax_1_2, + literalBlobsNativeAxiom + `Ix.Tc.SerializedLiteralBlobs.stringHashNative._native.native_decide.ax_1_1, + literalBlobsNativeAxiom + `Ix.Tc.SerializedLiteralBlobs.stringLoadedNative._native.native_decide.ax_1_1, + literalBlobsNativeAxiom + `Ix.Tc.SerializedLiteralBlobs.stringLookupNative._native.native_decide.ax_1_1, + literalBlobsNativeAxiom + `Ix.Tc.SerializedLiteralBlobs.stringSucceededNative._native.native_decide.ax_1_1 +] + +private def malformedConstantNative : Array Lean.Name := + canonicalPrimitivesNative.push <| literalBlobsNativeAxiom + `Ix.Tc.SerializedLiteralBlobs.malformedConstantRejectedNative._native.native_decide.ax_1_1 + +private def malformedBlobNative : Array Lean.Name := + canonicalPrimitivesNative.push <| literalBlobsNativeAxiom + `Ix.Tc.SerializedLiteralBlobs.malformedBlobRejectedNative._native.native_decide.ax_1_1 /- Direct upstream `sorryAx` origins. Listing the declarations, rather than -merely allowing `sorryAx`, makes upstream debt movement visible in review. -/ -private def inductiveWF : Lean.Name := ``Lean4Lean.VInductDecl.WF -private def addInduct : Lean.Name := ``Lean4Lean.VEnv.addInduct -private def addInductWF : Lean.Name := ``Lean4Lean.VEnv.addInduct_WF +merely allowing `sorryAx`, makes upstream debt movement visible in review. +The certificate-bearing Lean4Lean pin discharges the former `VInductDecl.WF`, +`VEnv.addInduct`, and `VEnv.addInduct_WF` origins. -/ 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] + #[forallEInv, sortInv] /- The empty legacy whole-`KEnv` inductive path is forbidden from every G2b consumer root. Keeping this list in the executable audit prevents an @@ -197,6 +870,17 @@ private def legacyWholeEnv : Array Lean.Name := #[ ``Ix.Tc.TrKEnv ] +/- E2a is intentionally a Theory-only certificate consumer. These +checker/catalog/pattern declarations must not enter its dependency graph. -/ +private def certificateAdapterForbidden : Array Lean.Name := #[ + ``Ix.Tc.Catalog, + ``Ix.Tc.RawInductiveConstRel, + ``Ix.Tc.RawRecursorRuleRel, + ``Ix.Tc.RawRecursorRulePatternRel, + ``Ix.Tc.InductiveOracle, + ``Lean4Lean.TrProj +] + /- 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. -/ @@ -210,6 +894,45 @@ private def legacyDeltaAuthority : Array Lean.Name := #[ private def k1ForbiddenDependencies : Array Lean.Name := legacyWholeEnv ++ legacyDeltaAuthority +/- Bounded recursive-method and checker roots must not silently regain the +all-depth, single-support closure interface whose finite-sort obstruction is +proved below. The legacy declarations remain audited as compatibility +artifacts while consumers migrate. -/ +private def legacyAllDepthKnot : Array Lean.Name := #[ + ``Ix.Tc.RecursiveMethodClosureContext, + ``Ix.Tc.RecursiveMethodClosureContext.closedAt, + ``Ix.Tc.RecursiveMethodClosureContext.methodsN, + ``Ix.Tc.RecursiveMethodClosureContext.fullInferenceContext, + ``Ix.Tc.RecursiveMethodClosureContext.next_fullInferenceWFAt, + ``Ix.Tc.RecursiveMethodClosureContext.methodsN_fullInferenceWFAt, + ``Ix.Tc.RecursiveMethodClosureContext.publicInfer_full_wf +] + +private def boundedKnotForbiddenDependencies : Array Lean.Name := + k1ForbiddenDependencies ++ legacyAllDepthKnot + +/- E2c occurrence-validation roots must be derived from the production run, +not from the ambient semantic inductive oracle retained by E2b. -/ +private def occurrenceValidationForbiddenDependencies : Array Lean.Name := + boundedKnotForbiddenDependencies.push ``Ix.Tc.InductiveOracle + +/- K2S keeps the global suffix model as a compatibility surface only. The +finite positive-fuel construction must neither manufacture that model nor +reach the older public adapters that consume it. -/ +private def legacyGlobalSuffix : Array Lean.Name := #[ + ``Ix.Tc.KernelSuffixModel, + ``Ix.Tc.ScopedKernelSuffixModel.toKernelSuffixModel, + ``Ix.Tc.PropositionClassifierContext, + ``Ix.Tc.RecursiveMethodRunContext, + ``Ix.Tc.TcM.whnf.wf_legacy, + ``Ix.Tc.TcM.infer.wf_legacy, + ``Ix.Tc.TcM.isDefEq.wf_legacy, + ``Ix.Tc.TcM.checkConst.wf_legacy +] + +private def scopedK2SForbiddenDependencies : Array Lean.Name := + boundedKnotForbiddenDependencies ++ legacyGlobalSuffix + private def roots : Array RootAllowance := #[ -- Level decision procedures. { root := ``Ix.Tc.univEq_sound, standardAxioms := standard }, @@ -277,8 +1000,7 @@ private def roots : Array RootAllowance := #[ nativeAxioms := expressionNative, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.supportAcceptance, - standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct], + standardAxioms := standard, nativeAxioms := inferNative, forbiddenDependencies := legacyWholeEnv }, -- G3b closes the remaining formalized walker/direct-intern families and @@ -346,65 +1068,64 @@ private def roots : Array RootAllowance := #[ { root := ``Ix.Tc.CheckConstSupport.abstractFVars, standardAxioms := standard, nativeAxioms := levelNative }, { root := ``Ix.Tc.ExecutionRequests.bind, - standardAxioms := standard, nativeAxioms := levelNative }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.ExecutionRequests.tryCatch, - standardAxioms := standard, nativeAxioms := levelNative }, + standardAxioms := standard, nativeAxioms := inferNative }, + { root := ``Ix.Tc.ExecutionRequests.runRec, + standardAxioms := standard, nativeAxioms := inferNative }, + { root := ``Ix.Tc.ExecutionRequests.isolateCheckErrors, + standardAxioms := standard, nativeAxioms := inferNative }, + { root := ``Ix.Tc.ExecutionRequests.modify, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.ExecutionRequests.weaken, - standardAxioms := standard, nativeAxioms := levelNative }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.ExecutionRequests.of_eq, - standardAxioms := standard, nativeAxioms := levelNative }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.ExecutionRequests.intern_eq_of_nil, - standardAxioms := standard, nativeAxioms := levelNative }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RunAssumptions.initial, - standardAxioms := standard, nativeAxioms := levelNative }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RunAssumptions.requestBounds, - standardAxioms := standard, nativeAxioms := levelNative }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RunAssumptions.internExpr_spec, - standardAxioms := standard, nativeAxioms := levelNative }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RunAssumptions.internUniv_spec, - standardAxioms := standard, nativeAxioms := levelNative }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RunSupport.CoversIntern.of_expr_univs, standardAxioms := standardWithoutChoice }, { root := ``Ix.Tc.RunAssumptions.lift_spec, - standardAxioms := standard, nativeAxioms := levelNative }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RunAssumptions.subst_spec, - standardAxioms := standard, nativeAxioms := levelNative }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RunAssumptions.simulSubst_spec, - standardAxioms := standard, nativeAxioms := levelNative }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RunAssumptions.instRev_spec, - standardAxioms := standard, nativeAxioms := levelNative }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RunAssumptions.abstractFVarsCached_spec, - standardAxioms := standard, nativeAxioms := levelNative }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RunAssumptions.abstractFVars_spec, - standardAxioms := standard, nativeAxioms := levelNative }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RunAssumptions.instantiateUnivParams_wf, - standardAxioms := standard, nativeAxioms := levelNative }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RunAssumptions.runIntern_supported_wf, - standardAxioms := standard, nativeAxioms := blake3Native, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := blake3Native }, { root := ``Ix.Tc.RunAssumptions.lift_wf, - standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RunAssumptions.subst_wf, - standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RunAssumptions.simulSubst_wf, - standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RunAssumptions.instRev_wf, - standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RunAssumptions.abstractFVars_wf, - standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RunAssumptions.instUniv_wf, - standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.AmbientNat.supportExecution, - standardAxioms := standard, nativeAxioms := levelNative, + standardAxioms := standard, nativeAxioms := inferNative, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.runAssumptions, - standardAxioms := standard, nativeAxioms := levelNative, + standardAxioms := standard, nativeAxioms := inferNative, forbiddenDependencies := legacyWholeEnv }, -- Expression translation, typing, uniqueness, and defeq bridges. @@ -429,19 +1150,17 @@ private def roots : Array RootAllowance := #[ -- Legacy whole-environment compatibility interfaces. G2b consumer roots -- below are forbidden from depending on these declarations. { root := ``Ix.Tc.TrKEnv.wf, - standardAxioms := standard, sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.TrKEnv.find?, - standardAxioms := standard, sorryOrigins := #[inductiveWF] }, + standardAxioms := standard }, { root := ``Ix.Tc.TcM.tick.tcInv, - standardAxioms := standard, sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.TcM.instantiateUnivParams.tcInv, - standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := levelNative }, -- The narrow upstream-context dependency behind translation uniqueness. { root := ``Ix.Tc.KVLCtx.IsDefEq.find?_uniq, - standardAxioms := standardWithoutChoice, - sorryOrigins := #[inductiveWF, addInduct, addInductWF] }, + standardAxioms := standard }, -- Dual-context reconciliation entry points used by the checker proofs. { root := ``Ix.Tc.CtxRecon.wf, standardAxioms := standard }, @@ -452,27 +1171,21 @@ private def roots : Array RootAllowance := #[ -- G1a's non-circular world and one-way lazy-load boundary. { root := ``Ix.Tc.VerifyWorld.ofCatalog_catalogued_not_trusted, - standardAxioms := standardWithoutChoice, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standardWithoutChoice }, { root := ``Ix.Tc.VerifyWorld.LE.trans, - standardAxioms := standardWithoutChoice, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standardWithoutChoice }, { root := ``Ix.Tc.VerifyWorld.LE.catalogued_iff, - standardAxioms := standardWithoutChoice, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standardWithoutChoice }, { root := ``Ix.Tc.LoadedAgrees.world_iff, - standardAxioms := standardWithoutChoice, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standardWithoutChoice }, { root := ``Ix.Tc.LoadedAgrees.insert, standardAxioms := standard }, { root := ``Ix.Tc.LoadedAgrees.of_extension, standardAxioms := standardWithoutChoice }, { root := ``Ix.Tc.VerifyWorld.ofCatalog_loaded, - standardAxioms := standardWithoutChoice, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standardWithoutChoice }, { root := ``Ix.Tc.VerifyWorld.ofCatalog_loaded_not_trusted, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, -- G1b's raw/pending boundary. Raw correspondence has no declaration-WF -- premise; the fixture roots pin the concrete non-WF pending case. @@ -483,98 +1196,185 @@ private def roots : Array RootAllowance := #[ { root := ``Ix.Tc.RawDeclRel.mono, standardAxioms := standard }, { root := ``Ix.Tc.PendingDecl.no_target_lookup, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.PendingDecl.no_self_expr_reference, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.PendingDecl.not_trustedDecl, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.IllTypedPending.pending_but_not_wf, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.IllTypedPending.loaded_pending_but_not_wf, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, -- G1c's trusted-only catalog log and explicit-WF promotion boundary. { root := ``Ix.Tc.RawDeclRel.wf_le, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.TrustedCatalogLog.wf, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.TrustedCatalogLog.catalogued, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.TrustedCatalogLog.find, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.TrustedCatalogRel.ofCatalog, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.TrustedCatalogRel.find, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.TrustedCatalogEntry.recursorRule, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.TrustedCatalogRel.recursorRule, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.TrustedCatalogEntry.recursorPattern, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.TrustedCatalogRel.recursorPattern, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.TrustedDecl.lookup, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.TrustedCatalogRel.lookup, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.Promotes.trans, - standardAxioms := standardWithoutChoice, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standardWithoutChoice }, { root := ``Ix.Tc.TrustedCatalogRel.promote, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.IllTypedPending.trustedCatalogRel, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.WellTypedPromotion.promotes, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, -- G1d's world-based concrete-state invariant. Loading stays -- representation-only, promotion requires a fresh WF witness, and the -- fixed-world Hoare roots pin no-promotion behavior on both outcomes. { root := ``Ix.Tc.TcStateWF.of_consts_eq, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.TcStateWF.load, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.TcStateWF.promote, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.TcStateWF.find?, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.TcInv.find?, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.IllTypedPending.tcInv_pending_but_not_wf, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.TcM.tick.tcStateWF, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.TcM.instantiateUnivParams.tcStateWF, - standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := levelNative }, + + -- Pin A / E2a: the certified-generation adapter may use only Lean4Lean + -- Theory transaction facts, never Ix checker/catalog/pattern authority. + { root := ``Ix.Tc.CertifiedGenerationTransaction.trace, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := certificateAdapterForbidden }, + { root := ``Ix.Tc.CertifiedGenerationTransaction.afterWF, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := certificateAdapterForbidden }, + { root := ``Ix.Tc.CertifiedGenerationTransaction.facts, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := certificateAdapterForbidden }, + + -- E2c occurrence-validation seam. These roots expose the selected loaded + -- family and strengthen every production guard into the elementwise + -- valid-inductive-application invariant, without oracle authority. + { root := + ``Ix.Tc.RecM.checkPositiveRecursiveApplicationPreconditions_success_iff, + standardAxioms := standard, + nativeAxioms := occurrenceValidationNative, + forbiddenDependencies := occurrenceValidationForbiddenDependencies }, + { root := ``Ix.Tc.RecM.positiveUniverseArgumentsAgree_eq_true_iff, + standardAxioms := standard, + nativeAxioms := occurrenceValidationNative, + forbiddenDependencies := occurrenceValidationForbiddenDependencies }, + { root := ``Ix.Tc.RecM.positiveIndicesIndependent_eq_true_iff, + standardAxioms := standard, + forbiddenDependencies := occurrenceValidationForbiddenDependencies }, + { root := ``Ix.Tc.RecM.checkPositiveParametersFrom_success, + standardAxioms := standard, + nativeAxioms := inferNative, + forbiddenDependencies := occurrenceValidationForbiddenDependencies }, + { root := ``Ix.Tc.RecM.checkPositiveParameters_success, + standardAxioms := standard, + nativeAxioms := inferNative, + forbiddenDependencies := occurrenceValidationForbiddenDependencies }, + { root := ``Ix.Tc.RecM.PositiveParameterComparisonTrace.sound, + standardAxioms := standard, + nativeAxioms := inferNative, + forbiddenDependencies := occurrenceValidationForbiddenDependencies }, + { root := ``Ix.Tc.RecM.PositiveParameterComparisonTrace.theoryDefEq, + standardAxioms := standard, + nativeAxioms := inferNative, + forbiddenDependencies := occurrenceValidationForbiddenDependencies }, + { root := + ``Ix.Tc.RecM.ValidPositiveRecursiveApplicationHeader.theoryParameters, + standardAxioms := standard, + nativeAxioms := inferNative, + forbiddenDependencies := occurrenceValidationForbiddenDependencies }, + { root := ``Ix.Tc.RecM.positivityGroupMatches_eq_true_iff, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := occurrenceValidationForbiddenDependencies }, + { root := + ``Ix.Tc.SpecializationIdentityFixture.semanticUniverseEquality_does_not_collapse_specialization, + standardAxioms := standard, + nativeAxioms := specializationIdentityNative, + forbiddenDependencies := occurrenceValidationForbiddenDependencies }, + { root := + ``Ix.Tc.RecM.checkPositiveRecursiveApplicationHeader_success, + standardAxioms := standard, + nativeAxioms := inferNative, + forbiddenDependencies := occurrenceValidationForbiddenDependencies }, + { root := ``Ix.Tc.RecM.PositiveRecursiveApplicationHeaderTrace.valid, + standardAxioms := standard, + nativeAxioms := inferNative, + forbiddenDependencies := occurrenceValidationForbiddenDependencies }, + { root := ``Ix.Tc.RecM.checkPositiveRecursiveApplicationHeader_valid, + standardAxioms := standard, + nativeAxioms := inferNative, + forbiddenDependencies := occurrenceValidationForbiddenDependencies }, + { root := ``Ix.Tc.RecM.checkPositiveRecursiveApplication_success, + standardAxioms := standard, + nativeAxioms := inferNative, + forbiddenDependencies := occurrenceValidationForbiddenDependencies }, + { root := ``Ix.Tc.RecM.PositiveRecursiveApplicationTrace.valid, + standardAxioms := standard, + nativeAxioms := inferNative, + forbiddenDependencies := occurrenceValidationForbiddenDependencies }, + { root := ``Ix.Tc.RecM.checkPositiveRecursiveApplication_valid, + standardAxioms := standard, + nativeAxioms := inferNative, + forbiddenDependencies := occurrenceValidationForbiddenDependencies }, + + -- E2b's first executable fragment. The family and recursor physical + -- blocks are linked positionally to one certified singleton enumeration; + -- the recursor pattern is proved from the exact registered equation and + -- then consumed by the ordinary E0 oracle-backed block transaction. + { root := ``Lean4Lean.VEnv.HasType.transfer_appN_telescope, + standardAxioms := standard, + sorryOrigins := typingDebt, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.SingletonFamilyCatalogLink.oracle, + standardAxioms := standard, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.SingletonRecursorCatalogLink.enumerationPatternRel, + standardAxioms := standard, + sorryOrigins := typingDebt, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.SingletonRecursorCatalogLink.oracle, + standardAxioms := standard, + sorryOrigins := typingDebt, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.RecM.certifySingletonFamilyBlock, + standardAxioms := standard, nativeAxioms := inductiveNative, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.RecM.certifySingletonRecursorBlock, + standardAxioms := standard, nativeAxioms := inductiveNative, + sorryOrigins := typingDebt, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + -- Concrete E2b closure: anonymous ingress, both production block-body and + -- branch checkers, exact physical/catalog ownership, and the two stable + -- oracle admissions are joined by one premise-free Boolean witness. + { root := ``Ix.Tc.BooleanEnumerationFixture.endToEndAcceptance, + standardAxioms := standard, nativeAxioms := booleanEnumerationNative, + sorryOrigins := typingDebt, + forbiddenDependencies := boundedKnotForbiddenDependencies }, -- G2a's explicit ambient-inductive assumption boundary. Audit every -- oracle projection so adding a field changes this manifest, then pin the @@ -596,134 +1396,98 @@ private def roots : Array RootAllowance := #[ { root := ``Ix.Tc.KConst.RecursorRuleAt.hasRecursorRule, standardAxioms := propextOnly }, { root := ``Ix.Tc.RawRecursorRulePatternRel.mono, - standardAxioms := propextOnly }, + standardAxioms := standardWithoutChoice }, { root := ``Ix.Tc.InductiveOracle.members, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.InductiveOracle.nonempty, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.InductiveOracle.fresh, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.InductiveOracle.after, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.InductiveOracle.envLE, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.InductiveOracle.blockWF, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.InductiveOracle.translateBlock, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.InductiveOracle.recursorFacts, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.InductiveOracle.recursorPatterns, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.InductiveOracle.catalogued, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.AmbientNat.oracle, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.AmbientNat.nat_lookup_good, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.AmbientNat.badDecl_not_wf, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.AmbientNat.acceptance, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, -- G2b's C1--C3 consumer path. These roots resolve exact concrete -- constants through trusted-world provenance and are mechanically barred -- from depending on the legacy whole-environment translation. { root := ``Ix.Tc.TrustedConstRel.mono, standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.TrustedConstRel.trKExprS_const, standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.TrustedCatalogRel.resolve, standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.TcStateWF.resolve, standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.TcInv.resolve, standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.natResolved, standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.natReferenceTranslates, standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.bad_not_resolved, standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.natResolvedInv, standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, -- G4's lookup isolation, exhaustive semantic-cache provenance, monotone -- warm-world transport, and transactional public-check error boundary. { root := ``Ix.Tc.PendingDecl.lookup_isolation, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.CacheEntry.SupportedBy.mono }, { root := ``Ix.Tc.CacheAuthority.stable_mono, - standardAxioms := standardWithoutChoice, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standardWithoutChoice }, { root := ``Ix.Tc.CacheProvenance.mono, - standardAxioms := standardWithoutChoice, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standardWithoutChoice }, { root := ``Ix.Tc.CacheProvenance.pending_isolation_stable, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.KEnv.restoreBlockCheckResultsOnError_origin, standardAxioms := standard }, { root := ``Ix.Tc.CacheInvariant.mono, - standardAxioms := standardWithoutChoice, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standardWithoutChoice }, { root := ``Ix.Tc.CacheInvariant.insertWhnf, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.CacheInvariant.insertWhnfNoDelta, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.CacheInvariant.insertWhnfNoDeltaCheap, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.CacheInvariant.insertWhnfCore, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.CacheInvariant.insertWhnfCoreCheap, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.CacheInvariant.of_intern_update, - standardAxioms := standardWithoutChoice, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standardWithoutChoice }, { root := ``Ix.Tc.CacheInvariant.clearReductionCaches, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.CacheInvariant.restoreCheckCachesOnError, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.TcM.isolateCheckErrors_error, standardAxioms := standardWithoutChoice }, { root := ``Ix.Tc.TcM.reset_cache_frame, @@ -731,72 +1495,54 @@ private def roots : Array RootAllowance := #[ nativeAxioms := #[nativeAxiom `Blake3 `Blake3.HasherOps.hash._native.native_decide.ax_1] }, { root := ``Ix.Tc.KernelStateWF.pendingCacheIsolation, - standardAxioms := standard, nativeAxioms := blake3Native, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := blake3Native }, { root := ``Ix.Tc.KernelStateWF.restoreCheckCachesOnError, - standardAxioms := standard, nativeAxioms := blake3Native, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := blake3Native }, { root := ``Ix.Tc.AmbientNat.warmCache_worldTransport, standardAxioms := standard, nativeAxioms := expressionNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.warmCache_cannotResolvePending, standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.cacheAcceptance, standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, -- K1's concrete Theory reduction meaning, exact five-way cache overlay, -- and real ambient-Nat warm-hit witness. The only sorries are the already -- named upstream inductive-environment boundary. { root := ``Ix.Tc.WhnfMeaning.refl, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.WhnfMeaning.symm, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.WhnfMeaning.mono, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.ExprCacheKind.isWhnf_iff }, { root := ``Ix.Tc.WhnfCacheValid.mono, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.WhnfCacheValid.expr, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { 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] }, + standardAxioms := standard }, { root := ``Ix.Tc.CacheInvariant.whnfHit, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.AmbientNat.supportExpr_whnfMeaning, standardAxioms := standard, nativeAxioms := expressionNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.warmHit_whnfMeaning, standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.RecM.tryReduceNative_noAccel, standardAxioms := standard, nativeAxioms := levelNative }, @@ -807,8 +1553,7 @@ private def roots : Array RootAllowance := #[ { root := ``Ix.Tc.RecM.tryReduceFinValDecidableRec_noAccel, standardAxioms := standard, nativeAxioms := expressionNative }, { root := ``Ix.Tc.WhnfTheory.exprWF, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct, addInductWF] }, + standardAxioms := standard }, { root := ``Ix.Tc.WhnfTheory.transMeaning, standardAxioms := standard, sorryOrigins := typingDebt }, @@ -819,42 +1564,31 @@ private def roots : Array RootAllowance := #[ { root := ``Ix.Tc.TcM.whnfKey_closed, standardAxioms := standard, nativeAxioms := contextNative }, { root := ``Ix.Tc.ContextKeyFrame.whnfStateInv, - standardAxioms := standard, nativeAxioms := blake3Native, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := blake3Native }, { root := ``Ix.Tc.TcM.ctxAddrForLbr_wf, standardAxioms := standard, nativeAxioms := contextNative }, { root := ``Ix.Tc.TcM.whnfKey_wf, - standardAxioms := standard, nativeAxioms := contextNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := contextNative }, { root := ``Ix.Tc.TcM.whnfKey_matches_wf, - standardAxioms := standard, nativeAxioms := contextNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := contextNative }, -- interning frame: exact intern-only framing, execution-indexed simultaneous -- substitution, and the production one-argument beta path. { root := ``Ix.Tc.InternUpdateFrame.whnfStateInv, - standardAxioms := standard, nativeAxioms := blake3Native, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := blake3Native }, { root := ``Ix.Tc.TcM.runIntern_whnf_wf, - standardAxioms := standard, nativeAxioms := blake3Native, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := blake3Native }, { root := ``Ix.Tc.TcM.runIntern_whnf_eval, - standardAxioms := standard, nativeAxioms := blake3Native, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := blake3Native }, { root := ``Ix.Tc.RunAssumptions.simulSubst_whnf_wf, - standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RunAssumptions.simulSubst_whnf_eval, - standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.WhnfMeaning.beta, - standardAxioms := standard, nativeAxioms := expressionNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF] }, + standardAxioms := standard, nativeAxioms := expressionNative }, { root := ``Ix.Tc.WhnfMeaning.letE, - standardAxioms := standard, nativeAxioms := expressionNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF] }, + standardAxioms := standard, nativeAxioms := expressionNative }, { root := ``Ix.Tc.WhnfMeaning.betaSimul, - standardAxioms := standard, nativeAxioms := expressionNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := expressionNative }, { root := ``Ix.Tc.RecM.WhnfCoreLeaf.eval, standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_betaOne, @@ -864,45 +1598,36 @@ private def roots : Array RootAllowance := #[ { root := ``Ix.Tc.RecM.whnfCoreWithFlagsUncached_betaOne, standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.whnfCoreWithFlagsUncached_betaOne_wf, - standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.whnfCoreWithFlags_leaf_wf, - standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.AmbientNat.warmStateInvAccelerated, standardAxioms := standard, nativeAxioms := inferNative.push nameDecideNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.warmKey_matches_wf, standardAxioms := standard, nativeAxioms := contextNative, - sorryOrigins := #[inductiveWF, addInduct], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.whnfCoreConst_noAccel_acceptance, standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.betaIdentityMeaning, standardAxioms := standard, nativeAxioms := expressionNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.betaSimulSpec, standardAxioms := standardWithoutQuot, nativeAxioms := expressionNative }, { root := ``Ix.Tc.AmbientNat.betaSimulMeaning, standardAxioms := standard, nativeAxioms := expressionNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.betaWalker_eval, standardAxioms := standard, nativeAxioms := expressionNative }, { root := ``Ix.Tc.AmbientNat.betaResultMeaning, standardAxioms := standard, nativeAxioms := expressionNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.betaCoreUncached_eval, standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.AmbientNat.betaCoreUncached_acceptance, standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, -- zeta reduction: both production zeta branches, including the legacy lifting walk, -- mixed-context semantic lookup, bounded driver, and inhabited fixtures. @@ -911,17 +1636,13 @@ private def roots : Array RootAllowance := #[ { root := ``Ix.Tc.TcM.lookupLetVal_eval, standardAxioms := standard, nativeAxioms := expressionNative }, { root := ``Ix.Tc.RunAssumptions.lift_whnf_wf, - standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RunAssumptions.lift_whnf_eval, - standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.WhnfMeaning.zetaVar, - standardAxioms := standard, nativeAxioms := expressionNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF] }, + standardAxioms := standard, nativeAxioms := expressionNative }, { root := ``Ix.Tc.WhnfMeaning.zetaFVar, - standardAxioms := standard, nativeAxioms := expressionNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF] }, + standardAxioms := standard, nativeAxioms := expressionNative }, { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_varZeta, standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_fvarZeta, @@ -933,50 +1654,40 @@ private def roots : Array RootAllowance := #[ { root := ``Ix.Tc.RecM.whnfCoreWithFlagsUncached_fvarZeta, standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.whnfCoreWithFlagsUncached_varZeta_acceptance, - standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.whnfCoreWithFlagsUncached_fvarZeta_acceptance, - standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.AmbientNat.bvarZetaLiftSpec, standardAxioms := standardWithoutQuot, nativeAxioms := expressionNative }, { root := ``Ix.Tc.AmbientNat.bvarZetaLookupEval, standardAxioms := standard, nativeAxioms := expressionNative }, { root := ``Ix.Tc.AmbientNat.bvarZetaMeaning, standardAxioms := standard, nativeAxioms := expressionNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.bvarZetaCoreUncachedEval, standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.AmbientNat.bvarZetaAcceptance, standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.fvarZetaMeaning, standardAxioms := standard, nativeAxioms := expressionNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.fvarZetaCoreUncachedEval, standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.AmbientNat.fvarZetaAcceptance, standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, -- 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, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.WhnfMeaning.registeredDefEq, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.InductiveReductionOracle.projection, - standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.InductiveReductionOracle.iota, - standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_projection, standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.whnfCoreWithFlagsStep_iota, @@ -986,11 +1697,9 @@ private def roots : Array RootAllowance := #[ { root := ``Ix.Tc.RecM.whnfCoreWithFlagsUncached_iota, standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.whnfCoreWithFlagsUncached_projection_acceptance, - standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.whnfCoreWithFlagsUncached_iota_acceptance, - standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.AmbientNat.projectionReduceEval, standardAxioms := standard, nativeAxioms := expressionNative, forbiddenDependencies := legacyWholeEnv }, @@ -999,15 +1708,12 @@ private def roots : Array RootAllowance := #[ 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 := inferNative, - sorryOrigins := #[inductiveWF, addInduct], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.iotaStateInv, standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.iotaTryEval, standardAxioms := standard, nativeAxioms := inferNative, @@ -1017,56 +1723,44 @@ private def roots : Array RootAllowance := #[ 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 := inferNative, - sorryOrigins := #[inductiveWF, addInduct], forbiddenDependencies := legacyWholeEnv }, -- 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 := inferNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.WhnfCoreTrace.eval, - standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.WhnfCoreTrace.initialInv, - standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.WhnfCoreTrace.finalInv, - standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.WhnfCoreTrace.meaning, standardAxioms := standard, nativeAxioms := inferNative, sorryOrigins := typingDebt }, { root := ``Ix.Tc.RecM.WhnfCoreTrace.uncached_eval, - standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.WhnfCoreTrace.uncached_acceptance, standardAxioms := standard, nativeAxioms := inferNative, sorryOrigins := typingDebt }, { root := ``Ix.Tc.AmbientNat.structuralNatLit_type, standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.structuralWhnfTheory, standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.structuralLoopStateInv, standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.structuralLoopSourceMeaning, standardAxioms := standard, nativeAxioms := expressionNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.structuralLoopBetaMeaning, standardAxioms := standard, nativeAxioms := expressionNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.structuralLoopFVarStep, standardAxioms := standard, nativeAxioms := inferNative, @@ -1076,7 +1770,6 @@ private def roots : Array RootAllowance := #[ forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.structuralLoopTrace, standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.structuralLoopAcceptance, standardAxioms := standard, nativeAxioms := inferNative, @@ -1084,7 +1777,6 @@ private def roots : Array RootAllowance := #[ forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.structuralLoopZeroFuel, standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct], forbiddenDependencies := legacyWholeEnv }, -- structural cache: the public structural entry point's keyed body has exact full, -- cheap, miss, hit, and transient equations. Misses require both an @@ -1110,17 +1802,13 @@ private def roots : Array RootAllowance := #[ { root := ``Ix.Tc.RecM.whnfCoreWithFlagsNonLeaf_transient, standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.WhnfCoreCacheUpdate.full_whnfStateInv, - standardAxioms := standard, nativeAxioms := blake3Native, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := blake3Native }, { root := ``Ix.Tc.RecM.WhnfCoreCacheUpdate.cheap_whnfStateInv, - standardAxioms := standard, nativeAxioms := blake3Native, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := blake3Native }, { root := ``Ix.Tc.RecM.whnfCoreWithFlags_fullHit_acceptance, - standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.whnfCoreWithFlags_cheapHit_acceptance, - standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.whnfCoreWithFlags_fullMiss_acceptance, standardAxioms := standard, nativeAxioms := inferNative, sorryOrigins := typingDebt }, @@ -1132,34 +1820,27 @@ private def roots : Array RootAllowance := #[ sorryOrigins := typingDebt }, { root := ``Ix.Tc.AmbientNat.betaArgMeaning, standardAxioms := standard, nativeAxioms := expressionNative, - sorryOrigins := #[inductiveWF, addInduct], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.fullCoreProvenance, standardAxioms := standard, nativeAxioms := expressionNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.cheapCoreProvenance, standardAxioms := standard, nativeAxioms := expressionNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.coreCacheFreshStateInv, standardAxioms := standard, nativeAxioms := expressionNative, - sorryOrigins := #[inductiveWF, addInduct], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.fullCoreWarmStateInv, standardAxioms := standard, nativeAxioms := expressionNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.bothCoreWarmStateInv, standardAxioms := standard, nativeAxioms := expressionNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.coreCacheKey_eval, standardAxioms := standard, nativeAxioms := contextNative, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.coreCacheKey_matches, standardAxioms := standard, nativeAxioms := contextNative, - sorryOrigins := #[inductiveWF, addInduct], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.betaTransientFalse, standardAxioms := standard, nativeAxioms := expressionNative, @@ -1172,7 +1853,6 @@ private def roots : Array RootAllowance := #[ forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.coreCacheTrace, standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.fullCoreColdAcceptance, standardAxioms := standard, nativeAxioms := inferNative, @@ -1180,7 +1860,6 @@ private def roots : Array RootAllowance := #[ forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.fullCoreWarmAcceptance, standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.cheapCorePolicyMissAcceptance, standardAxioms := standard, nativeAxioms := inferNative, @@ -1188,7 +1867,6 @@ private def roots : Array RootAllowance := #[ forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.cheapCoreWarmAcceptance, standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.coreCachePolicyIsolation, standardAxioms := standard, nativeAxioms := expressionNative, @@ -1199,8 +1877,7 @@ private def roots : Array RootAllowance := #[ -- 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, nativeAxioms := blake3Native, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := blake3Native }, { root := ``Ix.Tc.TcM.stepTrace_disabled, standardAxioms := standardWithoutChoice }, { root := ``Ix.Tc.TcM.bumpStats_disabled, @@ -1208,44 +1885,34 @@ private def roots : Array RootAllowance := #[ { root := ``Ix.Tc.TcM.tick_success, standardAxioms := standardWithoutChoice }, { root := ``Ix.Tc.RecM.WhnfNoDeltaTrace.no_zero, - standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.WhnfNoDeltaTrace.eval, - standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.WhnfNoDeltaTrace.initialInv, - standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.WhnfNoDeltaTrace.finalInv, - standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.WhnfNoDeltaTrace.meaning, standardAxioms := standard, nativeAxioms := inferNative, sorryOrigins := typingDebt }, { root := ``Ix.Tc.RecM.WhnfNoDeltaTrace.uncached_eval, - standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.WhnfNoDeltaTrace.uncached_acceptance, standardAxioms := standard, nativeAxioms := inferNative, sorryOrigins := typingDebt }, { root := ``Ix.Tc.RecM.WhnfFullTrace.no_zero, - standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.WhnfFullTrace.eval, - standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.WhnfFullTrace.initialInv, - standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.WhnfFullTrace.finalInv, - standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.WhnfFullTrace.meaning, standardAxioms := standard, nativeAxioms := inferNative, sorryOrigins := typingDebt }, { root := ``Ix.Tc.RecM.WhnfFullTrace.uncached_eval, - standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.WhnfFullTrace.uncached_acceptance, standardAxioms := standard, nativeAxioms := inferNative, sorryOrigins := typingDebt }, @@ -1276,20 +1943,15 @@ private def roots : Array RootAllowance := #[ { root := ``Ix.Tc.RecM.whnfNoDeltaImplNonLeaf_nativeNoInsert, standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.WhnfDriverCacheUpdate.noDelta_whnfStateInv, - standardAxioms := standard, nativeAxioms := blake3Native, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := blake3Native }, { root := ``Ix.Tc.RecM.WhnfDriverCacheUpdate.noDeltaCheap_whnfStateInv, - standardAxioms := standard, nativeAxioms := blake3Native, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := blake3Native }, { root := ``Ix.Tc.RecM.WhnfDriverCacheUpdate.full_whnfStateInv, - standardAxioms := standard, nativeAxioms := blake3Native, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := blake3Native }, { root := ``Ix.Tc.RecM.whnfNoDeltaImpl_fullHit_acceptance, - standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.whnfNoDeltaImpl_cheapHit_acceptance, - standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.whnfNoDeltaImpl_fullMiss_acceptance, standardAxioms := standard, nativeAxioms := inferNative, sorryOrigins := typingDebt }, @@ -1313,8 +1975,7 @@ private def roots : Array RootAllowance := #[ { root := ``Ix.Tc.RecM.whnfWithNatSuccModeNonLeaf_nativeNoInsert, standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.whnfWithNatSuccMode_hit_acceptance, - standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.whnfWithNatSuccMode_miss_acceptance, standardAxioms := standard, nativeAxioms := inferNative, sorryOrigins := typingDebt }, @@ -1328,23 +1989,18 @@ private def roots : Array RootAllowance := #[ standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.AmbientNat.betaNoDeltaStep, standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.fullNoDeltaProvenance, standardAxioms := standard, nativeAxioms := expressionNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.fullWhnfProvenance, standardAxioms := standard, nativeAxioms := expressionNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.fullNoDeltaWarmStateInv, standardAxioms := standard, nativeAxioms := expressionNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.noDeltaTrace, standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.fullNoDeltaColdAcceptance, standardAxioms := standard, nativeAxioms := inferNative, @@ -1352,14 +2008,12 @@ private def roots : Array RootAllowance := #[ forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.fullNoDeltaWarmAcceptance, standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.noDeltaCachePolicyIsolation, standardAxioms := standard, nativeAxioms := expressionNative, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.fullWhnfChargedStateInv, standardAxioms := standard, nativeAxioms := expressionNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.fullWhnfPrefixCold, standardAxioms := standard, nativeAxioms := expressionNative, @@ -1375,11 +2029,9 @@ private def roots : Array RootAllowance := #[ forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.fullWhnfTrace, standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.fullWhnfWarmStateInv, standardAxioms := standard, nativeAxioms := expressionNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.fullWhnfColdAcceptance, standardAxioms := standard, nativeAxioms := inferNative, @@ -1387,7 +2039,6 @@ private def roots : Array RootAllowance := #[ forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.fullWhnfWarmAcceptance, standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.fullWhnfFuelDiscipline, standardAxioms := standard, nativeAxioms := expressionNative, @@ -1403,43 +2054,33 @@ private def roots : Array RootAllowance := #[ { root := ``Ix.Tc.WhnfPost.transMeaning, standardAxioms := standard, sorryOrigins := typingDebt }, { root := ``Ix.Tc.WhnfPost.meaning, - standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard }, { root := ``Ix.Tc.TcM.isLetVar_wf, standardAxioms := standardWithoutChoice }, { root := ``Ix.Tc.TcM.stepTrace_whnf_wf, - standardAxioms := standard, nativeAxioms := blake3Native, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := blake3Native }, { root := ``Ix.Tc.TcM.bumpStats_whnf_wf, - standardAxioms := standard, nativeAxioms := blake3Native, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := blake3Native }, { root := ``Ix.Tc.RecM.WF.liftTcM, - standardAxioms := standard, nativeAxioms := blake3Native, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := blake3Native }, { root := ``Ix.Tc.RecM.WF.get, - standardAxioms := standard, nativeAxioms := blake3Native, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := blake3Native }, { root := ``Ix.Tc.RecM.WF.modifyGet, - standardAxioms := standard, nativeAxioms := blake3Native, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := blake3Native }, { root := ``Ix.Tc.RecM.WF.modify, - standardAxioms := standard, nativeAxioms := blake3Native, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := blake3Native }, { root := ``Ix.Tc.RecM.WhnfCoreTrace.complete, - standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := inferNative }, { 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] }, + standardAxioms := standard, nativeAxioms := inferNative }, { 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] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.WhnfFullTrace.uncached_wf, standardAxioms := standard, nativeAxioms := inferNative, sorryOrigins := typingDebt }, @@ -1460,11 +2101,9 @@ private def roots : Array RootAllowance := #[ sorryOrigins := typingDebt, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.RecM.whnfWithNatSuccModePrefix_wf, - standardAxioms := standard, nativeAxioms := blake3Native, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := blake3Native }, { root := ``Ix.Tc.RecM.whnfWithNatSuccModeMissCharge_wf, - standardAxioms := standard, nativeAxioms := blake3Native, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := blake3Native }, { root := ``Ix.Tc.RecM.whnfWithNatSuccMode_nonLeaf_semantic_wf, standardAxioms := standard, nativeAxioms := inferNative, sorryOrigins := typingDebt, @@ -1487,58 +2126,44 @@ private def roots : Array RootAllowance := #[ 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] }, + standardAxioms := standard }, { root := ``Ix.Tc.RecM.WF.bind, - standardAxioms := standard, nativeAxioms := blake3Native, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := blake3Native }, { root := ``Ix.Tc.RecM.runBounded_wf, - standardAxioms := standard, nativeAxioms := blake3Native, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := blake3Native }, { root := ``Ix.Tc.RecM.WhnfLeaf.eval, standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.whnf_leaf_wf, - standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.whnf_leaf_wf_of_theory, - standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF] }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.AmbientNat.noAccelStateInv, standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.whnfLeaf_noAccel_wf, standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.whnfLeaf_noAccel_acceptance, standardAxioms := standard, nativeAxioms := inferNative, - sorryOrigins := #[inductiveWF, addInduct], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.TcM.whnfKey_fst, standardAxioms := standard, nativeAxioms := contextNative }, { root := ``Ix.Tc.WhnfContextKeys.Matches.sourceAddr, - standardAxioms := standard, nativeAxioms := contextNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := contextNative }, { root := ``Ix.Tc.CacheProvenance.whnfMeaningOfMatches, - standardAxioms := standard, nativeAxioms := contextNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := contextNative }, { root := ``Ix.Tc.CacheInvariant.whnfHitOfMatches, - standardAxioms := standard, nativeAxioms := contextNative, - sorryOrigins := #[inductiveWF, addInduct] }, + standardAxioms := standard, nativeAxioms := contextNative }, { root := ``Ix.Tc.AmbientNat.warmKey_matches, standardAxioms := standard, nativeAxioms := contextNative, - sorryOrigins := #[inductiveWF, addInduct], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.methodsN_zero, standardAxioms := standard, nativeAxioms := inferNative }, @@ -1791,34 +2416,27 @@ private def roots : Array RootAllowance := #[ -- 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], + standardAxioms := standard, nativeAxioms := inferNative, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.RunAssumptions.subst_whnf_eval, - standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct], + standardAxioms := standard, nativeAxioms := inferNative, 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` @@ -1831,19 +2449,15 @@ private def roots : Array RootAllowance := #[ 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 @@ -1863,19 +2477,15 @@ private def roots : Array RootAllowance := #[ 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 @@ -1888,8 +2498,7 @@ private def roots : Array RootAllowance := #[ { root := ``Ix.Tc.InternUpdateFrame.trans, standardAxioms := standardWithoutChoice }, { root := ``Ix.Tc.RunAssumptions.internExpr_whnf_eval, - standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct], + standardAxioms := standard, nativeAxioms := inferNative, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.RecM.finishAppResult_eq_foldlM, standardAxioms := standard, nativeAxioms := expressionNative }, @@ -1899,14 +2508,12 @@ private def roots : Array RootAllowance := #[ standardAxioms := standardWithoutQuot, nativeAxioms := expressionNative }, { root := ``Ix.Tc.RecM.FinishAppRequests.support, - standardAxioms := standard, nativeAxioms := levelNative }, + standardAxioms := standard, nativeAxioms := inferNative }, { root := ``Ix.Tc.RecM.FinishAppRequests.foldlM_eval, - standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct], + standardAxioms := standard, nativeAxioms := inferNative, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.RecM.FinishAppRequests.eval, - standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct], + standardAxioms := standard, nativeAxioms := inferNative, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.RecM.FinishAppRequests.final_eq_spec, standardAxioms := standard, nativeAxioms := expressionNative }, @@ -1920,37 +2527,29 @@ private def roots : Array RootAllowance := #[ 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 }, @@ -1967,11 +2566,9 @@ private def roots : Array RootAllowance := #[ 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 }, @@ -1993,7 +2590,6 @@ private def roots : Array RootAllowance := #[ { 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, @@ -2003,14 +2599,12 @@ private def roots : Array RootAllowance := #[ 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, @@ -2020,7 +2614,7 @@ private def roots : Array RootAllowance := #[ sorryOrigins := typingDebt, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.RawRecursorRulePatternRel.checkedReduction, - standardAxioms := propextOnly, + standardAxioms := standardWithoutChoice, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.RecM.NatRecLiteralTranslationSplit.checkedRhsSuffix, standardAxioms := standard, nativeAxioms := expressionNative, @@ -2067,14 +2661,12 @@ private def roots : Array RootAllowance := #[ 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, @@ -2084,27 +2676,21 @@ private def roots : Array RootAllowance := #[ 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, @@ -2112,7 +2698,6 @@ private def roots : Array RootAllowance := #[ forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.WhnfMeaning.ofStructuralQuot, standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.KExpr.substNoIntern_of_lbr_le, standardAxioms := standardWithoutQuot, @@ -2127,49 +2712,38 @@ private def roots : Array RootAllowance := #[ 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, @@ -2177,15 +2751,12 @@ private def roots : Array RootAllowance := #[ 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, @@ -2193,7 +2764,6 @@ private def roots : Array RootAllowance := #[ 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, @@ -2217,19 +2787,15 @@ private def roots : Array RootAllowance := #[ 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, @@ -2242,7 +2808,6 @@ private def roots : Array RootAllowance := #[ { root := ``Ix.Tc.RecM.ApplyIotaRuleTrace.registeredStartQuot_empty, standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct, addInductWF], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.RecM.ApplyIotaRuleTrace.registeredAcceptance_empty, @@ -2284,15 +2849,12 @@ private def roots : Array RootAllowance := #[ 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, @@ -2730,26 +3292,22 @@ private def roots : Array RootAllowance := #[ 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, + standardAxioms := standard, nativeAxioms := inferNative, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.RecM.StructEtaFieldRequests.eval, - standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct], + standardAxioms := standard, nativeAxioms := inferNative, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.RecM.StructEtaBuildRequests.eval, - standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct], + standardAxioms := standard, nativeAxioms := inferNative, 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 @@ -2759,7 +3317,6 @@ private def roots : Array RootAllowance := #[ 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, @@ -2769,19 +3326,15 @@ private def roots : Array RootAllowance := #[ 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 @@ -2790,23 +3343,18 @@ private def roots : Array RootAllowance := #[ -- 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, @@ -2819,41 +3367,33 @@ private def roots : Array RootAllowance := #[ 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 @@ -2862,7 +3402,6 @@ private def roots : Array RootAllowance := #[ -- 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, @@ -2872,19 +3411,15 @@ private def roots : Array RootAllowance := #[ 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 @@ -2892,15 +3427,12 @@ private def roots : Array RootAllowance := #[ -- 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], + standardAxioms := standard, nativeAxioms := inferNative, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.RecM.finishStructEtaAfterSort_wf_of_requests, - standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct], + standardAxioms := standard, nativeAxioms := inferNative, forbiddenDependencies := legacyWholeEnv }, -- CacheShell: both structural-core cache partitions now have explicit @@ -2908,11 +3440,9 @@ private def roots : Array RootAllowance := #[ -- 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, @@ -2929,15 +3459,12 @@ private def roots : Array RootAllowance := #[ -- 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 @@ -2951,15 +3478,12 @@ private def roots : Array RootAllowance := #[ 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 @@ -2967,18 +3491,15 @@ private def roots : Array RootAllowance := #[ -- 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, @@ -2989,11 +3510,9 @@ private def roots : Array RootAllowance := #[ -- 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, @@ -3004,7 +3523,6 @@ private def roots : Array RootAllowance := #[ 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, @@ -3014,7 +3532,7 @@ private def roots : Array RootAllowance := #[ -- 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, + standardAxioms := standard, nativeAxioms := inferNative, sorryOrigins := typingDebt, forbiddenDependencies := legacyWholeEnv }, @@ -3026,7 +3544,6 @@ private def roots : Array RootAllowance := #[ 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, @@ -3043,31 +3560,24 @@ private def roots : Array RootAllowance := #[ 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 @@ -3075,24 +3585,19 @@ private def roots : Array RootAllowance := #[ -- 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 @@ -3101,46 +3606,36 @@ private def roots : Array RootAllowance := #[ -- 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, @@ -3176,18 +3671,15 @@ private def roots : Array RootAllowance := #[ 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, @@ -3203,15 +3695,12 @@ private def roots : Array RootAllowance := #[ 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 @@ -3222,12 +3711,10 @@ private def roots : Array RootAllowance := #[ standardAxioms := standardWithoutQuot, nativeAxioms := expressionNative, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.RecM.IotaArgsInternRequests.wfList, - standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct], + standardAxioms := standard, nativeAxioms := inferNative, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.RecM.IotaArgsInternRequests.wfArray, - standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct], + standardAxioms := standard, nativeAxioms := inferNative, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.RecM.applyIotaArg_true_state_wf, standardAxioms := standard, nativeAxioms := expressionNative, @@ -3242,16 +3729,13 @@ private def roots : Array RootAllowance := #[ standardAxioms := standardWithoutQuot, nativeAxioms := levelNative, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.RecM.applyIotaRule_state_wf_of_requests, - standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct], + standardAxioms := standard, nativeAxioms := inferNative, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.RecM.tryApplyIotaCtor_state_wf_of_requests, - standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct], + standardAxioms := standard, nativeAxioms := inferNative, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.RecM.TryApplyIotaCtorPreserves.of_requests, - standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct], + standardAxioms := standard, nativeAxioms := inferNative, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.RecM.StructEtaFinishRequests, standardAxioms := standardWithoutQuot, nativeAxioms := levelNative, @@ -3260,16 +3744,13 @@ private def roots : Array RootAllowance := #[ standardAxioms := standardWithoutQuot, nativeAxioms := levelNative, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.RecM.StructEtaFinishPreserves.of_requests, - standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct], + standardAxioms := standard, nativeAxioms := inferNative, 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, @@ -3279,15 +3760,12 @@ private def roots : Array RootAllowance := #[ 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, @@ -3297,43 +3775,33 @@ private def roots : Array RootAllowance := #[ 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], + standardAxioms := standard, nativeAxioms := inferNative, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.RecM.verifyKSynthCandidate_state_wf_of_requests, - standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct], + standardAxioms := standard, nativeAxioms := inferNative, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.RecM.selectKSynthCandidate_state_wf_of_requests, - standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct], + standardAxioms := standard, nativeAxioms := inferNative, 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], + standardAxioms := standard, nativeAxioms := inferNative, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.RecM.selectKSynthCandidate_state_wf_of_inputs, - standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct], + standardAxioms := standard, nativeAxioms := inferNative, 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 @@ -3341,26 +3809,21 @@ private def roots : Array RootAllowance := #[ -- 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, @@ -3391,7 +3854,6 @@ private def roots : Array RootAllowance := #[ 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, @@ -3411,15 +3873,12 @@ private def roots : Array RootAllowance := #[ 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 @@ -3431,23 +3890,19 @@ private def roots : Array RootAllowance := #[ 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], + standardAxioms := standard, nativeAxioms := inferNative, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.RecM.tryReduceProjectionDefinition_inv_wf, - standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct], + standardAxioms := standard, nativeAxioms := inferNative, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.RecM.tryReduceProjectionDefinition_optional_wf_of_contexts, - standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct], + standardAxioms := standard, nativeAxioms := inferNative, forbiddenDependencies := legacyWholeEnv }, -- Quotient: quotient reduction derives the selected major's support and -- translation from its real application-spine position, executes the @@ -3459,29 +3914,24 @@ private def roots : Array RootAllowance := #[ 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], + standardAxioms := standard, nativeAxioms := inferNative, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.RecM.tryQuotReduce_inv_wf, - standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct], + standardAxioms := standard, nativeAxioms := inferNative, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.RecM.tryQuotReduce_optional_wf_of_contexts, - standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct], + standardAxioms := standard, nativeAxioms := inferNative, 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, @@ -3492,7 +3942,6 @@ private def roots : Array RootAllowance := #[ -- `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, @@ -3506,7 +3955,6 @@ private def roots : Array RootAllowance := #[ -- 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, @@ -3514,34 +3962,31 @@ private def roots : Array RootAllowance := #[ 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, + standardAxioms := standard, nativeAxioms := inferNative, 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, + standardAxioms := standard, nativeAxioms := inferNative, sorryOrigins := typingDebt, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.RecM.deltaUnfoldOne_trusted_wf, - standardAxioms := standard, nativeAxioms := levelNative, + standardAxioms := standard, nativeAxioms := inferNative, sorryOrigins := typingDebt, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.RecM.TrustedDeltaContext, - standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct], + standardAxioms := standard, nativeAxioms := inferNative, forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.RecM.TrustedDeltaContext.wfAt, - standardAxioms := standard, nativeAxioms := levelNative, + standardAxioms := standard, nativeAxioms := inferNative, sorryOrigins := typingDebt, forbiddenDependencies := k1ForbiddenDependencies }, { root := ``Ix.Tc.RecM.FullWhnfStepContext.ofTrustedDelta, @@ -3550,15 +3995,12 @@ private def roots : Array RootAllowance := #[ 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, @@ -3646,7 +4088,6 @@ private def roots : Array RootAllowance := #[ forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.iotaArgsStateInv, standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.iotaArgsSupport_head, standardAxioms := standardWithoutQuot, @@ -3681,15 +4122,12 @@ private def roots : Array RootAllowance := #[ 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, @@ -3697,7 +4135,6 @@ private def roots : Array RootAllowance := #[ forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.multiIotaStateInv, standardAxioms := standard, nativeAxioms := levelNative, - sorryOrigins := #[inductiveWF, addInduct], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.AmbientNat.multiIotaSupport_start, standardAxioms := standardWithoutQuot, @@ -3717,15 +4154,12 @@ private def roots : Array RootAllowance := #[ 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, @@ -3745,7 +4179,6 @@ private def roots : Array RootAllowance := #[ 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, @@ -3753,7 +4186,6 @@ private def roots : Array RootAllowance := #[ 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, @@ -3765,7 +4197,6 @@ private def roots : Array RootAllowance := #[ 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, @@ -3781,11 +4212,9 @@ private def roots : Array RootAllowance := #[ 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 }, @@ -3793,13 +4222,11 @@ private def roots : Array RootAllowance := #[ 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 @@ -3863,15 +4290,12 @@ private def roots : Array RootAllowance := #[ 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, @@ -3885,19 +4309,15 @@ private def roots : Array RootAllowance := #[ -- 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, @@ -3922,27 +4342,21 @@ private def roots : Array RootAllowance := #[ 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 @@ -3950,43 +4364,33 @@ private def roots : Array RootAllowance := #[ -- 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, @@ -4005,31 +4409,24 @@ private def roots : Array RootAllowance := #[ -- 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, @@ -4048,35 +4445,27 @@ private def roots : Array RootAllowance := #[ -- 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, @@ -4161,15 +4550,12 @@ private def roots : Array RootAllowance := #[ 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 @@ -4194,7 +4580,6 @@ private def roots : Array RootAllowance := #[ 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, @@ -4264,15 +4649,12 @@ private def roots : Array RootAllowance := #[ 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, @@ -4300,19 +4682,15 @@ private def roots : Array RootAllowance := #[ -- 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, @@ -4346,7 +4724,6 @@ private def roots : Array RootAllowance := #[ 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, @@ -4419,19 +4796,15 @@ private def roots : Array RootAllowance := #[ -- 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, @@ -4439,7 +4812,6 @@ private def roots : Array RootAllowance := #[ 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, @@ -4474,7 +4846,6 @@ private def roots : Array RootAllowance := #[ 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, @@ -4482,19 +4853,15 @@ private def roots : Array RootAllowance := #[ 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, @@ -4537,31 +4904,24 @@ private def roots : Array RootAllowance := #[ -- 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 @@ -4569,41 +4929,33 @@ private def roots : Array RootAllowance := #[ -- 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 @@ -4611,23 +4963,18 @@ private def roots : Array RootAllowance := #[ -- 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, @@ -4637,27 +4984,21 @@ private def roots : Array RootAllowance := #[ 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, @@ -4679,31 +5020,24 @@ private def roots : Array RootAllowance := #[ 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, @@ -4713,11 +5047,9 @@ private def roots : Array RootAllowance := #[ 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 @@ -4728,103 +5060,78 @@ private def roots : Array RootAllowance := #[ 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- @@ -4867,7 +5174,6 @@ private def roots : Array RootAllowance := #[ -- 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, @@ -4875,15 +5181,12 @@ private def roots : Array RootAllowance := #[ 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 @@ -4892,19 +5195,15 @@ private def roots : Array RootAllowance := #[ -- 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, @@ -4924,20 +5223,16 @@ private def roots : Array RootAllowance := #[ 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, @@ -4962,7 +5257,6 @@ private def roots : Array RootAllowance := #[ 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, @@ -4987,7 +5281,6 @@ private def roots : Array RootAllowance := #[ -- 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, @@ -4998,7 +5291,6 @@ private def roots : Array RootAllowance := #[ forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.RecM.constantHeadsDefEq, standardAxioms := standard, - sorryOrigins := #[inductiveWF, addInduct], forbiddenDependencies := legacyWholeEnv }, { root := ``Ix.Tc.RecM.trySameHeadSpine_wf, standardAxioms := standard, nativeAxioms := blake3Native, @@ -5010,23 +5302,18 @@ private def roots : Array RootAllowance := #[ 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, @@ -5077,11 +5364,9 @@ private def roots : Array RootAllowance := #[ 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, @@ -5117,11 +5402,9 @@ private def roots : Array RootAllowance := #[ -- 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 @@ -5129,24 +5412,19 @@ private def roots : Array RootAllowance := #[ -- 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 @@ -5176,7 +5454,6 @@ private def roots : Array RootAllowance := #[ 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, @@ -5234,11 +5511,9 @@ private def roots : Array RootAllowance := #[ -- 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, @@ -5250,11 +5525,9 @@ private def roots : Array RootAllowance := #[ 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, @@ -5266,7 +5539,6 @@ private def roots : Array RootAllowance := #[ 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, @@ -5294,7 +5566,6 @@ private def roots : Array RootAllowance := #[ 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, @@ -5315,7 +5586,6 @@ private def roots : Array RootAllowance := #[ -- 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, @@ -5343,7 +5613,6 @@ private def roots : Array RootAllowance := #[ 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, @@ -5355,23 +5624,18 @@ private def roots : Array RootAllowance := #[ -- 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. @@ -5388,7 +5652,6 @@ private def roots : Array RootAllowance := #[ 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, @@ -5396,11 +5659,9 @@ private def roots : Array RootAllowance := #[ 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 @@ -5410,7 +5671,6 @@ private def roots : Array RootAllowance := #[ -- 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, @@ -5433,11 +5693,9 @@ private def roots : Array RootAllowance := #[ -- 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, @@ -5453,7 +5711,6 @@ private def roots : Array RootAllowance := #[ 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, @@ -5479,7 +5736,6 @@ private def roots : Array RootAllowance := #[ -- 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, @@ -5495,11 +5751,9 @@ private def roots : Array RootAllowance := #[ -- 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, @@ -5507,7 +5761,6 @@ private def roots : Array RootAllowance := #[ 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, @@ -5539,11 +5792,9 @@ private def roots : Array RootAllowance := #[ 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, @@ -5554,33 +5805,26 @@ private def roots : Array RootAllowance := #[ 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`. + -- Legacy all-depth six-field knot assembly under the canonical production + -- cache stack. These roots remain audited as migration adapters, but the + -- bounded public interfaces below are forbidden from depending on them. { 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, @@ -5589,6 +5833,791 @@ private def roots : Array RootAllowance := #[ { root := ``Ix.Tc.RecursiveMethodClosureContext.methodsN, standardAxioms := standard, nativeAxioms := inferNative, sorryOrigins := typingDebt.push trProjSorry, + forbiddenDependencies := k1ForbiddenDependencies }, + + -- The all-depth closure interface is provably unusable for a + -- finite support containing a sort: its syntax resources would generate + -- an unbounded successor-sort chain. The replacement below separates the + -- finite result footprint from fuel-indexed method-call domains. + { root := + ``Ix.Tc.FiniteSupportBoundary.SyntaxInferenceResources.no_sort_source, + standardAxioms := standard, nativeAxioms := levelNative, + forbiddenDependencies := k1ForbiddenDependencies }, + + -- C1A's usable production boundary: a finite schedule closes only the + -- method-table depths selected by this run's recursion fuel. The public + -- adapters consume the terminal successor-layer domain and have no + -- `sorryAx` dependency. + { root := ``Ix.Tc.Methods.CallDomain.empty_within, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.Methods.CallDomain.singletonInfer_within, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.Methods.methodsOut_wfAtOn, + standardAxioms := standard, nativeAxioms := blake3Native, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.Methods.CallScheduleAt.methodsN, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.Methods.CallScheduleAt.nextSelected, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.RecursiveMethodRunContext, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.TcM.whnf.wf, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.TcM.infer.wf, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.TcM.isDefEq.wf, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.Methods.SortSchedule.two, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.TcM.infer.sort_wf_bounded, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.TcM.infer.sort_wf_fuel_one, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + + -- K3 reconstructs the typed source translation from untyped/scoped + -- checker ingress. These roots are usable before the final checkConst + -- assembly and do not depend on its statement placeholder. + { root := ``Ix.Tc.KUniv.scoped_iff_toVLevel_wf, + standardAxioms := propextOnly, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.PreTrKExprS.upgradeOfTyped, + standardAxioms := standard, + sorryOrigins := typingDebt, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.TrKExprS.openFVarZero, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Lean4Lean.VExpr.inst_subst_cons, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RawCtxInterp.find?_inl, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RawCtxInterp.bvars_eq, + standardAxioms := propextOnly, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RawProjRel.none_substCompatible, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RawExprRel.toPre_of_scoped_aux, + standardAxioms := standard, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RawExprRel.toPre_of_scoped, + standardAxioms := standard, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RawDeclRel.toPre_of_scope, + standardAxioms := standard, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.PendingDecl.toPre_of_scope, + standardAxioms := standard, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.TypeCheckEvidence.isType, + standardAxioms := standard, + sorryOrigins := typingDebt, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.ValueCheckEvidence.hasType, + standardAxioms := standard, + sorryOrigins := typingDebt, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.StandaloneCheckEvidence.accepted, + standardAxioms := standard, + sorryOrigins := typingDebt, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.StandaloneCheckResult.accepted, + standardAxioms := standard, + sorryOrigins := typingDebt, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RawDeclRel.wfOfAccepted, + standardAxioms := standard, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.PendingDecl.promoteOfAccepted, + standardAxioms := standard, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.PendingDecl.checkResultAndPromote, + standardAxioms := standard, + sorryOrigins := typingDebt, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.validateUnivParamsSeen_go_sound, + standardAxioms := standard, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.validateUnivParamsSeen_sound, + standardAxioms := standard, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.validateUnivRootsList_sound, + standardAxioms := standard, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.validateUnivRootsArray_sound, + standardAxioms := standard, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.validateExprWellScoped_go_sound, + standardAxioms := standard, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.validateExprWellScoped_sound, + standardAxioms := standard, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.validateConstWellScoped_sound, + standardAxioms := standard, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.PendingDecl.toPre_of_validation, + standardAxioms := standard, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.PendingDecl.checkValidatedResultAndPromote, + standardAxioms := standard, + sorryOrigins := typingDebt, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.validateUnivParamsSeen_go_frame, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.validateUnivParamsSeen_frame, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.validateUnivRootsList_frame, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.validateUnivRootsArray_frame, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.TcM.getConst_frame, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.TcM.hasConst_frame, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.validateExprWellScoped_go_frame, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.validateExprWellScoped_frame, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.validateConstWellScoped_frame, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.TcM.LazyFaultPreserves.withInferOnly, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.checkTypePipeline_sound, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt.push trProjSorry, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.checkValuePipeline_sound, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt.push trProjSorry, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.Methods.FullInferenceWFAtOn.ofTypedIngress, + standardAxioms := standard, nativeAxioms := blake3Native, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.Methods.FullInferenceWFAtOn.ofSingletonSort, + standardAxioms := standard, nativeAxioms := blake3Native, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.StandalonePipelineResources.singletonSortAxiom, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.RecM.checkTypePipeline_bounded_sound, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.RecM.checkValuePipeline_bounded_sound, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.RecM.checkConstMember_axiom_sound, + standardAxioms := standard, nativeAxioms := inductiveNative, + sorryOrigins := typingDebt, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.RecM.checkConstMember_defn_sound, + standardAxioms := standard, nativeAxioms := inductiveNative, + sorryOrigins := typingDebt, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.RecM.checkConstMember_sound, + standardAxioms := standard, nativeAxioms := inductiveNative, + sorryOrigins := typingDebt, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.RecM.checkConstMember_validation_success, + standardAxioms := standard, nativeAxioms := inductiveNative, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.checkConstMember_pending_sound, + standardAxioms := standard, nativeAxioms := inductiveNative, + sorryOrigins := typingDebt, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.RecM.checkConstMemberFresh_pending_sound, + standardAxioms := standard, nativeAxioms := inductiveNative, + sorryOrigins := typingDebt, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.StandaloneRoute.axiomRoute, + standardAxioms := standard, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.checkConst_standalone_pending_sound, + standardAxioms := standard, nativeAxioms := inductiveNative, + sorryOrigins := typingDebt, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.RecM.checkNoUnsafeRefs_go_frame, + standardAxioms := standard, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.checkNoUnsafeRefs_frame, + standardAxioms := standard, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.KernelStateWF.rebaseWorld, + standardAxioms := standard, nativeAxioms := blake3Native, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.WhnfStateInv.rebaseWorld, + standardAxioms := standard, nativeAxioms := blake3Native, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.TcM.reset_whnf_entry, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.FullInferPost.of_typed, + standardAxioms := standard, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.TcM.WF.withInv, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.inferWith_fullHit_pre_acceptance, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.inferUncached_sort_full_wf, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.inferUncached_var_full_wf, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.inferUncached_fvar_full_wf, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.inferUncached_const_full_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.inferUncached_nat_full_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[trProjSorry], + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.inferUncached_str_full_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := #[trProjSorry], + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.FullInferenceStepContext, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.inferUncached_app_full_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.TcM.PreservesInferOnly.strengthenWFValue, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.TcM.PreservesInferOnly.withInferOnly, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.TcM.PreservesInferOnly.openBinder, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.TcM.PreservesInferOnly.inferKey, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.cacheInferResult_preservesInferOnly, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.withLctxScope_preservesInferOnly, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.ensureForallDirect_preservesInferOnly, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.ensureSortDirect_preservesInferOnly, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.Methods.methodsOut_preservesInferOnly, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.Methods.methodsN_preservesInferOnly, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.Methods.PreservesInferOnly.isDefEq_full_wf, + standardAxioms := standard, nativeAxioms := blake3Native, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.TcM.openBinder_scope_base, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.TcM.openBinder_pre_scope, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.KExpr.abstractFVarsSpec_instantiateRevSpec_singleton, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.TrKExprS.closeOpenedFVarZero, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.withLctxScope_openBinder_pre_wf, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.inferUncached_lam_full_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.inferUncached_all_full_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.TcM.openLet_scope_base, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.TcM.openLet_pre_scope, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.withLctxScope_openLet_pre_wf, + standardAxioms := standard, nativeAxioms := expressionNative, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.inferUncached_let_full_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.ProjectionInference.FullWFAt.of_semantic_and_policy, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.inferUncached_prj_full_wf, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.inferUncached_full_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt.push trProjSorry, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.inferWith_full_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt.push trProjSorry, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.infer_full_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt.push trProjSorry, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.TcM.PreservesInferOnly.instantiateUnivParams, + standardAxioms := standard, nativeAxioms := levelNative, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.inferUncached_preservesInferOnly, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.ProjectionInference.preservesInferOnlyAt, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecM.infer_preservesInferOnly_of_whnf, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := k1ForbiddenDependencies }, + + -- K3 closes the concrete operational policy and retains the old strong + -- all-support inference roots below as compatibility artifacts. The + -- public checker now consumes the bounded successor-layer resources above. + { root := ``Ix.Tc.Methods.next_preservesInferOnly, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.Methods.inferOnlyClosed, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.Methods.methodsN_concrete_preservesInferOnly, + standardAxioms := standard, nativeAxioms := inferNative, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.Methods.FullInferenceWFAt, + standardAxioms := standard, nativeAxioms := blake3Native, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecursiveMethodClosureContext.fullInferenceContext, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecursiveMethodClosureContext.next_fullInferenceWFAt, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt.push trProjSorry, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.Methods.methodsOut_fullInferenceWFAt, + standardAxioms := standard, nativeAxioms := blake3Native, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecursiveMethodClosureContext.methodsN_fullInferenceWFAt, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt.push trProjSorry, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.RecursiveMethodClosureContext.publicInfer_full_wf, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt.push trProjSorry, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.TcM.checkConst.rollback_on_error, + standardAxioms := standard, nativeAxioms := inductiveNative, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.TcM.checkConst.rollback_preserves_kernel, + standardAxioms := standard, nativeAxioms := inductiveNative, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.TcM.checkConst.wf, + standardAxioms := standard, nativeAxioms := inductiveNative, + sorryOrigins := typingDebt, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.TcM.checkConst.rejected_of_no_decl_wf, + standardAxioms := standard, nativeAxioms := inductiveNative, + sorryOrigins := typingDebt, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.TcM.checkConst.axiom_pending_sound, + standardAxioms := standard, nativeAxioms := inductiveNative, + sorryOrigins := typingDebt, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.RecM.checkConstMemberFresh_scoped_pending_evidence, + standardAxioms := standard, nativeAxioms := inductiveNative, + sorryOrigins := typingDebt, + forbiddenDependencies := scopedK2SForbiddenDependencies }, + + -- E0 closes the atomic coordinated-block transaction around the real + -- production router, classifier, body, and block-result cache. The + -- singleton-definition adapter consumes K3; inductive/recursor bodies keep + -- their E2 oracle premise explicit. Quotients are audited as excluded from + -- this authority rather than being silently admitted by the block theorem. + { root := ``Ix.Tc.ExactCheckBlock.rebaseWorld, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.RecM.coordinatedBlockIfKind_success_trace, + standardAxioms := standard, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.RecM.classifyBlock_wf, + standardAxioms := standard, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.RecM.coordinatedBlockFor_some_preserves, + standardAxioms := standard, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.CacheInvariant.replayCoordinatedMember, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.CacheInvariant.rejectsSuccessWithUntrustedMember, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.RecM.checkCoordinatedBlock_accepted, + standardAxioms := standard, nativeAxioms := inductiveNative, + sorryOrigins := typingDebt, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.RecM.checkCoordinatedBlock_rejected, + standardAxioms := standard, nativeAxioms := inductiveNative, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.RecM.checkConst_success_disposition, + standardAxioms := standard, nativeAxioms := inductiveNative, + sorryOrigins := typingDebt, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.TcM.checkConst.blockDisposition, + standardAxioms := standard, nativeAxioms := inductiveNative, + sorryOrigins := typingDebt, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.RecM.certifySingletonDefinition, + standardAxioms := standard, nativeAxioms := inductiveNative, + sorryOrigins := typingDebt, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.RecM.certifySingletonDefinitionScoped, + standardAxioms := standard, nativeAxioms := inductiveNative, + sorryOrigins := typingDebt, + forbiddenDependencies := scopedK2SForbiddenDependencies }, + { root := ``Ix.Tc.RecM.certifyOracleBackedBlock, + standardAxioms := standard, nativeAxioms := inductiveNative, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.RecM.coordinatedBlockFor_quotient, + standardAxioms := standard, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.Catalog.quotient_not_coordinated, + standardAxioms := propextOnly, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + -- Quotients remain physically standalone, but semantic admission is one + -- exact four-member Theory transaction followed by the registered quotient + -- equation. These roots expose that atomic target without claiming that + -- the production checker constructs it yet. + { root := ``Ix.Tc.QuotientAdmissionStep.bind, + standardAxioms := standard, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.QuotientAdmissionStep.le, + standardAxioms := standard, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.QuotientBundleAdmission.catalogEntries, + standardAxioms := standard, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.QuotientBundleAdmission.nameAssignments, + standardAxioms := standard, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.QuotientBundleAdmission.toAddQuot, + standardAxioms := standard, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.QuotientBundleAdmission.le, + standardAxioms := standard, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.QuotientBundleAdmission.quotType, + standardAxioms := standard, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.QuotientBundleAdmission.quotCtor, + standardAxioms := standard, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.QuotientBundleAdmission.quotLift, + standardAxioms := standard, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.QuotientBundleAdmission.quotInd, + standardAxioms := standard, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.QuotientBundleAdmission.quotientDefEq, + standardAxioms := standard, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.QuotientAdmission.wf, + standardAxioms := standard, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.QuotientAdmission.le, + standardAxioms := standard, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.AmbientNat.E0.atomicAdmission, + standardAxioms := standard, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.AmbientNat.E0.rejectsPrematureSuccess, + standardAxioms := standard, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + + -- E1 models semantic declaration dependencies in the production Address + -- domain, proves buildAnonWork is an exact duplicate-free partition, and + -- composes successful items in a constructive collapsed-block order. The + -- serial roots recover real successful checkConst calls from the public + -- result array before applying the named C2 success adapter. + { root := ``Ix.Tc.WorkCovers.covered, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.WorkCovers.subjectOfCovered, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.VerifyWorld.AcceptsAddress.mono, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.WorkItemAccepted.mono, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.WorkItemAccepted.acceptsAddress, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.WellFoundedBlocks.noTwoCycle, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.acceptedWorkset_subjectWF, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.IxonEnv.dependencyCatalog_blockOf, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.IxonEnv.dependencyCatalog_dependsOn_iff, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.IxonExpr.DeclReference.target_mem_refs, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.IxonConstant.SemanticDependency.target_mem_refs, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.ExactAnonEntry.getConst, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.ExactAnonEntry.constant_unique, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.ExactAnonEntry.buildAnonWorkItem_eq, + standardAxioms := standard, nativeAxioms := blake3Native, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.AnonWorkEnvWF.buildAnonWork_eq_expected, + standardAxioms := standard, nativeAxioms := blake3Native, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.AnonWorkEnvWF.mem_expectedAnonWork_iff, + standardAxioms := standard, nativeAxioms := blake3Native, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.AnonWorkItem.ofConstantInfo_root, + standardAxioms := standard, nativeAxioms := blake3Native, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.AnonWorkItem.covers_root, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.AnonWorkItem.ofConstantInfo_primary_mem_targets, + standardAxioms := standard, nativeAxioms := blake3Native, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.AnonWorkEnvWF.source_covered, + standardAxioms := standard, nativeAxioms := blake3Native, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.AnonWorkEnvWF.covered_is_source, + standardAxioms := standard, nativeAxioms := blake3Native, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.AnonWorkEnvWF.expected_primary_mem_targets, + standardAxioms := standard, nativeAxioms := blake3Native, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.ExactAnonEntry.blockOfAddr_eq_owner, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.ExactAnonEntry.blockOfAddr_eq_self, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.AnonWorkEnvWF.matches_blockOfAddr, + standardAxioms := standard, nativeAxioms := blake3Native, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.AnonWorkEnvWF.expectedAnonWork_covers, + standardAxioms := standard, nativeAxioms := blake3Native, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.AnonWorkEnvWF.expectedAnonWork_matchesCatalog, + standardAxioms := standard, nativeAxioms := blake3Native, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.AnonWorkEnvWF.buildAnonWork_exact, + standardAxioms := standard, nativeAxioms := blake3Native, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.finishAnonCheckItem_results, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.runAnonCheckItem_preserves_result, + standardAxioms := standard, nativeAxioms := inductiveNative, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.runAnonCheckList_preserves_result, + standardAxioms := standard, nativeAxioms := inductiveNative, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.runAnonCheckItem_error_result, + standardAxioms := standard, nativeAxioms := inductiveNative, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.serialChecksSucceeded_of_results, + standardAxioms := standard, nativeAxioms := inductiveNative, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.SerialChecksSucceeded.successfulStep, + standardAxioms := standard, nativeAxioms := inductiveNative, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.SerialChecksSucceeded.allAccepted, + standardAxioms := standard, nativeAxioms := inductiveNative, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.AnonWorkEnvWF.checkEnvAnon_eq_serial, + standardAxioms := standard, nativeAxioms := inductiveNative, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.AnonWorkEnvWF.checkEnvAnon_subjectWF, + standardAxioms := standard, nativeAxioms := inductiveNative, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.E1Fixture.exactSubjectsAndAssumptions, + standardAxioms := standardWithoutChoice, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.E1Fixture.droppingWorkItem_breaks_coverage, + standardAxioms := propextOnly, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.E1Fixture.unresolvedDependency_breaks_closure, + standardAxioms := propextOnly, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.E1Fixture.cyclicStandalones_not_wellFounded, + standardAxioms := propextOnly, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + + -- E3-S assembles the scoped K3 standalone theorem and E0's exact atomic + -- disposition into E1's concrete-call adapter. The body sum is + -- transparent: singleton definitions use the scoped K3 certificate and + -- inductive/recursor bodies retain an explicit E2 oracle resource. The + -- public SubjectWF root may not pass through any global suffix model. + { root := ``Ix.Tc.SupportedStandaloneResources.promotes, + standardAxioms := standard, nativeAxioms := inductiveNative, + sorryOrigins := typingDebt, + forbiddenDependencies := scopedK2SForbiddenDependencies }, + { root := ``Ix.Tc.SupportedBlockBodyResources.certify, + standardAxioms := standard, nativeAxioms := inductiveNative, + sorryOrigins := typingDebt, + forbiddenDependencies := scopedK2SForbiddenDependencies }, + { root := ``Ix.Tc.SupportedCheckRun.accepts, + standardAxioms := standard, nativeAxioms := inductiveNative, + sorryOrigins := typingDebt, + forbiddenDependencies := scopedK2SForbiddenDependencies }, + { root := ``Ix.Tc.SupportedCheckFragment.checkSuccessSound, + standardAxioms := standard, nativeAxioms := inductiveNative, + sorryOrigins := typingDebt, + forbiddenDependencies := scopedK2SForbiddenDependencies }, + { root := ``Ix.Tc.AnonWorkEnvWF.checkEnvAnon_supported_subjectWF, + standardAxioms := standard, nativeAxioms := inductiveNative, + sorryOrigins := typingDebt, + forbiddenDependencies := scopedK2SForbiddenDependencies }, + { root := ``Ix.Tc.BooleanEnumerationFixture.subjectWF, + standardAxioms := standard, nativeAxioms := booleanDriverNative, + sorryOrigins := typingDebt, + forbiddenDependencies := scopedK2SForbiddenDependencies }, + { root := ``Ix.Tc.BooleanSerialized.subjectWF, + standardAxioms := standard, nativeAxioms := serializedBooleanNative, + sorryOrigins := typingDebt, + forbiddenDependencies := scopedK2SForbiddenDependencies }, + { root := ``Ix.Tc.SerializedLiteralBlobs.literalRoundTrip, + standardAxioms := standard, nativeAxioms := literalRoundTripNative, + forbiddenDependencies := scopedK2SForbiddenDependencies }, + { root := ``Ix.Tc.SerializedLiteralBlobs.malformedConstantRejected, + standardAxioms := standard, nativeAxioms := malformedConstantNative, + forbiddenDependencies := scopedK2SForbiddenDependencies }, + { root := ``Ix.Tc.SerializedLiteralBlobs.malformedBlobRejected, + standardAxioms := standard, nativeAxioms := malformedBlobNative, + forbiddenDependencies := scopedK2SForbiddenDependencies }, + { root := + ``Ix.Tc.SupportedAcceptanceFixture.block_rejects_standalone_route, + standardAxioms := propextOnly, + forbiddenDependencies := scopedK2SForbiddenDependencies }, + { root := ``Ix.Tc.SupportedAcceptanceFixture.block_rejects_wrong_route, + standardAxioms := propextOnly, + forbiddenDependencies := scopedK2SForbiddenDependencies }, + { root := + ``Ix.Tc.SupportedAcceptanceFixture.booleanFamilyBody_certified, + standardAxioms := standard, nativeAxioms := booleanFamilyBodyNative, + sorryOrigins := typingDebt, + forbiddenDependencies := scopedK2SForbiddenDependencies }, + + -- Positive-fuel acceptance witness. The original resource theorem leaves + -- the joint suffix model explicit; the scoped checker roots below construct + -- the finite model from their exact public execution certificate. Two + -- exact Blake3 address inequalities remain explicit fixture inputs. + { root := ``Ix.Tc.PositiveFuelSort.methodContractAtFuelOne, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.PositiveFuelSort.fullInferenceAtFuelOne, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + { root := ``Ix.Tc.PositiveFuelSort.pipelines_cover_concreteAxiom, + standardAxioms := standard, nativeAxioms := inferNative, + sorryOrigins := typingDebt, + forbiddenDependencies := boundedKnotForbiddenDependencies }, + + -- K2S closed-context vertical slice. These roots certify the exact + -- fuel-one public trace, package its finite requests and bounded recursive + -- schedule, instantiate `ScopedKernelSuffixModel.finiteOperational`, and + -- retain `StateInScope` through successful semantic promotion. None may + -- pass through the global suffix-model compatibility path. + { root := ``Ix.Tc.PositiveFuelSort.Checker.model, + standardAxioms := standard, nativeAxioms := contextNative, + forbiddenDependencies := scopedK2SForbiddenDependencies }, + { root := ``Ix.Tc.PositiveFuelSort.Checker.initialState_inv, + standardAxioms := standard, nativeAxioms := nameContextNative, + forbiddenDependencies := scopedK2SForbiddenDependencies }, + { root := ``Ix.Tc.PositiveFuelSort.Checker.inference_run, + standardAxioms := standard, nativeAxioms := nameContextNative, + forbiddenDependencies := scopedK2SForbiddenDependencies }, + { root := ``Ix.Tc.PositiveFuelSort.Checker.public_requests, + standardAxioms := standard, nativeAxioms := inductiveNative, + forbiddenDependencies := scopedK2SForbiddenDependencies }, + { root := ``Ix.Tc.PositiveFuelSort.Checker.runAssumptions, + standardAxioms := standard, nativeAxioms := inductiveNative, + forbiddenDependencies := scopedK2SForbiddenDependencies }, + { root := ``Ix.Tc.PositiveFuelSort.Checker.publicContext, + standardAxioms := standard, nativeAxioms := inductiveNative, + sorryOrigins := typingDebt, + forbiddenDependencies := scopedK2SForbiddenDependencies }, + { root := ``Ix.Tc.PositiveFuelSort.Checker.checked_and_promoted, + standardAxioms := standard, nativeAxioms := inductiveNative, + sorryOrigins := typingDebt, + forbiddenDependencies := scopedK2SForbiddenDependencies }, + + -- The joined ambient-Nat fixture uses the exact semantic pending objects + -- and exact public checker executions for both verdicts. Its valid path + -- carries a concrete acceptance result and promotion; its invalid path + -- returns the malformed-universe error with exact rollback. + { root := ``Ix.Tc.AmbientNat.goodCheckResult, + standardAxioms := standard, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.AmbientNat.initial_good_public, + standardAxioms := standard, nativeAxioms := inductiveNative, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.AmbientNat.reset_bad_public, + standardAxioms := standard, nativeAxioms := inductiveNative, + forbiddenDependencies := k1ForbiddenDependencies }, + { root := ``Ix.Tc.AmbientNat.publicCheckLifecycle, + standardAxioms := standard, nativeAxioms := inductiveNative, forbiddenDependencies := k1ForbiddenDependencies } ] diff --git a/Ix/Tc/Verify/Audit/Statements.lean b/Ix/Tc/Verify/Audit/Statements.lean index cc0d4071c..207fd8393 100644 --- a/Ix/Tc/Verify/Audit/Statements.lean +++ b/Ix/Tc/Verify/Audit/Statements.lean @@ -1,14 +1,18 @@ import Ix.Tc.Verify.Audit.Basic +import Ix.Tc.Verify.Audit.Completed import Ix.Tc.Verify.Statements /-! -# Trust manifest for the temporary checker statement frontier +# Trust manifest for the public checker statement frontier -The four roots in this import context are intentionally still proved with -`sorry`. Their exact direct frontier includes each theorem itself plus the -two upstream inductive-environment assumptions now exposed by G4's concrete -`KernelTcInv`. As proofs land, the corresponding local origin must disappear -and the remaining transitive boundary must still match exactly. +All seven roots are concrete results over the bounded production recursion +schedule and checker. The three recursive-method adapters have no `sorryAx` +dependency; the standalone and atomic-block checker roots retain only the two +named Lean4Lean typing lemmas through their singleton-definition branch. The +E3-S root executes the exact Boolean serial workset and composes those same +transparent K3/E0 resources with E1 and certificate-backed E2 evidence. This +module permits no local statement placeholder and forbids both the legacy +whole-environment route and the unusable all-depth recursive closure. -/ namespace Ix.Tc.Verify.Audit.Statements @@ -18,8 +22,47 @@ open Ix.Tc.Verify.Audit private def standard : Array Lean.Name := #[``propext, ``Classical.choice, ``Quot.sound] -private def inductiveWF : Lean.Name := ``Lean4Lean.VInductDecl.WF -private def addInduct : Lean.Name := ``Lean4Lean.VEnv.addInduct +private def forallEInv : Lean.Name := + ``Lean4Lean.VEnv.IsDefEqU.forallE_inv_stratified +private def sortInv : Lean.Name := ``Lean4Lean.VEnv.IsDefEqU.sort_inv +private def checkerDebt : Array Lean.Name := #[forallEInv, sortInv] + +private def legacyWholeEnv : Array Lean.Name := #[ + ``Ix.Tc.AddKInduct, + ``Ix.Tc.AddKInduct.to_addInduct, + ``Ix.Tc.TrKEnv', + ``Ix.Tc.TrKEnv +] + +private def legacyAllDepthKnot : Array Lean.Name := #[ + ``Ix.Tc.RecursiveMethodClosureContext, + ``Ix.Tc.RecursiveMethodClosureContext.closedAt, + ``Ix.Tc.RecursiveMethodClosureContext.methodsN, + ``Ix.Tc.RecursiveMethodClosureContext.fullInferenceContext, + ``Ix.Tc.RecursiveMethodClosureContext.next_fullInferenceWFAt, + ``Ix.Tc.RecursiveMethodClosureContext.methodsN_fullInferenceWFAt, + ``Ix.Tc.RecursiveMethodClosureContext.publicInfer_full_wf +] + +private def forbidden : Array Lean.Name := + legacyWholeEnv ++ legacyAllDepthKnot + +/- K2S public recursive roots may retain the legacy declarations in the +library, but must not manufacture a global suffix model or pass through the +old proposition-classifier/run-context path. -/ +private def legacyGlobalSuffix : Array Lean.Name := #[ + ``Ix.Tc.KernelSuffixModel, + ``Ix.Tc.ScopedKernelSuffixModel.toKernelSuffixModel, + ``Ix.Tc.PropositionClassifierContext, + ``Ix.Tc.RecursiveMethodRunContext, + ``Ix.Tc.TcM.whnf.wf_legacy, + ``Ix.Tc.TcM.infer.wf_legacy, + ``Ix.Tc.TcM.isDefEq.wf_legacy, + ``Ix.Tc.TcM.checkConst.wf_legacy +] + +private def scopedForbidden : Array Lean.Name := + forbidden ++ legacyGlobalSuffix private def runNative : Array Lean.Name := #[ nativeAxiom `Blake3 @@ -44,23 +87,39 @@ private def checkConstNative : Array Lean.Name := #[ nativeAxiom `Ix.Environment `Ix.Name.mkStr._native.native_decide.ax_1, nativeAxiom `Ix.Tc.Inductive - `Ix.Tc.RecM.canonicalAuxOrder._native.native_decide.ax_17 + `Ix.Tc.RecM.canonicalAuxOrder._native.native_decide.ax_15 ] private def roots : Array RootAllowance := #[ { root := ``Ix.Tc.TcM.whnf.wf, standardAxioms := standard, nativeAxioms := runNative, - sorryOrigins := #[inductiveWF, addInduct, ``Ix.Tc.TcM.whnf.wf] }, + forbiddenDependencies := scopedForbidden }, { root := ``Ix.Tc.TcM.infer.wf, standardAxioms := standard, nativeAxioms := runNative, - sorryOrigins := #[inductiveWF, addInduct, ``Ix.Tc.TcM.infer.wf] }, + forbiddenDependencies := scopedForbidden }, { root := ``Ix.Tc.TcM.isDefEq.wf, standardAxioms := standard, nativeAxioms := runNative, - sorryOrigins := #[inductiveWF, addInduct, ``Ix.Tc.TcM.isDefEq.wf] }, + forbiddenDependencies := scopedForbidden }, { root := ``Ix.Tc.TcM.checkConst.wf, standardAxioms := standard, nativeAxioms := checkConstNative, - sorryOrigins := #[inductiveWF, addInduct, ``Ix.Tc.TcM.checkConst.wf] } + sorryOrigins := checkerDebt, + forbiddenDependencies := scopedForbidden }, + { root := ``Ix.Tc.TcM.checkConst.blockDisposition, + standardAxioms := standard, + nativeAxioms := checkConstNative, + sorryOrigins := checkerDebt, + forbiddenDependencies := scopedForbidden }, + { root := ``Ix.Tc.BooleanEnumerationFixture.subjectWF, + standardAxioms := standard, + nativeAxioms := Ix.Tc.Verify.Audit.Completed.booleanDriverNative, + sorryOrigins := checkerDebt, + forbiddenDependencies := scopedForbidden }, + { root := ``Ix.Tc.BooleanSerialized.subjectWF, + standardAxioms := standard, + nativeAxioms := Ix.Tc.Verify.Audit.Completed.serializedBooleanNative, + sorryOrigins := checkerDebt, + forbiddenDependencies := scopedForbidden } ] run_cmd Ix.Tc.Verify.Audit.check roots diff --git a/Ix/Tc/Verify/Cache.lean b/Ix/Tc/Verify/Cache.lean index e44941e20..74386e089 100644 --- a/Ix/Tc/Verify/Cache.lean +++ b/Ix/Tc/Verify/Cache.lean @@ -260,9 +260,17 @@ theorem SourceReferences.mono {small large : RunSupport} obtain ⟨e, he, ha, href⟩ := h exact ⟨e, hle.1 e he, ha, href⟩ -/-- Direct constant roots on which an entry can depend. Trusted constants' -own bodies are justified by their trusted-world provenance, so this records -roots rather than an unbounded syntactic transitive closure. -/ +/-- Direct *declaration* roots on which an entry can depend. Trusted +constants' own bodies are justified by their trusted-world provenance, so +this records roots rather than an unbounded syntactic transitive closure. + +Physical block keys are deliberately not declaration roots. They identify +entries in `KEnv.blocks`, but anonymous Muts addresses are not `KConst` +members and are never promoted into `VerifyWorld.trusted`. The semantic +validity predicate for the structural cache families must relate such a key +to its exact `VerifyWorld.blocks` member array instead. Treating the key as a +`KId` dependency would make every real inductive-block post-state +uninhabitable, even after all of its declarations were admitted. -/ def References (support : RunSupport) : CacheEntry → KId .anon → Prop | .expr _ key value, id => SourceReferences support key.1 id ∨ value.References id @@ -274,14 +282,13 @@ def References (support : RunSupport) : CacheEntry → KId .anon → Prop | .natSuccStuck key, id | .isProp key _, id => SourceReferences support key.1 id | .isRec ind _, id => id.addr = ind - | .recursor block generated, id => - id = block ∨ ∃ g ∈ generated, + | .recursor _ generated, id => + ∃ g ∈ generated, id.addr = g.indAddr ∨ g.ty.References id ∨ ∃ rule ∈ g.rules, rule.rhs.References id - | .recMajors majors block, id => id ∈ majors ∨ id = block - | .blockPeer block, id => id = block - | .blockResult block (.ok ()), id => id = block - | .blockResult _ (.error _), _ => False + | .recMajors majors _, id => id ∈ majors + | .blockPeer _, _ => False + | .blockResult _ _, _ => False theorem References.mono {small large : RunSupport} (hle : small ≤ large) {entry : CacheEntry} {id : KId .anon} (h : entry.References small id) : @@ -297,10 +304,7 @@ theorem References.mono {small large : RunSupport} (hle : small ≤ large) | natSuccStuck key | isProp key value => exact SourceReferences.mono hle h | isRec | recursor | recMajors | blockPeer => exact h - | blockResult block value => - cases value with - | ok => exact h - | error => exact False.elim h + | blockResult => exact False.elim h end CacheEntry @@ -373,17 +377,42 @@ structure CacheSemantics where blockError : ∀ (authority : CacheAuthority) (support : RunSupport) (block : KId .anon) (err : TcError .anon), Valid authority support (.blockResult block (.error err)) + /-- Once the exact catalogued member array is trusted, a successful block + verdict is a valid stable cache entry. -/ + blockSuccess : ∀ (authority : CacheAuthority) (support : RunSupport) + (block : KId .anon), authority.world.AcceptedBlock block → + Valid authority support (.blockResult block (.ok ())) + /-- Conversely, no cache semantics may accept a successful block verdict + without proving that every member of the exact immutable block is trusted. -/ + blockSuccessSound : ∀ (authority : CacheAuthority) (support : RunSupport) + (block : KId .anon), + Valid authority support (.blockResult block (.ok ())) → + authority.world.AcceptedBlock block /-- The vacuous contract accepting every entry. It carries no semantic content; it is the default witness that lets statement-level `CacheSemantics` stubs be declared `opaque`. -/ instance : Inhabited CacheSemantics := - ⟨{ Valid := fun _ _ _ => True - mono := fun _ h => h + ⟨{ Valid := fun authority _ entry => + match entry with + | .blockResult block (.ok ()) => authority.world.AcceptedBlock block + | _ => True + mono := by + intro before after support entry hle h + cases entry with + | blockResult block result => + cases result with + | ok value => + cases value + exact h.mono hle.world + | error => trivial + | _ => trivial Equiv := fun _ _ => Eq equivEquivalence := fun _ _ => ⟨fun _ => rfl, Eq.symm, Eq.trans⟩ equivMono := fun _ h => h - blockError := fun _ _ _ _ => trivial }⟩ + blockError := fun _ _ _ _ => trivial + blockSuccess := fun _ _ _ h => h + blockSuccessSound := fun _ _ _ h => h }⟩ /-- Full ghost certificate attached to one physical entry. -/ structure CacheProvenance (semantics : CacheSemantics) @@ -405,6 +434,18 @@ theorem blockError (semantics : CacheSemantics) (authority : CacheAuthority) intro id href exact False.elim href +/-- Build complete provenance for a successful coordinated-block verdict. +Its semantic dependency is the exact immutable member array, not the block +address as a synthetic declaration reference. -/ +theorem blockSuccess (semantics : CacheSemantics) + (authority : CacheAuthority) (support : RunSupport) + (block : KId .anon) (haccepted : authority.world.AcceptedBlock block) : + CacheProvenance semantics authority support + (.blockResult block (.ok ())) := by + refine ⟨trivial, ?_, semantics.blockSuccess authority support block haccepted⟩ + 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. @@ -564,6 +605,31 @@ theorem hit {semantics : CacheSemantics} {authority : CacheAuthority} CacheProvenance semantics authority support entry := h hhit +/-- A physical cached success can only replay an already accepted exact +block. This is the stable-cache no-overclaim theorem: validity cannot be +manufactured merely from the presence of a block key. -/ +theorem acceptedBlock_of_success_hit + {semantics : CacheSemantics} {authority : CacheAuthority} + {support : RunSupport} {env : KEnv .anon} {block : KId .anon} + (h : CacheInvariant semantics authority support env) + (hhit : env.blockCheckResults[block]? = some (.ok ())) : + authority.world.AcceptedBlock block := by + have hp := h (.blockResult hhit) + exact semantics.blockSuccessSound authority support block hp.valid + +/-- Replaying a successful block result certifies each member of the one +exact array committed for that block. -/ +theorem trusted_of_success_hit + {semantics : CacheSemantics} {authority : CacheAuthority} + {support : RunSupport} {env : KEnv .anon} {block id : KId .anon} + {members : Array (KId .anon)} + (h : CacheInvariant semantics authority support env) + (hhit : env.blockCheckResults[block]? = some (.ok ())) + (hblock : authority.world.blocks block = some members) + (hid : id ∈ members) : authority.world.trusted id := + VerifyWorld.AcceptedBlock.trusted + (h.acceptedBlock_of_success_hit hhit) hblock hid + /-- Warm entries transport when the trusted world grows. -/ theorem mono {semantics : CacheSemantics} {before after : CacheAuthority} {support : RunSupport} @@ -604,6 +670,74 @@ theorem update {semantics : CacheSemantics} · exact hnew · exact hbefore hold +/-- Insert one certified coordinated-block verdict while retaining every +other cache family. This is the physical update performed by `checkConst` +after `checkBlockBody` returns or throws. -/ +theorem insertBlockResult {semantics : CacheSemantics} + {authority : CacheAuthority} {support : RunSupport} + {env : KEnv .anon} {block : KId .anon} + {result : Except (TcError .anon) Unit} + (hbefore : CacheInvariant semantics authority support env) + (hnew : CacheProvenance semantics authority support + (.blockResult block result)) : + CacheInvariant semantics authority support + { env with blockCheckResults := + env.blockCheckResults.insert block result } := 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 hget => exact .inr (.isRec hget) + | recursor hget => exact .inr (.recursor hget) + | recMajors hget => exact .inr (.recMajors hget) + | blockPeer hmem => exact .inr (.blockPeer hmem) + | @blockResult foundBlock foundResult hget => + rw [Std.HashMap.getElem?_insert] at hget + split at hget + · next heq => + cases hget + have hblock : block = foundBlock := eq_of_beq heq + subst foundBlock + exact .inl rfl + · exact .inr (.blockResult hget) + +/-- A successful verdict may be inserted only after every member of the +exact immutable block has become trusted. -/ +theorem insertBlockSuccess {semantics : CacheSemantics} + {authority : CacheAuthority} {support : RunSupport} + {env : KEnv .anon} {block : KId .anon} + (hbefore : CacheInvariant semantics authority support env) + (haccepted : authority.world.AcceptedBlock block) : + CacheInvariant semantics authority support + { env with blockCheckResults := + env.blockCheckResults.insert block (.ok ()) } := + insertBlockResult hbefore + (CacheProvenance.blockSuccess semantics authority support block haccepted) + +/-- A failed verdict carries no acceptance claim and is always safe to +insert, including on partial-error states retained by `EStateM`. -/ +theorem insertBlockError {semantics : CacheSemantics} + {authority : CacheAuthority} {support : RunSupport} + {env : KEnv .anon} {block : KId .anon} {err : TcError .anon} + (hbefore : CacheInvariant semantics authority support env) : + CacheInvariant semantics authority support + { env with blockCheckResults := + env.blockCheckResults.insert block (.error err) } := + insertBlockResult hbefore + (CacheProvenance.blockError semantics authority support block err) + /-- Insert one certified full-whnf result while retaining provenance for all old entries. The four policy-specific siblings below cover every other K1 WHNF expression map; their exact semantic payload is supplied by diff --git a/Ix/Tc/Verify/Check/Acceptance.lean b/Ix/Tc/Verify/Check/Acceptance.lean new file mode 100644 index 000000000..42419a804 --- /dev/null +++ b/Ix/Tc/Verify/Check/Acceptance.lean @@ -0,0 +1,261 @@ +import Ix.Tc.Verify.Check.DeclarationValidation +import Ix.Tc.Verify.Infer.SortTypes +import Ix.Tc.Verify.State + +/-! +# Standalone declaration acceptance and promotion + +The operational checker should produce only the typing fact which differs by +declaration kind. Fresh installation and trusted-world promotion are then +pure consequences of the existing pending-declaration model. + +This keeps K3's critical implication explicit: + +* an axiom is accepted only when its declared type is a Theory type; +* a definition, opaque definition, or theorem is accepted only when its + value has its declared Theory type. + +No field below assumes a `VDecl.WF` transition. +-/ + +namespace Ix.Tc + +open Lean4Lean (VConstant VDecl VDefVal VEnv VExpr) + +/-! ## Semantic results of the two checker pipelines -/ + +/-- Evidence retained after the production `infer type; ensureSortDirect` +pipeline. The inferred kernel type and its structural translation are kept +explicit so the two operational calls have to agree on the same witness. -/ +def TypeCheckEvidence (trProj : RawProjRel) (world : VerifyWorld) + (support : RunSupport) (uvars : Nat) (Delta : KVLCtx) + (sourceV : VExpr) : Prop := + ∃ inferred : KExpr .anon, ∃ inferredV : VExpr, + TrKExpr world.venv uvars world.nameOf trProj Delta inferred inferredV ∧ + world.venv.HasType uvars Delta.toCtx sourceV inferredV ∧ + ∃ sort : KUniv .anon, + SortView world support uvars Delta inferredV sort + +namespace TypeCheckEvidence + +/-- Successful inference followed by successful sort exposure proves that +the checked source is a Theory type. -/ +theorem isType + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {sourceV : VExpr} + (hDelta : KVLCtx.WF world.venv uvars Delta) + (h : TypeCheckEvidence trProj world support uvars Delta sourceV) : + world.venv.IsType uvars Delta.toCtx sourceV := by + obtain ⟨_, _, _, hsourceType, sort, hsort⟩ := h + exact ⟨sort.toVLevel, + hsourceType.defeqU_r world.venvWF hDelta.toCtx hsort.inputEq⟩ + +end TypeCheckEvidence + +/-- Evidence retained after inferring a definition value and accepting the +production `isDefEq inferredType declaredType` comparison. -/ +def ValueCheckEvidence (world : VerifyWorld) (uvars : Nat) + (Delta : KVLCtx) (valueV declaredTypeV : VExpr) : Prop := + ∃ inferredTypeV : VExpr, + world.venv.HasType uvars Delta.toCtx valueV inferredTypeV ∧ + world.venv.IsDefEqU uvars Delta.toCtx inferredTypeV declaredTypeV + +namespace ValueCheckEvidence + +/-- A true definitional-equality result transports the inferred value type +to the declaration's advertised type. -/ +theorem hasType + {world : VerifyWorld} {uvars : Nat} {Delta : KVLCtx} + {valueV declaredTypeV : VExpr} + (hDelta : KVLCtx.WF world.venv uvars Delta) + (h : ValueCheckEvidence world uvars Delta valueV declaredTypeV) : + world.venv.HasType uvars Delta.toCtx valueV declaredTypeV := + let ⟨_, hvalueType, heq⟩ := h + hvalueType.defeqU_r world.venvWF hDelta.toCtx heq + +end ValueCheckEvidence + +/-- The declaration-local semantic fact established by successful checking, +before freshness is used to install it in a new Theory environment. -/ +def StandaloneAccepted (env : VEnv) : VDecl → Prop + | .axiom ci => ci.toVConstant.WF env + | .def ci | .opaque ci => ci.WF env + | .block _ | .example _ | .quot | .induct _ => False + +/-- The semantic evidence retained from the two production checker paths. +The type-check result is recorded for definitions as well as axioms because +`checkConstMember` checks the advertised type before checking the value. +Only the value-check result is needed by Theory's `VDefVal.WF`; keeping both +premises makes the operational acceptance boundary exact. -/ +inductive StandaloneCheckEvidence (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) : VDecl → Prop + | axiom {ci : Lean4Lean.VConstVal} : + TypeCheckEvidence trProj world support ci.uvars [] ci.type → + StandaloneCheckEvidence trProj world support (.axiom ci) + | defn {ci : Lean4Lean.VDefVal} : + TypeCheckEvidence trProj world support ci.uvars [] ci.type → + ValueCheckEvidence world ci.uvars [] ci.value ci.type → + StandaloneCheckEvidence trProj world support (.def ci) + | opaque {ci : Lean4Lean.VDefVal} : + TypeCheckEvidence trProj world support ci.uvars [] ci.type → + ValueCheckEvidence world ci.uvars [] ci.value ci.type → + StandaloneCheckEvidence trProj world support (.opaque ci) + +namespace StandaloneCheckEvidence + +/-- The exact successful checker evidence implies the declaration-local +Theory acceptance fact. The empty translation context is well formed by +definition, so no ambient typing assumption enters this implication. -/ +theorem accepted + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {decl : VDecl} + (h : StandaloneCheckEvidence trProj world support decl) : + StandaloneAccepted world.venv decl := by + cases h with + | «axiom» htype => + exact TypeCheckEvidence.isType (by trivial) htype + | defn _ hvalue => + exact ValueCheckEvidence.hasType (by trivial) hvalue + | «opaque» _ hvalue => + exact ValueCheckEvidence.hasType (by trivial) hvalue + +end StandaloneCheckEvidence + +/-- The complete declaration-local result expected from K3: a validated raw +declaration has an exact untyped Theory translation, and the checker has +supplied the semantic evidence appropriate to its declaration kind. -/ +structure StandaloneCheckResult (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (id : KId .anon) + (concrete : KConst .anon) (decl : VDecl) : Prop where + ingress : PreDeclRel world.venv world.nameOf trProj id concrete decl + evidence : StandaloneCheckEvidence trProj world support decl + +namespace StandaloneCheckResult + +/-- A complete standalone result is semantically accepted independently of +freshness and promotion. -/ +theorem accepted + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {id : KId .anon} {concrete : KConst .anon} {decl : VDecl} + (h : StandaloneCheckResult trProj world support id concrete decl) : + StandaloneAccepted world.venv decl := + h.evidence.accepted + +end StandaloneCheckResult + +namespace RawDeclRel + +/-- A semantically accepted raw standalone declaration can be installed in +the Theory environment when its pending target name is fresh. -/ +theorem wfOfAccepted + {env : VEnv} {nameOf : Address → Option Lean.Name} + {trProj : RawProjRel} {id : KId .anon} {c : KConst .anon} + {d : VDecl} + (hraw : RawDeclRel env nameOf trProj id c d) + (hfresh : ∀ ⦃name⦄, nameOf id.addr = some name → + env.constants name = none) + (haccepted : StandaloneAccepted env d) : + ∃ env', VDecl.WF env d env' := by + cases hraw with + | @«axiom» nm lps isUnsafe lvls ty name tyV hname hty => + let ci : VConstant := { uvars := lvls.toNat, type := tyV } + let env' : VEnv := + { env with constants := fun candidate => + if name = candidate then some ci + else env.constants candidate } + have hadd : env.addConst name ci = some env' := by + simp [VEnv.addConst, hfresh hname, env', ci] + exact ⟨env', VDecl.WF.axiom (by simpa [ci] using haccepted) hadd⟩ + | @defn nm lps kind safety hints lvls ty val leanAll block name tyV valV d + hname hty hval hkind => + let ci : VDefVal := + { name, uvars := lvls.toNat, type := tyV, value := valV } + let env' : VEnv := + { env with constants := fun candidate => + if name = candidate then some ci.toVConstant + else env.constants candidate } + have hadd : env.addConst name ci.toVConstant = some env' := by + simp [VEnv.addConst, hfresh hname, env', ci] + cases hkind with + | defn => + exact ⟨env'.addDefEq ci.toDefEq, VDecl.WF.def haccepted hadd⟩ + | opaq | thm => exact ⟨env', VDecl.WF.opaque haccepted hadd⟩ + +end RawDeclRel + +namespace PendingDecl + +/-- Acceptance plus the existing pending-state invariant is sufficient for +one exact ghost promotion. The concrete checker state is unchanged. -/ +theorem promoteOfAccepted + {trProj : RawProjRel} {world : VerifyWorld} + {s : TcState .anon} {id : KId .anon} {d : VDecl} + (hstate : TcStateWF trProj s world) + (hpending : PendingDecl trProj world id d) + (haccepted : StandaloneAccepted world.venv d) : + ∃ world', + Promotes world (fun target => target = id) world' ∧ + TcStateWF trProj s world' ∧ + TrustedDecl trProj world' id d := by + obtain ⟨concrete, hcatalog, hraw, huntrusted, hclosed, hfresh⟩ := + hpending + obtain ⟨venv', hwf⟩ := hraw.wfOfAccepted hfresh haccepted + exact hstate.promote + ⟨concrete, hcatalog, hraw, huntrusted, hclosed, hfresh⟩ hwf + +/-- Validator scope, exact raw ingress, and successful checker evidence +assemble into the K3 result and one trusted-world promotion. In particular, +scope alone cannot promote a declaration, and semantic evidence alone cannot +choose a translation for the concrete Ix syntax. -/ +theorem checkResultAndPromote + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {s : TcState .anon} {id : KId .anon} {decl : VDecl} + {concrete : KConst .anon} + (hstate : TcStateWF trProj s world) + (hprojection : trProj.SubstCompatible) + (hliterals : ∀ literal, world.venv.ContainsLits literal) + (hpending : PendingDecl trProj world id decl) + (hcatalog : world.catalog id = some concrete) + (hscope : StandaloneScope concrete) + (hevidence : StandaloneCheckEvidence trProj world support decl) : + StandaloneCheckResult trProj world support id concrete decl ∧ + ∃ world', + Promotes world (fun target => target = id) world' ∧ + TcStateWF trProj s world' ∧ + TrustedDecl trProj world' id decl := by + have hingress := hpending.toPre_of_scope + hprojection hliterals hcatalog hscope + exact ⟨⟨hingress, hevidence⟩, + promoteOfAccepted hstate hpending hevidence.accepted⟩ + +/-- End-to-end K3 assembly at the standalone validation boundary. The exact +production validator supplies raw scoping, while checker evidence supplies +semantic acceptance; together they produce the pre-translation result and a +fresh trusted-world promotion. -/ +theorem checkValidatedResultAndPromote + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {s after : TcState .anon} {id : KId .anon} {decl : VDecl} + {concrete : KConst .anon} + (hstate : TcStateWF trProj s world) + (hprojection : trProj.SubstCompatible) + (hliterals : ∀ literal, world.venv.ContainsLits literal) + (hpending : PendingDecl trProj world id decl) + (hcatalog : world.catalog id = some concrete) + (hresources : StandaloneValidationResources support concrete) + (hcollision : support.CollisionFree) + {methods : Methods .anon} + (hvalidation : + (RecM.validateConstWellScoped concrete).run methods s = .ok () after) + (hevidence : StandaloneCheckEvidence trProj world support decl) : + StandaloneCheckResult trProj world support id concrete decl ∧ + ∃ world', + Promotes world (fun target => target = id) world' ∧ + TcStateWF trProj s world' ∧ + TrustedDecl trProj world' id decl := + checkResultAndPromote hstate hprojection hliterals hpending hcatalog + (RecM.validateConstWellScoped_sound hresources hcollision hvalidation) + hevidence + +end PendingDecl + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/BinderRoundTrip.lean b/Ix/Tc/Verify/Check/BinderRoundTrip.lean new file mode 100644 index 000000000..4321a91af --- /dev/null +++ b/Ix/Tc/Verify/Check/BinderRoundTrip.lean @@ -0,0 +1,242 @@ +import Ix.Tc.Verify.Check.PreTranslationScopes +import Ix.Tc.Verify.Infer.BinderClosing + +/-! +# Binder open/close round trip + +The Lean4Lean checker closes a freshly opened binder with +`FVarsIn.abstract_instantiate1`. Ix uses address-carrying `KExpr` smart +constructors and separate cached walkers, so K3 needs the corresponding pure +syntax theorem for `instantiateRevSpec` followed by singleton +`abstractFVarsSpec`. +-/ + +namespace Ix.Tc + +namespace KExpr + +/-- One selected free-variable id does not occur in an expression. -/ +def FVarAbsent (target : FVarId) : KExpr .anon → Prop + | .fvar id _ _ => id ≠ target + | .app fn arg _ => fn.FVarAbsent target ∧ arg.FVarAbsent target + | .lam _ _ type body _ | .all _ _ type body _ => + type.FVarAbsent target ∧ body.FVarAbsent target + | .letE _ type value body _ _ => + type.FVarAbsent target ∧ value.FVarAbsent target ∧ + body.FVarAbsent target + | .prj _ _ value _ => value.FVarAbsent target + | _ => True + +end KExpr + +namespace PreTrKExprS + +/-- A pre-translation can mention only fvars registered by its `KVLCtx`. -/ +theorem fvarAbsent + {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address → Option Lean.Name} {trProj : RawProjRel} + {Delta : KVLCtx} {source : KExpr .anon} {sourceV : Lean4Lean.VExpr} + (hsource : PreTrKExprS env uvars nameOf trProj Delta source sourceV) + {target : FVarId} (hfresh : target ∉ Delta.fvars) : + source.FVarAbsent target := by + induction hsource with + | var => trivial + | fvar hfind => + intro heq + subst target + exact hfresh (KVLCtx.find?_inr_mem hfind) + | sort => trivial + | const => trivial + | app _ _ ihfn iharg => exact ⟨ihfn hfresh, iharg hfresh⟩ + | lam _ _ ihtype ihbody => + exact ⟨ihtype hfresh, ihbody (by simpa using hfresh)⟩ + | all _ _ ihtype ihbody => + exact ⟨ihtype hfresh, ihbody (by simpa using hfresh)⟩ + | letE _ _ _ ihtype ihvalue ihbody => + exact ⟨ihtype hfresh, ihvalue hfresh, + ihbody (by simpa using hfresh)⟩ + | prj _ _ _ ihvalue => exact ihvalue hfresh + | nat => trivial + | str => trivial + +end PreTrKExprS + +namespace KExpr + +/-- Opening one de Bruijn binder with a fresh fvar and immediately +abstracting that exact fvar reconstructs the original constructed `KExpr`. +The bound is a deliberately simple joint no-wrap condition for both walkers. +-/ +theorem abstractFVarsSpec_instantiateRevSpec_singleton + {body : KExpr .anon} {fv : FVarId} {name : Mode.anon.F Name} + {depth : UInt64} + (hcon : Constructed body) + (hfresh : body.FVarAbsent fv) + (hbig : depth.toNat + body.size + 1 < UInt64.size) : + abstractFVarsSpec + (instantiateRevSpec body #[.mkFVar fv name] depth) + (abstractFVarPositions #[fv]) 1 depth = body := by + induction hcon generalizing depth with + | @var idx varName info hidx => + 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 [mkVar_shape, instantiateRevSpec] + have hsize : #[KExpr.mkFVar fv name].size.toUInt64 = 1 := rfl + rw [hsize] + by_cases heq : idx = depth + · subst idx + have hlt : depth < depth + 1 := + UInt64.lt_iff_toNat_lt.mpr (by rw [hsucc]; omega) + have hwindow : + ((depth ≥ depth && depth < depth + 1) = true) := by + simp [hlt] + rw [if_pos hwindow] + have hindex : (1 - 1 - (depth - depth)).toNat = 0 := by simp + rw [hindex, getElem!_pos #[KExpr.mkFVar fv name] 0 (by simp)] + change abstractFVarsSpec (KExpr.mkFVar fv name) + (abstractFVarPositions #[fv]) 1 depth = mkVar depth varName info + rw [mkFVar_shape, abstractFVarsSpec, + abstractFVarPositions_singleton_hit] + simp only [UInt64.add_zero] + · by_cases hgt : depth < idx + · have hgeSucc : depth + 1 ≤ idx := + UInt64.le_iff_toNat_le.mpr (by + rw [hsucc] + have := UInt64.lt_iff_toNat_lt.mp hgt + omega) + have hnltSucc : ¬idx < depth + 1 := fun hlt => by + have := UInt64.lt_iff_toNat_lt.mp hlt + have := UInt64.le_iff_toNat_le.mp hgeSucc + omega + have hwindow : + ¬((idx ≥ depth && idx < depth + 1) = true) := by + simp [hnltSucc] + have hone : (1 : UInt64) ≤ idx := + UInt64.le_iff_toNat_le.mpr (by + have := UInt64.lt_iff_toNat_lt.mp hgt + simp only [UInt64.toNat_ofNat] + omega) + have honeNat : 1 ≤ idx.toNat := + UInt64.le_iff_toNat_le.mp hone + have hshift : idx - 1 ≥ depth := + UInt64.le_iff_toNat_le.mpr (by + rw [UInt64.toNat_sub_of_le idx 1 hone, + show (1 : UInt64).toNat = 1 from rfl] + have hgeSuccNat := UInt64.le_iff_toNat_le.mp hgeSucc + rw [hsucc] at hgeSuccNat + exact Nat.le_sub_of_add_le + hgeSuccNat) + have hround : idx - 1 + 1 = idx := by + apply UInt64.toNat_inj.mp + rw [UInt64.toNat_add, UInt64.toNat_sub_of_le idx 1 hone, + show (1 : UInt64).toNat = 1 from rfl] + rw [Nat.sub_add_cancel honeNat] + exact Nat.mod_eq_of_lt (Nat.lt_trans (Nat.lt_succ_self _) hidx) + rw [if_neg hwindow, if_pos hgeSucc, mkVar_shape, + abstractFVarsSpec, if_pos hshift, hround] + exact mkVar_shape idx varName info + · have hnge : ¬idx ≥ depth := fun hge => by + have hle := UInt64.le_iff_toNat_le.mp hge + have hne : idx.toNat ≠ depth.toNat := fun h => + heq (UInt64.toNat_inj.mp h) + exact hgt (UInt64.lt_iff_toNat_lt.mpr (by omega)) + have hwindow : + ¬((idx ≥ depth && idx < depth + 1) = true) := by + simp [hnge] + have hngeSucc : ¬idx ≥ depth + 1 := fun hge => + hnge (UInt64.le_iff_toNat_le.mpr (by + have hgeNat := UInt64.le_iff_toNat_le.mp hge + rw [hsucc] at hgeNat + omega)) + rw [if_neg hwindow, if_neg hngeSucc, abstractFVarsSpec, + if_neg hnge] + | @fvar id fvarName info => + have hne : id ≠ fv := by + rw [mkFVar_shape] at hfresh + exact hfresh + rw [mkFVar_shape] + change (match (abstractFVarPositions #[fv])[id]? with + | some p => mkVar (depth + p) (anonName (m := .anon)) + | none => .fvar id fvarName (mkFVar id fvarName info).info) = _ + rw [abstractFVarPositions_singleton_miss hne] + | sort => rfl + | const => rfl + | @app fn arg info hfn harg ihfn iharg => + rcases hfresh with ⟨hfnFresh, hargFresh⟩ + rw [mkApp_shape, size] at hbig + rw [mkApp_shape, instantiateRevSpec, mkApp_shape, abstractFVarsSpec, + ihfn (depth := depth) hfnFresh (by omega), + iharg (depth := depth) hargFresh (by omega)] + exact mkApp_shape fn arg info + | @lam binderName bi type body info htype hbody ihtype ihbody => + rcases hfresh with ⟨htypeFresh, hbodyFresh⟩ + 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, instantiateRevSpec, mkLam_shape, abstractFVarsSpec, + ihtype (depth := depth) htypeFresh (by omega), + ihbody (depth := depth + 1) hbodyFresh (by rw [hsucc]; omega)] + exact mkLam_shape binderName bi type body info + | @all binderName bi type body info htype hbody ihtype ihbody => + rcases hfresh with ⟨htypeFresh, hbodyFresh⟩ + 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, instantiateRevSpec, mkAll_shape, abstractFVarsSpec, + ihtype (depth := depth) htypeFresh (by omega), + ihbody (depth := depth + 1) hbodyFresh (by rw [hsucc]; omega)] + exact mkAll_shape binderName bi type body info + | @letE binderName type value body nondep info htype hvalue hbody + ihtype ihvalue ihbody => + rcases hfresh with ⟨htypeFresh, hvalueFresh, hbodyFresh⟩ + 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, instantiateRevSpec, mkLet_shape, abstractFVarsSpec, + ihtype (depth := depth) htypeFresh (by omega), + ihvalue (depth := depth) hvalueFresh (by omega), + ihbody (depth := depth + 1) hbodyFresh (by rw [hsucc]; omega)] + exact mkLet_shape binderName type value body nondep info + | @prj id field value info hvalue ihvalue => + rw [mkPrj_shape, size] at hbig + rw [mkPrj_shape, instantiateRevSpec, mkPrj_shape, abstractFVarsSpec, + ihvalue (depth := depth) hfresh (by omega)] + exact mkPrj_shape id field value info + | nat => rfl + | str => rfl + +end KExpr + +/-- Close a successfully inferred opened binder back to its original Ix +syntax. The opening bounds justify the pure round trip; the closing bounds +justify the production abstraction walker whose translation theorem supplies +the typed result. -/ +theorem TrKExprS.closeOpenedFVarZero + {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address → Option Lean.Name} {trProj : RawProjRel} + {Delta : KVLCtx} {decl : Lean4Lean.VLocalDecl} + {body bodyOpen : KExpr .anon} {bodyV : Lean4Lean.VExpr} + {fv : FVarId} {deps : List FVarId} {name : Mode.anon.F Name} + (H : TrKExprS env uvars nameOf trProj + ((some (fv, deps), decl) :: Delta) bodyOpen bodyV) + (hopen : bodyOpen = KExpr.instantiateRevSpec body + #[KExpr.mkFVar fv name] 0) + (hfresh : body.FVarAbsent fv) + (hopenBounds : WalkerRequest.Bounds + (.instRev body #[KExpr.mkFVar fv name])) + (hcloseBounds : WalkerRequest.Bounds + (.abstractFVars bodyOpen #[fv])) : + TrKExprS env uvars nameOf trProj ((none, decl) :: Delta) body bodyV := by + subst bodyOpen + have hclosed := H.closeFVarZero hcloseBounds + have hround := KExpr.abstractFVarsSpec_instantiateRevSpec_singleton + (name := name) (depth := 0) hopenBounds.1 hfresh + (by simpa using hopenBounds.2.2) + rw [hround] at hclosed + exact hclosed + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/BlockAcceptance.lean b/Ix/Tc/Verify/Check/BlockAcceptance.lean new file mode 100644 index 000000000..84796dfdd --- /dev/null +++ b/Ix/Tc/Verify/Check/BlockAcceptance.lean @@ -0,0 +1,262 @@ +import Ix.Tc.Verify.Check.Acceptance +import Ix.Tc.Verify.Check.BlockCache + +/-! +# Atomic coordinated-block acceptance + +The production checker validates a coordinated block before publishing one +cached success verdict. The corresponding ghost transition must therefore +be exact: every immutable member is admitted, no unrelated declaration is +admitted, and the successful cache entry is installed only after temporary +member authority has become stable trust. + +Inductive-family and recursor blocks are admitted here relative to the +explicit `InductiveOracle`. That oracle already describes one Theory-level +block transaction; E2 must derive it from the production inductive checker. +Definition admission is local, but Lean4Lean currently has no mutual- +definition `VDecl`, so the constructive definition theorem below is +deliberately restricted to production's singleton definition blocks. A +multi-definition block is not silently decomposed into independent claims. +-/ + +namespace Ix.Tc + +/-- Exact promotion specialized to the ordered member array of one physical +block. Array order remains available through `ExactCheckBlock`; the trust +delta uses extensional membership. -/ +abbrev ExactBlockPromotion (before : VerifyWorld) + (members : Array (KId .anon)) (after : VerifyWorld) : Prop := + ExactPromotion before (fun id => id ∈ members) after + +/-- The stable semantic result of one atomic coordinated-block transaction. +The immutable identity is stated in the pre-world, while `promotion` fixes +the complete trust delta and `trustedCatalog` records the actual Theory +event log for the post-world. -/ +structure AtomicBlockAdmission (trProj : RawProjRel) + (before after : VerifyWorld) (block : KId .anon) + (members : Array (KId .anon)) (kind : CheckBlockKind) : Prop where + exactBlock : ExactCheckBlock before block members kind + promotion : ExactBlockPromotion before members after + trustedCatalog : TrustedCatalogRel trProj after + +namespace AtomicBlockAdmission + +/-- Exact block identity survives the ghost transaction. -/ +theorem exactAfter {trProj : RawProjRel} {before after : VerifyWorld} + {block : KId .anon} {members : Array (KId .anon)} + {kind : CheckBlockKind} + (h : AtomicBlockAdmission trProj before after block members kind) : + ExactCheckBlock after block members kind := by + refine ⟨?_, h.exactBlock.nonempty, ?_⟩ + · change after.blocks block = some members + rw [← h.promotion.le.blocks] + exact h.exactBlock.blockLookup + · intro id + change id ∈ members ↔ + after.catalog.CoordinatedMember block kind id + rw [← h.promotion.le.catalog] + exact h.exactBlock.memberIff id + +/-- Every member is trusted in the post-world. Consequently no proper +subset can be published as an atomic success. -/ +theorem memberTrusted {trProj : RawProjRel} + {before after : VerifyWorld} {block id : KId .anon} + {members : Array (KId .anon)} {kind : CheckBlockKind} + (h : AtomicBlockAdmission trProj before after block members kind) + (hid : id ∈ members) : after.trusted id := + (h.promotion.trusted_iff id).2 (.inl hid) + +/-- The atomic transaction establishes the stable meaning required by a +successful physical block-cache entry. -/ +theorem accepted {trProj : RawProjRel} {before after : VerifyWorld} + {block : KId .anon} {members : Array (KId .anon)} + {kind : CheckBlockKind} + (h : AtomicBlockAdmission trProj before after block members kind) : + after.AcceptedBlock block := + ⟨members, h.exactAfter.blockLookup, h.exactBlock.nonempty, + fun _ hid => h.memberTrusted hid⟩ + +/-- An identifier newly trusted by this transition must be an exact physical +member; unrelated catalog entries cannot ride along with block acceptance. -/ +theorem newlyTrustedMember {trProj : RawProjRel} + {before after : VerifyWorld} {block id : KId .anon} + {members : Array (KId .anon)} {kind : CheckBlockKind} + (h : AtomicBlockAdmission trProj before after block members kind) + (hafter : after.trusted id) (hbefore : ¬before.trusted id) : + id ∈ members := + h.promotion.newlyTrusted hafter hbefore + +/-- Close the active block-cache phase only after the exact semantic +transaction. This composes atomic admission with the cache ordering theorem +instead of allowing cache success to justify its own acceptance. -/ +theorem closeCacheSuccess + {semantics : CacheSemantics} {support : RunSupport} + {trProj : RawProjRel} {before after : VerifyWorld} + {env : KEnv .anon} {block : KId .anon} + {members : Array (KId .anon)} {kind : CheckBlockKind} + (h : AtomicBlockAdmission trProj before after block members kind) + (hcaches : CacheInvariant semantics + (CacheAuthority.coordinatedBlock before members) support env) : + CacheInvariant semantics (CacheAuthority.stable after) support + { env with blockCheckResults := + env.blockCheckResults.insert block (.ok ()) } := + CacheInvariant.closeExactBlockSuccess hcaches h.promotion.le h.exactAfter + h.accepted + +end AtomicBlockAdmission + +/-! ## Oracle-backed inductive and recursor blocks -/ + +namespace CheckBlockKind + +/-- Kinds whose semantic block transaction is represented by the current +ambient inductive oracle. Definitions use the standalone declaration +transition; quotients never enter coordinated routing. -/ +def OracleBacked : CheckBlockKind → Prop + | .inductive' | .recursor => True + | .defn => False + +end CheckBlockKind + +/-- An oracle tied extensionally to one exact immutable member array. The +kind restriction prevents this ambient inductive boundary from being reused +as a definition checker. -/ +structure OracleBlockCertificate (trProj : RawProjRel) + (world : VerifyWorld) (block : KId .anon) + (members : Array (KId .anon)) (kind : CheckBlockKind) where + oracleBacked : kind.OracleBacked + exactBlock : ExactCheckBlock world block members kind + oracle : InductiveOracle trProj world.catalog world.nameOf world.trusted + world.venv + memberIff : ∀ id, oracle.members id ↔ id ∈ members + +namespace VerifyWorld + +/-- Materialize the one ambient Theory transaction carried by an inductive +oracle while preserving all immutable ghost inputs. -/ +def admitOracle {trProj : RawProjRel} (world : VerifyWorld) + (oracle : InductiveOracle trProj world.catalog world.nameOf world.trusted + world.venv) : VerifyWorld where + catalog := world.catalog + blocks := world.blocks + trusted := oracle.TrustBlock + venv := oracle.after + nameOf := world.nameOf + venvWF := oracle.blockWF + trustedCatalogued := by + intro id htrusted + change oracle.members id ∨ world.trusted id at htrusted + rcases htrusted with hmember | hold + · exact oracle.catalogued hmember + · exact world.trustedCatalogued hold + +/-- Oracle admission is a monotone world extension. -/ +theorem le_admitOracle {trProj : RawProjRel} (world : VerifyWorld) + (oracle : InductiveOracle trProj world.catalog world.nameOf world.trusted + world.venv) : world ≤ world.admitOracle oracle := + ⟨rfl, rfl, rfl, fun {_} hold => oracle.trust_old hold, oracle.envLE⟩ + +end VerifyWorld + +namespace OracleBlockCertificate + +/-- Oracle freshness covers every exact immutable member. -/ +theorem fresh {trProj : RawProjRel} {world : VerifyWorld} + {block : KId .anon} {members : Array (KId .anon)} + {kind : CheckBlockKind} + (certificate : OracleBlockCertificate trProj world block members kind) + {id : KId .anon} (hid : id ∈ members) : ¬world.trusted id := + certificate.oracle.fresh ((certificate.memberIff id).2 hid) + +/-- Commit an oracle-backed block as one exact ghost transaction and one +trusted-log event. This theorem is intentionally semantic: E2 supplies the +future operational proof that a production inductive/recursor block success +constructs this certificate. -/ +theorem admit {trProj : RawProjRel} {world : VerifyWorld} + {block : KId .anon} {members : Array (KId .anon)} + {kind : CheckBlockKind} + (certificate : OracleBlockCertificate trProj world block members kind) + (hrel : TrustedCatalogRel trProj world) : + AtomicBlockAdmission trProj world + (world.admitOracle certificate.oracle) block members kind := by + refine ⟨certificate.exactBlock, ?_, ?_⟩ + · refine ⟨world.le_admitOracle certificate.oracle, ?_⟩ + intro id + change (certificate.oracle.members id ∨ world.trusted id) ↔ + id ∈ members ∨ world.trusted id + rw [certificate.memberIff id] + · exact TrustedCatalogLog.ambient certificate.oracle hrel + +/-- Rebase the concrete/world invariant after the ghost-only atomic oracle +transaction. The concrete environment, including its exact block array, +does not change. -/ +theorem admitState {trProj : RawProjRel} {world : VerifyWorld} + {block : KId .anon} {members : Array (KId .anon)} + {kind : CheckBlockKind} {state : TcState .anon} + (certificate : OracleBlockCertificate trProj world block members kind) + (hstate : BlockStateWF trProj state world) : + let after := world.admitOracle certificate.oracle + AtomicBlockAdmission trProj world after block members kind ∧ + BlockStateWF trProj state after := by + let admission := certificate.admit hstate.core.trustedCatalog + refine ⟨admission, ?_⟩ + apply hstate.rebaseWorld admission.promotion.le + exact + { trustedCatalog := admission.trustedCatalog + loaded := (LoadedAgrees.world_iff admission.promotion.le).mp + hstate.core.loaded + intern := hstate.core.intern } + +end OracleBlockCertificate + +/-! ## Constructive singleton-definition admission -/ + +/-- The currently supported definition-block semantic certificate. Its +singleton shape is explicit: treating a multi-definition block as a sequence +of standalone declarations would be unsound for mutual references until the +Theory exposes a matching atomic declaration form. -/ +structure SingletonDefinitionCertificate (trProj : RawProjRel) + (world : VerifyWorld) (block id : KId .anon) + (decl : Lean4Lean.VDecl) : Prop where + exactBlock : ExactCheckBlock world block #[id] .defn + pending : PendingDecl trProj world id decl + accepted : StandaloneAccepted world.venv decl + +namespace SingletonDefinitionCertificate + +/-- Construct the singleton definition's exact one-declaration Theory +transition. Every accepted member (the singleton) is trusted, and the exact +promotion theorem rules out unrelated trust growth. -/ +theorem admit {trProj : RawProjRel} {world : VerifyWorld} + {block id : KId .anon} {decl : Lean4Lean.VDecl} + {state : TcState .anon} + (certificate : SingletonDefinitionCertificate trProj world block id decl) + (hstate : BlockStateWF trProj state world) : + ∃ after, + AtomicBlockAdmission trProj world after block #[id] .defn ∧ + BlockStateWF trProj state after ∧ + TrustedDecl trProj after id decl := by + obtain ⟨concrete, hcatalog, hraw, huntrusted, hclosed, hfresh⟩ := + certificate.pending + obtain ⟨venv', hwf⟩ := hraw.wfOfAccepted hfresh certificate.accepted + have hpending : PendingDecl trProj world id decl := + ⟨concrete, hcatalog, hraw, huntrusted, hclosed, hfresh⟩ + obtain ⟨after, hpromotion, hrel, hdecl⟩ := + TrustedCatalogRel.promoteExact hstate.core.trustedCatalog hpending hwf + have hblockPromotion : ExactBlockPromotion world #[id] after := by + refine ⟨hpromotion.le, ?_⟩ + intro target + simpa using hpromotion.trusted_iff target + let admission : AtomicBlockAdmission trProj world after block #[id] .defn := + ⟨certificate.exactBlock, hblockPromotion, hrel⟩ + refine ⟨after, admission, ?_, hdecl⟩ + apply hstate.rebaseWorld admission.promotion.le + exact + { trustedCatalog := hrel + loaded := (LoadedAgrees.world_iff admission.promotion.le).mp + hstate.core.loaded + intern := hstate.core.intern } + +end SingletonDefinitionCertificate + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/BlockCache.lean b/Ix/Tc/Verify/Check/BlockCache.lean new file mode 100644 index 000000000..70686182d --- /dev/null +++ b/Ix/Tc/Verify/Check/BlockCache.lean @@ -0,0 +1,113 @@ +import Ix.Tc.Verify.Check.BlockIdentity + +/-! +# Coordinated block-cache closure + +During an atomic block check, structural block caches may refer to members +which are not trusted yet. A successful close must first promote the complete +exact member array, then rebase those active entries to stable authority, and +only then insert `blockCheckResults[block] = .ok ()`. + +The inverse theorem is equally important: replaying a physical cached success +recovers acceptance of the exact immutable block and therefore cannot certify +a proper subset or treat the block address as a declaration. +-/ + +namespace Ix.Tc + +namespace CacheAuthority + +/-- Temporary authority for exactly the members of one atomic block. -/ +def coordinatedBlock (world : VerifyWorld) + (members : Array (KId .anon)) : CacheAuthority where + world := world + active := fun id => id ∈ members + +/-- Once the exact block has been accepted in a larger world, every temporary +member authority becomes ordinary stable trust. -/ +theorem coordinatedBlock_le_stable + {before after : VerifyWorld} {block : KId .anon} + {members : Array (KId .anon)} + (hle : before ≤ after) (hblock : after.blocks block = some members) + (haccepted : after.AcceptedBlock block) : + coordinatedBlock before members ≤ stable after := by + refine ⟨hle, ?_⟩ + intro id hauthorized + rcases hauthorized with htrusted | hmember + · exact .inl (hle.trusted htrusted) + · exact .inl (VerifyWorld.AcceptedBlock.trusted + haccepted hblock hmember) + +end CacheAuthority + +namespace CacheInvariant + +/-- Close the successful atomic-cache phase in the required order: all exact +members are already trusted in `after`, active authority is eliminated, and +the successful block verdict is inserted under stable authority. -/ +theorem closeBlockSuccess + {semantics : CacheSemantics} {support : RunSupport} + {before after : VerifyWorld} {env : KEnv .anon} + {block : KId .anon} {members : Array (KId .anon)} + (hcaches : CacheInvariant semantics + (CacheAuthority.coordinatedBlock before members) support env) + (hle : before ≤ after) (hblock : after.blocks block = some members) + (haccepted : after.AcceptedBlock block) : + CacheInvariant semantics (CacheAuthority.stable after) support + { env with blockCheckResults := + env.blockCheckResults.insert block (.ok ()) } := by + have hauthority : CacheAuthority.coordinatedBlock before members ≤ + CacheAuthority.stable after := + CacheAuthority.coordinatedBlock_le_stable hle hblock haccepted + exact (hcaches.mono hauthority).insertBlockSuccess haccepted + +/-- Exact-block specialization of `closeBlockSuccess`. -/ +theorem closeExactBlockSuccess + {semantics : CacheSemantics} {support : RunSupport} + {before after : VerifyWorld} {env : KEnv .anon} + {block : KId .anon} {members : Array (KId .anon)} + {kind : CheckBlockKind} + (hcaches : CacheInvariant semantics + (CacheAuthority.coordinatedBlock before members) support env) + (hle : before ≤ after) + (hexact : ExactCheckBlock after block members kind) + (haccepted : after.AcceptedBlock block) : + CacheInvariant semantics (CacheAuthority.stable after) support + { env with blockCheckResults := + env.blockCheckResults.insert block (.ok ()) } := + closeBlockSuccess hcaches hle hexact.blockLookup haccepted + +/-- A stable physical success hit covers every catalog declaration owned by +the exact block. This is the member-level replay theorem used by E0. -/ +theorem replayCoordinatedMember + {semantics : CacheSemantics} {support : RunSupport} + {world : VerifyWorld} {env : KEnv .anon} + {block id : KId .anon} {members : Array (KId .anon)} + {kind : CheckBlockKind} + (hcaches : CacheInvariant semantics (CacheAuthority.stable world) + support env) + (hexact : ExactCheckBlock world block members kind) + (hhit : env.blockCheckResults[block]? = some (.ok ())) + (hid : world.catalog.CoordinatedMember block kind id) : + world.trusted id := by + have haccepted := hcaches.acceptedBlock_of_success_hit hhit + exact hexact.coordinated_trusted haccepted hid + +/-- Adversarial corollary: if even one exact member is untrusted, no valid +stable success verdict for that block can exist. -/ +theorem rejectsSuccessWithUntrustedMember + {semantics : CacheSemantics} {support : RunSupport} + {world : VerifyWorld} {block id : KId .anon} + {members : Array (KId .anon)} {kind : CheckBlockKind} + (hexact : ExactCheckBlock world block members kind) + (hid : id ∈ members) (huntrusted : ¬world.trusted id) : + ¬semantics.Valid (CacheAuthority.stable world) support + (.blockResult block (.ok ())) := by + intro hvalid + have haccepted := semantics.blockSuccessSound + (CacheAuthority.stable world) support block hvalid + exact huntrusted (hexact.trusted haccepted hid) + +end CacheInvariant + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/BlockClassification.lean b/Ix/Tc/Verify/Check/BlockClassification.lean new file mode 100644 index 000000000..f5ba46a5d --- /dev/null +++ b/Ix/Tc/Verify/Check/BlockClassification.lean @@ -0,0 +1,215 @@ +import Ix.Tc.Verify.Check.BlockRouting + +/-! +# Coordinated block classification + +Production classifies a block by loading every ordered member, accumulating +three shape flags, and accepting exactly one homogeneous flag. This module +proves that process against `ExactCheckBlock`: every successful lookup is the +immutable catalog entry, the accumulator records the catalogued kind, and a +successful classifier result is exactly that kind. Both success and error +paths preserve the caller's invariant through lazy ingress. +-/ + +namespace Ix.Tc + +namespace RecM.BlockClassFlags + +/-- Proof-side description of recording one member of a known exact kind. -/ +def mark (flags : BlockClassFlags) : CheckBlockKind → BlockClassFlags + | .defn => { flags with sawDefn := true } + | .inductive' => { flags with sawInductiveLike := true } + | .recursor => { flags with sawRecr := true } + +/-- A catalog declaration owned by one coordinated kind makes production's +shape recorder perform exactly the corresponding flag update. -/ +theorem note_of_member + {catalog : Catalog} {block member : KId .anon} + {kind : CheckBlockKind} {concrete : KConst .anon} + (h : concrete.IsMemberOfKind catalog block kind) + (flags : BlockClassFlags) : + flags.note member concrete = .ok (mark flags kind) := by + cases kind <;> cases concrete <;> + simp [KConst.IsMemberOfKind, KConst.IsDefinitionMemberOf, + KConst.IsInductiveMemberOf, KConst.IsRecursorMemberOf, note, mark] + at h ⊢ + +/-- The flag state after observing at least one member of one kind. -/ +def only (kind : CheckBlockKind) : BlockClassFlags := + mark BlockClassFlags.empty kind + +@[simp] theorem mark_only (kind : CheckBlockKind) : + mark (only kind) kind = only kind := by + cases kind <;> rfl + +theorem foldl_mark_only (kind : CheckBlockKind) + (members : List (KId .anon)) : + members.foldl (fun acc _ => mark acc kind) (only kind) = only kind := by + induction members with + | nil => rfl + | cons member rest ih => simpa using ih + +/-- Starting empty and observing a nonempty homogeneous list leaves exactly +one kind flag set. -/ +theorem foldl_mark_empty_of_nonempty (kind : CheckBlockKind) + {members : List (KId .anon)} (h : members ≠ []) : + members.foldl (fun acc _ => mark acc kind) BlockClassFlags.empty = + only kind := by + cases members with + | nil => contradiction + | cons member rest => + simpa [only] using foldl_mark_only kind rest + +@[simp] theorem finish_only (kind : CheckBlockKind) : + BlockClassFlags.finish (m := .anon) (only kind) = .ok kind := by + cases kind <;> rfl + +end RecM.BlockClassFlags + +namespace RecM + +/-- Classification's ordered member scan preserves any invariant preserved +by lazy ingress. This frame theorem deliberately makes no semantic claim +about the resulting flags; exact-kind correctness is proved below. -/ +theorem collectBlockClassFlags_wf + {I : TcState .anon → Prop} {methods : Methods .anon} + (hfault : TcM.LazyFaultPreserves I) + (members : List (KId .anon)) (flags : BlockClassFlags) + (state : TcState .anon) : + TcM.WF I state + ((collectBlockClassFlags members flags).run methods) + (fun _ _ => True) := by + induction members generalizing flags state with + | nil => + simpa [collectBlockClassFlags] using + (TcM.WF.pure (I := I) (s := state) (a := flags) fun _ => trivial) + | cons member rest ih => + unfold collectBlockClassFlags + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.WF.bind (TcM.getConst_loaded_wf hfault member state) + intro concrete after _ + cases hnote : flags.note member concrete with + | error err => + simpa only using + (TcM.WF.throw (I := I) (s := after) fun _ => trivial) + | ok next => + simpa only using ih next after + +/-- The complete classifier, including empty/mixed-block errors, preserves +any invariant preserved by lazy ingress. -/ +theorem classifyBlock_wf + {I : TcState .anon → Prop} {methods : Methods .anon} + (hfault : TcM.LazyFaultPreserves I) + (members : Array (KId .anon)) (state : TcState .anon) : + TcM.WF I state ((classifyBlock members).run methods) + (fun _ _ => True) := by + unfold classifyBlock + split + · exact TcM.WF.throw fun _ => trivial + · apply TcM.WF.bind + (collectBlockClassFlags_wf hfault members.toList + BlockClassFlags.empty state) + intro flags after _ + match hfinish : BlockClassFlags.finish (m := .anon) flags with + | .error err => + simp only [hfinish] + exact TcM.WF.throw (I := I) (s := after) + (Q := fun _ _ => True) (E := fun _ _ => True) fun _ => trivial + | .ok kind => + simp only [hfinish] + exact TcM.WF.pure (I := I) (s := after) (a := kind) + (Q := fun _ _ => True) (E := fun _ _ => True) fun _ => trivial + +/-- The ordered production census preserves an arbitrary caller invariant +and returns exactly the fold of the known homogeneous kind. `hloaded` is the +only representation premise: it prevents lazy ingress from substituting a +different declaration under the same member key. -/ +theorem collectBlockClassFlags_exact_wf + {I : TcState .anon → Prop} {world : VerifyWorld} + {methods : Methods .anon} {block : KId .anon} + {kind : CheckBlockKind} + (hloaded : ∀ {state}, I state → + LoadedAgrees world.catalog state.env) + (hfault : TcM.LazyFaultPreserves I) + (members : List (KId .anon)) + (hcoord : ∀ id ∈ members, + world.catalog.CoordinatedMember block kind id) + (flags : BlockClassFlags) (state : TcState .anon) : + TcM.WF I state + ((collectBlockClassFlags members flags).run methods) + (fun result _ => result = members.foldl + (fun acc _ => BlockClassFlags.mark acc kind) flags) := by + induction members generalizing flags state with + | nil => + simpa [collectBlockClassFlags] using + (TcM.WF.pure (I := I) (s := state) (a := flags) fun _ => rfl) + | cons member rest ih => + unfold collectBlockClassFlags + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.WF.bind + (TcM.WF.withInv (TcM.getConst_loaded_wf hfault member state)) + intro concrete after hpost + have hcatalogFound : world.catalog member = some concrete := + hloaded hpost.1 hpost.2 + obtain ⟨expected, hcatalog, hshape⟩ := hcoord member (by simp) + have hconcrete : concrete = expected := + Option.some.inj (hcatalogFound.symm.trans hcatalog) + subst concrete + rw [BlockClassFlags.note_of_member hshape] + simpa using ih (fun id hid => hcoord id (by simp [hid])) + (BlockClassFlags.mark flags kind) after + +/-- Complete classifier correctness for an exact immutable block. A lazy +fault may still make the computation fail, but every outcome preserves `I`, +and every successful result equals the exact catalog kind. -/ +theorem classifyBlock_exact_wf + {I : TcState .anon → Prop} {world : VerifyWorld} + {methods : Methods .anon} {block : KId .anon} + {kind : CheckBlockKind} {members : Array (KId .anon)} + (hloaded : ∀ {state}, I state → + LoadedAgrees world.catalog state.env) + (hfault : TcM.LazyFaultPreserves I) + (hexact : ExactCheckBlock world block members kind) + (state : TcState .anon) : + TcM.WF I state ((classifyBlock members).run methods) + (fun result _ => result = kind) := by + unfold classifyBlock + have hpositive := hexact.nonempty + have hsize : members.size ≠ 0 := by omega + simp only [Array.isEmpty, hsize] + apply TcM.WF.bind + (collectBlockClassFlags_exact_wf hloaded hfault members.toList + (fun id hid => hexact.coordinated (by simpa using hid)) + BlockClassFlags.empty state) + intro flags after hflags + have hlist : members.toList ≠ [] := by + intro hempty + have : members.size = 0 := by + simpa using congrArg List.length hempty + exact hsize this + rw [hflags, BlockClassFlags.foldl_mark_empty_of_nonempty kind hlist] + simpa [BlockClassFlags.finish_only] using + (TcM.WF.pure (I := I) (s := after) (a := kind) fun _ => rfl) + +/-- Concrete success corollary used to refine an existential body trace to +the exact catalog kind. -/ +theorem classifyBlock_success_exact + {I : TcState .anon → Prop} {world : VerifyWorld} + {methods : Methods .anon} {block : KId .anon} + {expected actual : CheckBlockKind} + {members : Array (KId .anon)} {before after : TcState .anon} + (hloaded : ∀ {state}, I state → + LoadedAgrees world.catalog state.env) + (hfault : TcM.LazyFaultPreserves I) + (hexact : ExactCheckBlock world block members expected) + (hbefore : I before) + (hrun : (classifyBlock members).run methods before = .ok actual after) : + I after ∧ actual = expected := by + have hpost := classifyBlock_exact_wf (methods := methods) hloaded hfault + hexact before hbefore + rw [hrun] at hpost + exact hpost + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/BlockDefinition.lean b/Ix/Tc/Verify/Check/BlockDefinition.lean new file mode 100644 index 000000000..395f9a177 --- /dev/null +++ b/Ix/Tc/Verify/Check/BlockDefinition.lean @@ -0,0 +1,173 @@ +import Ix.Tc.Verify.Check.BlockTransaction +import Ix.Tc.Verify.Check.BlockClassification +import Ix.Tc.Verify.Check.ScopedStandaloneDriver +import Ix.Tc.Verify.Check.StandaloneDriver + +/-! +# Singleton definition blocks + +The production definition-block branch iterates `checkConstMemberFresh` over +the complete array and then publishes the peak DefEq depth. Lean4Lean does +not yet have an atomic mutual-definition declaration, so the constructive E0 +bridge is intentionally the singleton specialization. It extracts the +actual member run from `checkClassifiedBlock`, invokes K3 without performing +K3's standalone promotion, and packages that evidence for the enclosing +atomic block transaction. +-/ + +namespace Ix.Tc + +namespace RecM + +/-- On a singleton definition array, successful classified execution is +exactly successful execution of that member. The final peak update is a +no-op because `max 0 peak = peak` for `UInt32`. -/ +theorem checkClassifiedBlock_singleton_definition_success + {methods : Methods .anon} {block id : KId .anon} + {before after : TcState .anon} + (hrun : (checkClassifiedBlock .defn block #[id]).run methods before = + .ok () after) : + (checkConstMemberFresh id).run methods before = .ok () after := by + unfold checkClassifiedBlock at hrun + have hneq : ((.defn : CheckBlockKind) != .defn) = false := by rfl + rw [hneq] at hrun + simp at hrun + change EStateM.bind ((checkConstMemberFresh id).run methods) _ before = + .ok () after at hrun + unfold EStateM.bind at hrun + cases hmember : (checkConstMemberFresh id).run methods before with + | error err failed => + rw [hmember] at hrun + contradiction + | ok value checked => + rw [hmember] at hrun + cases value + simp only [get, modify, ReaderT.run] at hrun + cases hrun + simp [UInt32.max_def] + +/-- Construct the certified singleton-definition body from the actual +production trace and K3's fixed-world member theorem. Classifier correctness +is applied to the exact observed classification equation, so no invariant for +an unexecuted branch can satisfy it. + +`hblocksAfter` is the remaining representation frame for the legacy K1/K2 +invariant, which tracks loaded constants and intern/cache state but predates +E0's explicit block-array agreement layer. -/ +theorem certifySingletonDefinition + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {model : KernelSuffixModel trProj world} + {calls : Methods.CallDomain} {methods : Methods .anon} + (context : StandalonePipelineResources + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars calls methods) + (hmethods : Methods.WFAtOn .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars calls (Methods.next methods)) + (hmethodPolicy : (Methods.next methods).PreservesInferOnly) + {block requested id : KId .anon} {concrete : KConst .anon} + {decl : Lean4Lean.VDecl} {before after : TcState .anon} + (hprojection : trProj.SubstCompatible) + (hliterals : ∀ literal, world.venv.ContainsLits literal) + (hpending : PendingDecl trProj world id decl) + (hcatalog : world.catalog id = some concrete) + (hresources : StandaloneValidationResources support concrete) + (hcovers : context.Covers concrete) + (hcollision : support.CollisionFree) + (huvars : model.keys.uvars = concrete.lvls.toNat) + (hexact : ExactCheckBlock world block #[id] .defn) + (trace : ExactBlockBodySuccessTrace methods block requested #[id] .defn + before after) + (hbefore : WhnfStateInv .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars [] before) + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv .noAccel (kernelCacheSemantics model.keys trProj) + trProj world support model.keys.uvars [])) + (hblocksAfter : LoadedBlocksAgrees world.blocks after.env) : + CertifiedBlockBodySuccess (kernelCacheSemantics model.keys trProj) trProj + world support methods block requested #[id] .defn before after := by + cases trace with + | run loaded classified hlookup hclassification hclassified => + have hlookupPost := TcM.tryGetBlock_wf hfault block before hbefore + rw [hlookup] at hlookupPost + have hloadedInv := hlookupPost.1 + have hmember := + checkClassifiedBlock_singleton_definition_success hclassified + have hclassifiedInv := classifyBlock_success_exact + (I := WhnfStateInv .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars []) + (fun hI => hI.1.core.loaded) hfault hexact hloadedInv hclassification + have hevidence := checkConstMemberFresh_pending_evidence context hmethods + hmethodPolicy hprojection hliterals hpending hcatalog hresources + hcovers hcollision huvars hclassifiedInv.1.1 hclassifiedInv.1.2.2 + hfault hmember + exact + { trace := .run loaded classified hlookup hclassification hclassified + exactBlock := hexact + activePost := ActiveBlockStateWF.ofKernel hevidence.2.1 hblocksAfter + evidence := .singletonDefinition hpending hevidence.1 } + +/-- Run-scoped singleton-definition certification for the E3-S adapter. +This is the atomic-block analogue of K3's scoped standalone theorem: the +member run produces evidence in the original world and retains the finite +suffix-model witness, while the enclosing block transaction remains the +sole semantic commit point. -/ +theorem certifySingletonDefinitionScoped + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {model : ScopedKernelSuffixModel trProj world} + {calls : Methods.CallDomain} {methods : Methods .anon} + (context : ScopedStandalonePipelineResources model support calls methods) + (hmethods : Methods.ScopedWFAtOn model .noAccel + (kernelCacheSemantics model.keys trProj) support calls + (Methods.next methods)) + (hmethodPolicy : (Methods.next methods).PreservesInferOnly) + {block requested id : KId .anon} {concrete : KConst .anon} + {decl : Lean4Lean.VDecl} {before after : TcState .anon} + (hprojection : trProj.SubstCompatible) + (hliterals : ∀ literal, world.venv.ContainsLits literal) + (hpending : PendingDecl trProj world id decl) + (hcatalog : world.catalog id = some concrete) + (hresources : StandaloneValidationResources support concrete) + (hcovers : context.Covers concrete) + (hcollision : support.CollisionFree) + (huvars : model.keys.uvars = concrete.lvls.toNat) + (hresetScope : model.ResetPreservesScope) + (hexact : ExactCheckBlock world block #[id] .defn) + (trace : ExactBlockBodySuccessTrace methods block requested #[id] .defn + before after) + (hbefore : ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) support [] before) + (hfault : TcM.LazyFaultPreserves + (ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) support [])) + (hblocksAfter : LoadedBlocksAgrees world.blocks after.env) : + CertifiedBlockBodySuccess (kernelCacheSemantics model.keys trProj) trProj + world support methods block requested #[id] .defn before after := by + cases trace with + | run loaded classified hlookup hclassification hclassified => + have hlookupPost := TcM.tryGetBlock_wf hfault block before hbefore + rw [hlookup] at hlookupPost + have hloadedInv := hlookupPost.1 + have hmember := + checkClassifiedBlock_singleton_definition_success hclassified + have hclassifiedInv := classifyBlock_success_exact + (I := ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) support []) + (fun hI => hI.1.1.core.loaded) hfault hexact hloadedInv + hclassification + have hevidence := checkConstMemberFresh_scoped_pending_evidence context + hmethods hmethodPolicy hprojection hliterals hpending hcatalog + hresources hcovers hcollision huvars hresetScope hclassifiedInv.1 + hfault hmember + exact + { trace := .run loaded classified hlookup hclassification hclassified + exactBlock := hexact + activePost := + ActiveBlockStateWF.ofKernel hevidence.2.1.1 hblocksAfter + evidence := .singletonDefinition hpending hevidence.1 } + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/BlockExecution.lean b/Ix/Tc/Verify/Check/BlockExecution.lean new file mode 100644 index 000000000..93a1474aa --- /dev/null +++ b/Ix/Tc/Verify/Check/BlockExecution.lean @@ -0,0 +1,383 @@ +import Ix.Tc.Verify.Check.BlockAcceptance + +/-! +# Coordinated block execution traces + +This module follows the production `checkCoordinatedBlock` cache shell +exactly. It separates a stable cache hit from a fresh `checkBlockBody` run +and proves that the sole subsequent mutation is insertion of the captured +verdict. In particular: + +* a returned success cannot be manufactured after a body error; +* a returned error cannot publish a successful block verdict; +* neither result insertion changes constants, block identity, interning, or + the ghost verification world. + +The semantic admission theorem remains in `BlockAcceptance`; this module is +the operational half needed to join that transaction to production. +-/ + +namespace Ix.Tc + +namespace TcM + +/-- A physical block already present in the checker environment takes the +fast path, returning the exact array without changing state or invoking lazy +ingress. -/ +theorem tryGetBlock_of_loaded + {state : TcState .anon} {block : KId .anon} + {members : Array (KId .anon)} + (hloaded : state.env.getBlock? block = some members) : + TcM.tryGetBlock block state = .ok (some members) state := by + unfold TcM.tryGetBlock + change EStateM.bind (get : TcM .anon (TcState .anon)) _ state = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) state = + .ok state state by rfl] + simp only + rw [hloaded] + rfl + +/-- Every successful `some` result of the production block lookup is +physically installed in its post-state, on either the eager or lazy-ingress +path. -/ +theorem tryGetBlock_success_loaded + {block : KId .anon} {members : Array (KId .anon)} + {before after : TcState .anon} + (hrun : TcM.tryGetBlock block before = .ok (some members) after) : + after.env.getBlock? block = some members := by + unfold TcM.tryGetBlock at hrun + change EStateM.bind (get : TcM .anon (TcState .anon)) _ before = _ at hrun + unfold EStateM.bind at hrun + rw [show (get : TcM .anon (TcState .anon)) before = + .ok before before by rfl] at hrun + simp only at hrun + cases hget : before.env.getBlock? block 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 at hrun + change EStateM.bind (TcM.lazyIngressAddr block.addr) _ before = _ at hrun + unfold EStateM.bind at hrun + cases hfault : TcM.lazyIngressAddr block.addr before with + | error err failed => + rw [hfault] at hrun + contradiction + | ok value faulted => + rw [hfault] at hrun + simp only at hrun + change EStateM.bind (get : TcM .anon (TcState .anon)) _ faulted = _ + at hrun + unfold EStateM.bind at hrun + rw [show (get : TcM .anon (TcState .anon)) faulted = + .ok faulted faulted by rfl] at hrun + simp only at hrun + cases hretry : faulted.env.getBlock? block with + | none => + rw [hretry] at hrun + cases hrun + | some found => + rw [hretry] at hrun + rcases hrun with ⟨rfl, rfl⟩ + exact hretry + +end TcM + +namespace RecM + +/-- Capturing a successful body is exactly a successful outer action carrying +`Except.ok`. -/ +theorem captureBlockCheckResult_success_iff + {methods : Methods .anon} {block requested : KId .anon} + {before after : TcState .anon} : + (captureBlockCheckResult block requested).run methods before = + .ok (.ok ()) after ↔ + (checkBlockBody block requested).run methods before = .ok () after := by + unfold captureBlockCheckResult + change EStateM.tryCatch + (EStateM.bind ((checkBlockBody block requested).run methods) + (fun _ state => EStateM.Result.ok (Except.ok ()) state)) + (fun err state => EStateM.Result.ok (Except.error err) state) before = + EStateM.Result.ok (Except.ok ()) after ↔ _ + unfold EStateM.bind EStateM.tryCatch + cases hbody : (checkBlockBody block requested).run methods before <;> + simp only [hbody] <;> simp + +/-- The capture shell handles both body outcomes and therefore cannot return +an outer checker error. -/ +theorem captureBlockCheckResult_ne_error + {methods : Methods .anon} {block requested : KId .anon} + {before after : TcState .anon} {err : TcError .anon} : + (captureBlockCheckResult block requested).run methods before ≠ + .error err after := by + intro hrun + unfold captureBlockCheckResult at hrun + change EStateM.tryCatch + (EStateM.bind ((checkBlockBody block requested).run methods) + (fun _ state => EStateM.Result.ok (Except.ok ()) state)) + (fun caught state => EStateM.Result.ok (Except.error caught) state) before = + EStateM.Result.error err after at hrun + unfold EStateM.bind EStateM.tryCatch at hrun + cases hbody : (checkBlockBody block requested).run methods before <;> + simp only [hbody] at hrun <;> contradiction + +/-- A captured error came from an actual error of `checkBlockBody` in the +same state. `TcM` is deliberately non-backtracking, so writes performed +before the throw survive the catch exactly. -/ +theorem captureBlockCheckResult_error_has_body_error + {methods : Methods .anon} {block requested : KId .anon} + {before captured : TcState .anon} {err : TcError .anon} + (hrun : (captureBlockCheckResult block requested).run methods before = + .ok (.error err) captured) : + (checkBlockBody block requested).run methods before = + .error err captured := by + unfold captureBlockCheckResult at hrun + change EStateM.tryCatch + (EStateM.bind ((checkBlockBody block requested).run methods) + (fun _ state => EStateM.Result.ok (Except.ok ()) state)) + (fun caught state => EStateM.Result.ok (Except.error caught) state) before = + EStateM.Result.ok (Except.error err) captured at hrun + unfold EStateM.bind EStateM.tryCatch at hrun + cases hbody : (checkBlockBody block requested).run methods before with + | ok value after => + simp only [hbody] at hrun + cases value + cases hrun + | error bodyErr failed => + have hrestore : EStateM.Backtrackable.restore failed + (EStateM.Backtrackable.save before) = failed := rfl + simp only [hbody, hrestore] at hrun + cases hrun + rfl + +/-- A successful body exposes the production lookup, classification, and +classified-block execution as three consecutive equations. The lookup +post-state is explicit, so the trace covers both eager and lazy ingress. The +classified kind is an index, so semantic admission evidence cannot later be +paired with a different production branch. -/ +inductive ExactBlockBodySuccessTrace + (methods : Methods .anon) (block requested : KId .anon) + (members : Array (KId .anon)) (kind : CheckBlockKind) + (before after : TcState .anon) : Prop + | run (loaded classified : TcState .anon) : + TcM.tryGetBlock block before = .ok (some members) loaded → + (classifyBlock members).run methods loaded = .ok kind classified → + (checkClassifiedBlock kind block members).run methods classified = + .ok () after → + ExactBlockBodySuccessTrace methods block requested members kind before + after + +/-- Invert successful `checkBlockBody` execution. Production now fails +closed on a missing coordinated array, so every success contains an actual +`some members` lookup and there is no fallback singleton case. -/ +theorem checkBlockBody_success_trace + {methods : Methods .anon} {block requested : KId .anon} + {before after : TcState .anon} + (hrun : (checkBlockBody block requested).run methods before = + .ok () after) : + ∃ members kind, + ExactBlockBodySuccessTrace methods block requested members kind before + after := by + unfold checkBlockBody at hrun + simp only [ReaderT.run_bind, ReaderT.run_monadLift] at hrun + change EStateM.bind (TcM.tryGetBlock block) _ before = .ok () after at hrun + unfold EStateM.bind at hrun + cases hlookup : TcM.tryGetBlock block before with + | error err failed => + rw [hlookup] at hrun + contradiction + | ok found loaded => + rw [hlookup] at hrun + cases found with + | none => + simp only [throw] at hrun + contradiction + | some members => + simp only at hrun + change EStateM.bind ((classifyBlock members).run methods) _ loaded = + .ok () after at hrun + unfold EStateM.bind at hrun + cases hclass : (classifyBlock members).run methods loaded with + | error err failed => + rw [hclass] at hrun + contradiction + | ok kind classified => + rw [hclass] at hrun + exact ⟨members, kind, + .run loaded classified hlookup hclass hrun⟩ + +/-- Exhaustive successful execution of the coordinated cache shell. -/ +inductive CoordinatedBlockSuccessTrace + (methods : Methods .anon) (block requested : KId .anon) + (before after : TcState .anon) : Prop + | cached : + before.env.blockCheckResults[block]? = some (.ok ()) → + after = before → + CoordinatedBlockSuccessTrace methods block requested before after + | fresh {bodyAfter : TcState .anon} : + before.env.blockCheckResults[block]? = none → + (checkBlockBody block requested).run methods before = + .ok () bodyAfter → + after = bodyAfter.withBlockCheckResult block (.ok ()) → + CoordinatedBlockSuccessTrace methods block requested before after + +/-- Exhaustive failing execution of the coordinated cache shell. -/ +inductive CoordinatedBlockErrorTrace + (methods : Methods .anon) (block requested : KId .anon) + (before : TcState .anon) (err : TcError .anon) + (after : TcState .anon) : Prop + | cached : + before.env.blockCheckResults[block]? = some (.error err) → + after = before → + CoordinatedBlockErrorTrace methods block requested before err after + | fresh {failed : TcState .anon} : + before.env.blockCheckResults[block]? = none → + (captureBlockCheckResult block requested).run methods before = + .ok (.error err) failed → + (checkBlockBody block requested).run methods before = + .error err failed → + after = failed.withBlockCheckResult block (.error err) → + CoordinatedBlockErrorTrace methods block requested before err after + +/-- Invert a successful production execution into the two exhaustive paths. +The fresh constructor exposes the actual successful block-body equation and +the exact result-insertion state. -/ +theorem checkCoordinatedBlock_success_trace + {methods : Methods .anon} {block requested : KId .anon} + {before after : TcState .anon} + (hrun : (checkCoordinatedBlock block requested).run methods before = + .ok () after) : + CoordinatedBlockSuccessTrace methods block requested before after := by + unfold checkCoordinatedBlock at hrun + simp only [ReaderT.run_bind] at hrun + change EStateM.bind (get : TcM .anon (TcState .anon)) _ before = + .ok () after at hrun + unfold EStateM.bind at hrun + rw [show (get : TcM .anon (TcState .anon)) before = + .ok before before by rfl] at hrun + dsimp only at hrun + cases hcache : before.env.blockCheckResults[block]? with + | some result => + rw [hcache] at hrun + dsimp only at hrun + cases result with + | ok value => + cases value + exact .cached hcache (EStateM.Result.ok.inj hrun |>.2.symm) + | error err => + simp only [throw] at hrun + contradiction + | none => + rw [hcache] at hrun + dsimp only at hrun + change EStateM.bind + ((captureBlockCheckResult block requested).run methods) _ before = + .ok () after at hrun + unfold EStateM.bind at hrun + cases hcapture : + (captureBlockCheckResult block requested).run methods before with + | error err failed => + exact False.elim (captureBlockCheckResult_ne_error hcapture) + | ok result captured => + rw [hcapture] at hrun + cases result with + | error err => + simp only [modify, throw] at hrun + contradiction + | ok value => + cases value + have hbody := captureBlockCheckResult_success_iff.mp hcapture + simp only [modify] at hrun + exact .fresh hcache hbody + (EStateM.Result.ok.inj hrun |>.2.symm) + +/-- Invert a failing production execution into a cached error or an actual +body error followed by an error-only result insertion. -/ +theorem checkCoordinatedBlock_error_trace + {methods : Methods .anon} {block requested : KId .anon} + {before after : TcState .anon} {err : TcError .anon} + (hrun : (checkCoordinatedBlock block requested).run methods before = + .error err after) : + CoordinatedBlockErrorTrace methods block requested before err after := by + unfold checkCoordinatedBlock at hrun + simp only [ReaderT.run_bind] at hrun + change EStateM.bind (get : TcM .anon (TcState .anon)) _ before = + .error err after at hrun + unfold EStateM.bind at hrun + rw [show (get : TcM .anon (TcState .anon)) before = + .ok before before by rfl] at hrun + dsimp only at hrun + cases hcache : before.env.blockCheckResults[block]? with + | some result => + rw [hcache] at hrun + dsimp only at hrun + cases result with + | ok value => + cases value + contradiction + | error cachedErr => + cases hrun + exact .cached hcache rfl + | none => + rw [hcache] at hrun + dsimp only at hrun + change EStateM.bind + ((captureBlockCheckResult block requested).run methods) _ before = + .error err after at hrun + unfold EStateM.bind at hrun + cases hcapture : + (captureBlockCheckResult block requested).run methods before with + | error outerErr failed => + exact False.elim (captureBlockCheckResult_ne_error hcapture) + | ok result captured => + rw [hcapture] at hrun + cases result with + | ok value => + cases value + simp only [modify] at hrun + contradiction + | error capturedErr => + have hbody := + captureBlockCheckResult_error_has_body_error hcapture + simp only [modify, throw] at hrun + cases hrun + exact .fresh hcache hcapture hbody rfl + +end RecM + +namespace TcState + +/-- The production verdict update installs exactly the requested entry. -/ +@[simp] theorem withBlockCheckResult_self + (state : TcState .anon) (block : KId .anon) + (result : Except (TcError .anon) Unit) : + (state.withBlockCheckResult block result).env.blockCheckResults[block]? = + some result := by + simp [TcState.withBlockCheckResult] + +end TcState + +namespace BlockStateWF + +/-- Publishing a captured block verdict cannot change semantic trust or the +concrete/world representation boundary. -/ +theorem withBlockCheckResult {trProj : RawProjRel} + {state : TcState .anon} {world : VerifyWorld} + (h : BlockStateWF trProj state world) (block : KId .anon) + (result : Except (TcError .anon) Unit) : + BlockStateWF trProj (state.withBlockCheckResult block result) world := by + refine ⟨h.core.of_consts_eq ?_ ?_, ?_⟩ + · rfl + · exact h.core.intern + · intro loadedBlock members hget + apply h.loadedBlocks + change state.env.blocks[loadedBlock]? = some members at hget + exact hget + +end BlockStateWF + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/BlockIdentity.lean b/Ix/Tc/Verify/Check/BlockIdentity.lean new file mode 100644 index 000000000..c8b60906f --- /dev/null +++ b/Ix/Tc/Verify/Check/BlockIdentity.lean @@ -0,0 +1,280 @@ +import Ix.Tc.Driver +import Ix.Tc.Verify.State + +/-! +# Coordinated checker-block identity + +`checkConst` uses three representations of a block which must not be allowed +to drift apart: + +* `KEnv.blocks` is the concrete ordered member array used by the checker; +* `VerifyWorld.blocks` is its immutable ghost identity, needed to interpret a + stable `blockCheckResults[block] = .ok ()` hit; and +* `AnonWorkItem.block` exposes the block address, primary address, target + addresses, and the larger `provenTargets` set used by the driver. + +This module defines their exact agreement without assigning typing authority +to any of them. In particular, a catalogued member is still untrusted until +the atomic acceptance theorem admits the complete array. +-/ + +namespace Ix.Tc + +/-! ## Concrete/world block agreement -/ + +/-- E0's representation invariant. The existing `TcStateWF` continues to +separate loaded constants from semantic trust; this layer adds the one-way +agreement for lazily loaded block arrays. -/ +structure BlockStateWF (trProj : RawProjRel) (s : TcState .anon) + (world : VerifyWorld) : Prop where + core : TcStateWF trProj s world + loadedBlocks : LoadedBlocksAgrees world.blocks s.env + +namespace BlockStateWF + +/-- A concrete block lookup exposes the exact immutable ordered array. -/ +theorem blockLookup {trProj : RawProjRel} {s : TcState .anon} + {world : VerifyWorld} (h : BlockStateWF trProj s world) + {block : KId .anon} {members : Array (KId .anon)} + (hget : s.env.blocks[block]? = some members) : + world.blocks block = some members := + h.loadedBlocks hget + +/-- Operational bookkeeping changes preserve the block invariant when the +whole environment is unchanged. -/ +theorem of_env_eq {trProj : RawProjRel} {before after : TcState .anon} + {world : VerifyWorld} (h : BlockStateWF trProj before world) + (henv : after.env = before.env) : + BlockStateWF trProj after world := by + refine ⟨h.core.of_env_eq henv, ?_⟩ + rw [henv] + exact h.loadedBlocks + +/-- Ghost promotion preserves block identity because `VerifyWorld.LE` fixes +the immutable block catalog. -/ +theorem rebaseWorld {trProj : RawProjRel} {s : TcState .anon} + {before after : VerifyWorld} (h : BlockStateWF trProj s before) + (hle : before ≤ after) (hcore : TcStateWF trProj s after) : + BlockStateWF trProj s after := + ⟨hcore, (LoadedBlocksAgrees.world_iff hle).mp h.loadedBlocks⟩ + +end BlockStateWF + +/-! ## Exact semantic ownership of members -/ + +namespace KConst + +/-- A definition declaration records this coordinated owner block. -/ +def IsDefinitionMemberOf (block : KId .anon) : KConst .anon → Prop + | .defn (block := owner) .. => owner = block + | _ => False + +/-- A recursor declaration records this coordinated owner block. -/ +def IsRecursorMemberOf (block : KId .anon) : KConst .anon → Prop + | .recr (block := owner) .. => owner = block + | _ => False + +/-- Inductive-like ownership follows production's routing exactly. An +inductive records its block directly; a constructor inherits the block from +the exact parent inductive committed by the catalog. -/ +def IsInductiveMemberOf (catalog : Catalog) (block : KId .anon) : + KConst .anon → Prop + | .indc (block := owner) .. => owner = block + | .ctor (induct := parent) .. => + ∃ parentConst, catalog parent = some parentConst ∧ + match parentConst with + | .indc (block := owner) .. => owner = block + | _ => False + | _ => False + +/-- Exact declaration shape represented by a production `CheckBlockKind`. -/ +def IsMemberOfKind (catalog : Catalog) (block : KId .anon) : + CheckBlockKind → KConst .anon → Prop + | .defn => IsDefinitionMemberOf block + | .inductive' => IsInductiveMemberOf catalog block + | .recursor => IsRecursorMemberOf block + +end KConst + +namespace Catalog + +/-- `id` is the exact catalog declaration owned by `block` under `kind`. +This is deliberately stronger than merely having the right constructor tag. -/ +def CoordinatedMember (catalog : Catalog) (block : KId .anon) + (kind : CheckBlockKind) (id : KId .anon) : Prop := + ∃ concrete, catalog id = some concrete ∧ + concrete.IsMemberOfKind catalog block kind + +namespace CoordinatedMember + +theorem catalogued {catalog : Catalog} {block : KId .anon} + {kind : CheckBlockKind} {id : KId .anon} + (h : catalog.CoordinatedMember block kind id) : + Catalog.Contains catalog id := by + obtain ⟨concrete, hcatalog, _⟩ := h + exact ⟨concrete, hcatalog⟩ + +end CoordinatedMember + +end Catalog + +/-- One immutable block entry is exact for a coordinated checker kind: it is +nonempty, and array membership is equivalent to catalog ownership. The +ordered array itself remains available, so later ingress/driver proofs can +also establish positional claims rather than only set coverage. -/ +structure ExactCheckBlock (world : VerifyWorld) (block : KId .anon) + (members : Array (KId .anon)) (kind : CheckBlockKind) : Prop where + blockLookup : world.blocks block = some members + nonempty : members.size > 0 + memberIff : ∀ id, id ∈ members ↔ + world.catalog.CoordinatedMember block kind id + +namespace ExactCheckBlock + +/-- Exact block identity is stable under semantic world extension: both the +catalog and ordered block table are immutable components of `VerifyWorld`. -/ +theorem rebaseWorld {before after : VerifyWorld} {block : KId .anon} + {members : Array (KId .anon)} {kind : CheckBlockKind} + (h : ExactCheckBlock before block members kind) (hle : before ≤ after) : + ExactCheckBlock after block members kind := by + refine ⟨?_, h.nonempty, ?_⟩ + · rw [← hle.blocks] + exact h.blockLookup + · intro id + rw [← hle.catalog] + exact h.memberIff id + +theorem member {world : VerifyWorld} {block id : KId .anon} + {members : Array (KId .anon)} {kind : CheckBlockKind} + (h : ExactCheckBlock world block members kind) + (hmember : world.catalog.CoordinatedMember block kind id) : + id ∈ members := + (h.memberIff id).2 hmember + +theorem coordinated {world : VerifyWorld} {block id : KId .anon} + {members : Array (KId .anon)} {kind : CheckBlockKind} + (h : ExactCheckBlock world block members kind) (hmember : id ∈ members) : + world.catalog.CoordinatedMember block kind id := + (h.memberIff id).1 hmember + +/-- Once the exact block is accepted, every exact member is trusted. -/ +theorem trusted {world : VerifyWorld} {block id : KId .anon} + {members : Array (KId .anon)} {kind : CheckBlockKind} + (hexact : ExactCheckBlock world block members kind) + (haccepted : world.AcceptedBlock block) (hid : id ∈ members) : + world.trusted id := + VerifyWorld.AcceptedBlock.trusted haccepted hexact.blockLookup hid + +/-- Acceptance covers every catalog declaration owned by this exact block; +no proper subset of its member array can satisfy the conclusion. -/ +theorem coordinated_trusted {world : VerifyWorld} {block id : KId .anon} + {members : Array (KId .anon)} {kind : CheckBlockKind} + (hexact : ExactCheckBlock world block members kind) + (haccepted : world.AcceptedBlock block) + (hid : world.catalog.CoordinatedMember block kind id) : + world.trusted id := + hexact.trusted haccepted (hexact.member hid) + +end ExactCheckBlock + +/-- Global coherence required of E0's immutable inputs: every catalogued +declaration which records coordinated ownership has one exact block entry of +the same kind. The premise does not trust or type the declaration. -/ +def ExactCoordinatedCatalog (world : VerifyWorld) : Prop := + ∀ {id concrete block kind}, world.catalog id = some concrete → + concrete.IsMemberOfKind world.catalog block kind → + ∃ members, ExactCheckBlock world block members kind + +namespace ExactCoordinatedCatalog + +/-- Resolve a catalogued owner to its exact array and requested membership. -/ +theorem resolve {world : VerifyWorld} (h : ExactCoordinatedCatalog world) + {id concrete block kind} + (hcatalog : world.catalog id = some concrete) + (hshape : concrete.IsMemberOfKind world.catalog block kind) : + ∃ members, ExactCheckBlock world block members kind ∧ id ∈ members := by + obtain ⟨members, hexact⟩ := h hcatalog hshape + exact ⟨members, hexact, + hexact.member ⟨concrete, hcatalog, hshape⟩⟩ + +end ExactCoordinatedCatalog + +/-! ## Driver primary/target identity -/ + +namespace AnonWorkItem + +/-- Exact agreement between one anonymous driver item and the immutable block +catalog. A Muts item exposes all flattened `KEnv.blocks` members as targets; +its first member is the primary. `provenTargets` additionally includes the +original Muts address, which is not necessarily a `KConst` declaration id. + +Standalone ingress also registers a singleton physical block, although +axioms and quotients intentionally bypass block coordination in `checkConst`. -/ +def MatchesBlockCatalog (blocks : BlockCatalog) : AnonWorkItem → Prop + | .standalone addr => + let id : KId .anon := ⟨addr, ()⟩ + blocks id = some #[id] + | .block blockAddr primary targets => + let block : KId .anon := ⟨blockAddr, ()⟩ + ∃ first rest, + blocks block = some (#[first] ++ rest) ∧ + primary = first.addr ∧ + targets = (#[first] ++ rest).map (·.addr) + +namespace MatchesBlockCatalog + +/-- A block item's primary is one of its exact target addresses. -/ +theorem primary_mem_targets {blocks : BlockCatalog} {item : AnonWorkItem} + (h : item.MatchesBlockCatalog blocks) : + item.primary ∈ item.targets := by + cases item with + | standalone addr => simp [AnonWorkItem.primary, AnonWorkItem.targets] + | block blockAddr primary targets => + obtain ⟨first, rest, hblock, hprimary, htargets⟩ := h + subst primary + subst targets + simp [AnonWorkItem.primary, AnonWorkItem.targets] + +/-- For a block item, `targets` is exactly the address image of the immutable +ordered member array. -/ +theorem block_targets {blocks : BlockCatalog} {blockAddr primary : Address} + {targets : Array Address} + (h : (AnonWorkItem.block blockAddr primary targets).MatchesBlockCatalog + blocks) : + ∃ members, blocks (⟨blockAddr, ()⟩ : KId .anon) = some members ∧ + members.size > 0 ∧ primary = members[0]!.addr ∧ + targets = members.map (·.addr) := by + obtain ⟨first, rest, hblock, hprimary, htargets⟩ := h + refine ⟨#[first] ++ rest, hblock, ?_, ?_, htargets⟩ + · rw [Array.size_append] + have hone : (#[first] : Array (KId .anon)).size = 1 := by rfl + rw [hone] + omega + · have hzero : (#[first] ++ rest)[0]! = first := by + rw [getElem!_pos (#[first] ++ rest) 0 (by simp; omega)] + exact Array.getElem_append_left (by simp) + rw [hzero] + exact hprimary + +/-- `provenTargets` is the exact target array plus the original Muts block +address. This is the extra coverage later consumed by E1; it is not smuggled +into the member array or treated as a trusted declaration. -/ +theorem block_provenTargets {blocks : BlockCatalog} + {blockAddr primary : Address} {targets : Array Address} + (_h : (AnonWorkItem.block blockAddr primary targets).MatchesBlockCatalog + blocks) : + (AnonWorkItem.block blockAddr primary targets).provenTargets = + #[blockAddr] ++ targets := by + rfl + +/-- Standalone work proves exactly its one target. -/ +theorem standalone_provenTargets {blocks : BlockCatalog} {addr : Address} + (_h : (AnonWorkItem.standalone addr).MatchesBlockCatalog blocks) : + (AnonWorkItem.standalone addr).provenTargets = #[addr] := by + rfl + +end MatchesBlockCatalog + +end AnonWorkItem + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/BlockNatFixture.lean b/Ix/Tc/Verify/Check/BlockNatFixture.lean new file mode 100644 index 000000000..84aa6407b --- /dev/null +++ b/Ix/Tc/Verify/Check/BlockNatFixture.lean @@ -0,0 +1,121 @@ +import Ix.Tc.Verify.Check.PublicBlocks +import Ix.Tc.Verify.NatFixture + +/-! +# Concrete Nat block fixture for E0 + +The existing ambient-Nat oracle is instantiated here against an exact +physical block table. This fixture exercises the semantic transaction and +the adversarial cache rule without pretending that E2 has already connected +the production inductive checker to the oracle. +-/ + +namespace Ix.Tc.AmbientNat.E0 + +/-- Ordered production member array for the Nat family. -/ +def blockMembers : Array (KId .anon) := #[natId, zeroId, succId] + +/-- A physical block table containing exactly the Nat family under its +recorded owner key. -/ +def blockTable : BlockCatalog := fun block => + if block == natId then some blockMembers else none + +/-- Pre-admission world: the Nat declarations are immutable inputs but none +is trusted yet. -/ +def baseWorld : VerifyWorld where + catalog := catalog + blocks := blockTable + trusted := fun _ => False + venv := .empty + nameOf := nameOf + venvWF := ⟨[], .empty⟩ + trustedCatalogued := fun {_} h => False.elim h + +@[simp] theorem blockMembers_iff (id : KId .anon) : + id ∈ blockMembers ↔ AmbientNat.members id := by + simp [blockMembers, AmbientNat.members] + +/-- For the inductive classifier kind, the full ambient catalog owns exactly +the three Nat-family declarations. Other fixture entries are standalone or +recursor-shaped and cannot enter this block. -/ +theorem coordinated_iff (id : KId .anon) : + catalog.CoordinatedMember natId .inductive' id ↔ + AmbientNat.members id := by + constructor + · rintro ⟨concrete, hcatalog, hshape⟩ + unfold catalog at hcatalog + split at hcatalog + · exact Or.inl (eq_of_beq (by assumption)) + · split at hcatalog + · exact Or.inr (Or.inl (eq_of_beq (by assumption))) + · split at hcatalog + · exact Or.inr (Or.inr (eq_of_beq (by assumption))) + · split at hcatalog + · have : concrete = goodConcrete := Option.some.inj hcatalog.symm + subst concrete + simp [goodConcrete, KConst.IsMemberOfKind, + KConst.IsInductiveMemberOf] at hshape + · split at hcatalog + · have : concrete = IllTypedPending.concrete := + Option.some.inj hcatalog.symm + subst concrete + simp [IllTypedPending.concrete, KConst.IsMemberOfKind, + KConst.IsInductiveMemberOf] at hshape + · split at hcatalog + · have : concrete = iotaConcrete := + Option.some.inj hcatalog.symm + subst concrete + simp [iotaConcrete, KConst.IsMemberOfKind, + KConst.IsInductiveMemberOf] at hshape + · cases hcatalog + · intro hmember + rcases hmember with rfl | rfl | rfl + · exact ⟨natConcrete, catalog_nat, by rfl⟩ + · exact ⟨zeroConcrete, catalog_zero, by + refine ⟨natConcrete, catalog_nat, ?_⟩ + rfl⟩ + · exact ⟨succConcrete, catalog_succ, by + refine ⟨natConcrete, catalog_nat, ?_⟩ + rfl⟩ + +/-- Exact immutable identity of the concrete Nat block. -/ +theorem exactBlock : + ExactCheckBlock baseWorld natId blockMembers .inductive' := by + refine ⟨?_, by decide, ?_⟩ + · rfl + · intro id + exact (blockMembers_iff id).trans (coordinated_iff id).symm + +/-- The ambient Nat oracle specialized definitionally to the pre-admission +world. -/ +def blockOracle : InductiveOracle RawProjRel.none baseWorld.catalog + baseWorld.nameOf baseWorld.trusted baseWorld.venv := + AmbientNat.oracle + +/-- Concrete oracle-backed certificate for the exact Nat member array. -/ +def certificate : OracleBlockCertificate RawProjRel.none baseWorld natId + blockMembers .inductive' where + oracleBacked := trivial + exactBlock := exactBlock + oracle := blockOracle + memberIff := fun id => by + change AmbientNat.members id ↔ id ∈ blockMembers + exact (blockMembers_iff id).symm + +/-- The fixture performs one exact atomic Theory admission: all three Nat +members become trusted together and no unrelated catalog entry does. -/ +theorem atomicAdmission : + AtomicBlockAdmission RawProjRel.none baseWorld + (baseWorld.admitOracle blockOracle) natId blockMembers .inductive' := + certificate.admit TrustedCatalogLog.empty + +/-- Before admission, a stable successful block-cache entry is semantically +invalid because an exact member is still untrusted. -/ +theorem rejectsPrematureSuccess + (semantics : CacheSemantics) (support : RunSupport) : + ¬semantics.Valid (CacheAuthority.stable baseWorld) support + (.blockResult natId (.ok ())) := + CacheInvariant.rejectsSuccessWithUntrustedMember exactBlock + (id := zeroId) (by simp [blockMembers]) (fun h => h) + +end Ix.Tc.AmbientNat.E0 diff --git a/Ix/Tc/Verify/Check/BlockOracle.lean b/Ix/Tc/Verify/Check/BlockOracle.lean new file mode 100644 index 000000000..265453653 --- /dev/null +++ b/Ix/Tc/Verify/Check/BlockOracle.lean @@ -0,0 +1,93 @@ +import Ix.Tc.Verify.Check.BlockTransaction +import Ix.Tc.Verify.Inductive.Certificate + +/-! +# Oracle-backed inductive and recursor blocks + +E0 proves the transaction and cache ordering around production block checks. +The semantic meaning of a successful inductive/recursor body remains the +explicit E2b boundary: E2b must connect the actual Ix validators and generated +recursor patterns to an `InductiveOracle`. The Lean4Lean +`CertifiedGenerationTransaction` supplies the Theory-owned portion of that +future construction, but cannot determine Ix addresses, member arrays, or +checker execution on its own. + +This module packages exactly that remaining boundary and ties it to the real +classified-body trace. It introduces no unindexed “block succeeded” axiom. +-/ + +namespace Ix.Tc + +/-- The E2b resources which remain after E0 has fixed the exact physical +array and production classifier kind. The post-state uses temporary block +authority; it cannot be exposed as a stable success until the oracle's exact +member set is atomically admitted. -/ +structure OracleBackedBlockResources + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) + (members : Array (KId .anon)) (kind : CheckBlockKind) + (after : TcState .anon) where + oracleBacked : kind.OracleBacked + activePost : ActiveBlockStateWF semantics trProj world support members after + oracle : InductiveOracle trProj world.catalog world.nameOf world.trusted + world.venv + memberIff : ∀ id, oracle.members id ↔ id ∈ members + +namespace RecM + +/-- Package an actual successful inductive/recursor body for E0. The trace, +exact block, active post-state, and oracle all share the same `members` and +`kind` indices. -/ +theorem certifyOracleBackedBlock + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {methods : Methods .anon} + {block requested : KId .anon} {members : Array (KId .anon)} + {kind : CheckBlockKind} {before after : TcState .anon} + (trace : ExactBlockBodySuccessTrace methods block requested members kind + before after) + (hexact : ExactCheckBlock world block members kind) + (resources : OracleBackedBlockResources semantics trProj world support + members kind after) : + CertifiedBlockBodySuccess semantics trProj world support methods block + requested members kind before after := + { trace := trace + exactBlock := hexact + activePost := resources.activePost + evidence := .oracleBacked resources.oracleBacked resources.oracle + resources.memberIff } + +/-- Package an actual successful inductive/recursor body when its memoized +post-state is validated only after the exact oracle admission. This is the +appropriate atomic proof shape for production blocks whose generated +reduction entries mention members of the block itself. -/ +theorem certifyOracleBackedAdmittedBlock + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {methods : Methods .anon} + {block requested : KId .anon} {members : Array (KId .anon)} + {kind : CheckBlockKind} {before after : TcState .anon} + (trace : ExactBlockBodySuccessTrace methods block requested members kind + before after) + (hexact : ExactCheckBlock world block members kind) + (horacleBacked : kind.OracleBacked) + (oracle : InductiveOracle trProj world.catalog world.nameOf world.trusted + world.venv) + (memberIff : ∀ id, oracle.members id ↔ id ∈ members) + (trustedCatalog : TrustedCatalogRel trProj world) + (post : KernelStateWF semantics trProj (world.admitOracle oracle) support + after) : + CertifiedAdmittedBlockBodySuccess semantics trProj world + (world.admitOracle oracle) support methods block requested members kind + before after := by + let certificate : OracleBlockCertificate trProj world block members kind := + { oracleBacked := horacleBacked + exactBlock := hexact + oracle := oracle + memberIff := memberIff } + exact + { trace := trace + admission := certificate.admit trustedCatalog + post := post } + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/BlockRouteFrame.lean b/Ix/Tc/Verify/Check/BlockRouteFrame.lean new file mode 100644 index 000000000..bf2096a85 --- /dev/null +++ b/Ix/Tc/Verify/Check/BlockRouteFrame.lean @@ -0,0 +1,124 @@ +import Ix.Tc.Verify.Check.BlockClassification + +/-! +# State framing for successful coordinated routing + +Block identity and classifier soundness are semantic claims. This module +supplies the orthogonal operational fact needed by the `checkConst` driver: +if routing returns a coordinated block, every lazy lookup and classification +step preserves the caller's invariant up to the exact post-route state. +-/ + +namespace Ix.Tc + +namespace RecM + +private theorem runTcBindFrame {alpha beta : Type} + (x : TcM .anon alpha) (k : alpha → TcM .anon beta) + (state : TcState .anon) : + (x >>= k) state = match x state with + | .ok value after => k value after + | .error err after => .error err after := by + show EStateM.bind x k state = _ + unfold EStateM.bind + cases x state <;> rfl + +/-- The direct block/kind router preserves an arbitrary lazy-ingress +invariant on every successful `some` route. -/ +theorem coordinatedBlockIfKind_success_preserves + {I : TcState .anon → Prop} {methods : Methods .anon} + {block : KId .anon} {kind : CheckBlockKind} + {before after : TcState .anon} + (hfault : TcM.LazyFaultPreserves I) (hbefore : I before) + (hrun : (coordinatedBlockIfKind block kind).run methods before = + .ok (some block) after) : + I after := by + cases coordinatedBlockIfKind_success_trace hrun with + | run members loaded hlookup hclassification => + have hlookupPost := TcM.tryGetBlock_wf hfault block before hbefore + rw [hlookup] at hlookupPost + have hclassPost := classifyBlock_wf (methods := methods) hfault members + loaded hlookupPost.1 + rw [hclassification] at hclassPost + exact hclassPost.1 + +/-- The complete production router preserves an arbitrary lazy-ingress +invariant whenever it successfully selects a coordinated block. The +constructor path includes the parent-inductive lookup before the direct +block/kind router. -/ +theorem coordinatedBlockFor_some_preserves + {I : TcState .anon → Prop} {methods : Methods .anon} + {concrete : KConst .anon} {routed : KId .anon} + {before after : TcState .anon} + (hfault : TcM.LazyFaultPreserves I) (hbefore : I before) + (hrun : (coordinatedBlockFor concrete).run methods before = + .ok (some routed) after) : + I after := by + cases concrete with + | defn name levelParams defKind safety hints levels type value leanAll owner => + have hroute : routed = owner := + coordinatedBlockIfKind_some_eq owner routed .defn methods before after + (by simpa [coordinatedBlockFor] using hrun) + subst routed + exact coordinatedBlockIfKind_success_preserves hfault hbefore + (by simpa [coordinatedBlockFor] using hrun) + | recr name levelParams k isUnsafe levels params indices motives minors owner + memberIdx type rules leanAll => + have hroute : routed = owner := + coordinatedBlockIfKind_some_eq owner routed .recursor methods before + after (by simpa [coordinatedBlockFor] using hrun) + subst routed + exact coordinatedBlockIfKind_success_preserves hfault hbefore + (by simpa [coordinatedBlockFor] using hrun) + | axio => + simp only [coordinatedBlockFor] at hrun + cases hrun + | quot => + simp only [coordinatedBlockFor] at hrun + cases hrun + | indc name levelParams levels params indices isUnsafe owner memberIdx type + ctors leanAll => + have hroute : routed = owner := + coordinatedBlockIfKind_some_eq owner routed .inductive' methods before + after (by simpa [coordinatedBlockFor] using hrun) + subst routed + exact coordinatedBlockIfKind_success_preserves hfault hbefore + (by simpa [coordinatedBlockFor] using hrun) + | ctor name levelParams isUnsafe levels parent cidx params fields type => + unfold coordinatedBlockFor at hrun + simp only [ReaderT.run_bind, ReaderT.run_monadLift] at hrun + rw [runTcBindFrame] at hrun + cases hlookup : (monadLift (TcM.tryGetConst parent) : + TcM .anon (Option (KConst .anon))) before with + | error err failed => simp [hlookup] at hrun + | ok found afterLookup => + have hlookup' : TcM.tryGetConst parent before = + .ok found afterLookup := hlookup + have hlookupPost := TcM.tryGetConst_wf hfault parent before hbefore + rw [hlookup'] at hlookupPost + rw [hlookup] at hrun + cases found with + | none => + simp only at hrun + cases hrun + | some parentConst => + cases parentConst with + | indc parentName parentLevelParams parentLevels parentParams + parentIndices parentUnsafe owner parentMemberIdx parentType + parentCtors parentLeanAll => + simp only at hrun + have hroute : routed = owner := + coordinatedBlockIfKind_some_eq owner routed .inductive' + methods afterLookup after hrun + subst routed + exact coordinatedBlockIfKind_success_preserves hfault + hlookupPost.1 hrun + | defn => simp only at hrun; cases hrun + | axio => simp only at hrun; cases hrun + | quot => simp only at hrun; cases hrun + | ctor => simp only at hrun; cases hrun + | recr => simp only at hrun; cases hrun + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/BlockRouting.lean b/Ix/Tc/Verify/Check/BlockRouting.lean new file mode 100644 index 000000000..a35f11f74 --- /dev/null +++ b/Ix/Tc/Verify/Check/BlockRouting.lean @@ -0,0 +1,301 @@ +import Ix.Tc.Verify.Check.BlockIdentity +import Ix.Tc.Verify.Infer.Constants + +/-! +# Soundness of production block routing + +This module follows `coordinatedBlockFor` rather than replacing it with an +abstract dispatcher. The direct definition/inductive/recursor cases return +their recorded owner. The constructor case must additionally show that the +successful concrete parent lookup is the exact catalogued inductive and that +the constructor itself belongs to that parent's exact member array. +-/ + +namespace Ix.Tc + +namespace RecM + +private theorem runTcBind {alpha beta : Type} + (x : TcM .anon alpha) (k : alpha → TcM .anon beta) + (state : TcState .anon) : + (x >>= k) state = match x state with + | .ok value after => k value after + | .error err after => .error err after := by + show EStateM.bind x k state = _ + unfold EStateM.bind + cases x state <;> rfl + +/-- `coordinatedBlockIfKind` can fail or return `none`, but any successful +`some` result is exactly its input block key. -/ +theorem coordinatedBlockIfKind_some_eq + (candidate result : KId .anon) (expected : CheckBlockKind) + (methods : Methods .anon) (before after : TcState .anon) + (hrun : (coordinatedBlockIfKind candidate expected).run methods before = + .ok (some result) after) : + result = candidate := by + unfold coordinatedBlockIfKind at hrun + simp only [ReaderT.run_bind, ReaderT.run_monadLift] at hrun + rw [runTcBind] at hrun + cases hblock : (monadLift (TcM.tryGetBlock candidate) : + TcM .anon (Option (Array (KId .anon)))) before with + | error err failed => simp [hblock] at hrun + | ok found afterBlock => + rw [hblock] at hrun + cases found with + | none => + simp only at hrun + change EStateM.Result.ok none afterBlock = + EStateM.Result.ok (some result) after at hrun + cases hrun + | some members => + simp only at hrun + rw [ReaderT.run_bind, runTcBind] at hrun + cases hclass : ((classifyBlock members).try?).run methods afterBlock with + | error err failed => simp [hclass] at hrun + | ok classified afterClass => + rw [hclass] at hrun + cases classified with + | none => + simp only at hrun + change EStateM.Result.ok none afterClass = + EStateM.Result.ok (some result) after at hrun + cases hrun + | some actual => + simp only at hrun + split at hrun + · change EStateM.Result.ok (some candidate) afterClass = + EStateM.Result.ok (some result) after at hrun + cases hrun + rfl + · change EStateM.Result.ok none afterClass = + EStateM.Result.ok (some result) after at hrun + cases hrun + +/-- A successful caught classifier probe is exactly a successful execution +of the probed computation, including its post-state. -/ +private theorem tryQuestion_some_eq + {methods : Methods .anon} {x : RecM .anon α} + {before after : TcState .anon} {value : α} + (hrun : (try? x).run methods before = .ok (some value) after) : + x.run methods before = .ok value after := by + unfold try? at hrun + rw [ReaderT.run_bind] at hrun + change EStateM.bind + (EStateM.tryCatch + (EStateM.bind (x.run methods) + (fun a state => EStateM.Result.ok (some a) state)) _) + _ before = _ at hrun + unfold EStateM.bind EStateM.tryCatch at hrun + cases hx : x.run methods before with + | ok found reached => + simp only [hx] at hrun + cases hrun + rfl + | error err failed => + have hrestore : EStateM.Backtrackable.restore failed + (EStateM.Backtrackable.save before) = failed := rfl + simp only [hx, hrestore] at hrun + change EStateM.Result.ok none failed = + EStateM.Result.ok (some value) after at hrun + cases hrun + +/-- Exact internal execution selected by a successful block-kind router. +The classifier equation is exposed without its caught-error wrapper. -/ +inductive CoordinatedBlockIfKindSuccessTrace + (methods : Methods .anon) (block : KId .anon) + (expected : CheckBlockKind) (before after : TcState .anon) : Prop where + | run (members : Array (KId .anon)) (loaded : TcState .anon) : + TcM.tryGetBlock block before = .ok (some members) loaded → + (classifyBlock members).run methods loaded = .ok expected after → + CoordinatedBlockIfKindSuccessTrace methods block expected before after + +/-- Invert a successful `coordinatedBlockIfKind` call into its exact lookup +and successful homogeneous classification. -/ +theorem coordinatedBlockIfKind_success_trace + {methods : Methods .anon} {block : KId .anon} + {expected : CheckBlockKind} {before after : TcState .anon} + (hrun : (coordinatedBlockIfKind block expected).run methods before = + .ok (some block) after) : + CoordinatedBlockIfKindSuccessTrace methods block expected before after := by + unfold coordinatedBlockIfKind at hrun + simp only [ReaderT.run_bind, ReaderT.run_monadLift] at hrun + rw [runTcBind] at hrun + cases hlookup : (monadLift (TcM.tryGetBlock block) : + TcM .anon (Option (Array (KId .anon)))) before with + | error err failed => simp [hlookup] at hrun + | ok found loaded => + rw [hlookup] at hrun + cases found with + | none => + simp only at hrun + cases hrun + | some members => + simp only at hrun + rw [ReaderT.run_bind, runTcBind] at hrun + cases hclass : ((classifyBlock members).try?).run methods loaded with + | error err failed => simp [hclass] at hrun + | ok classified classifiedState => + rw [hclass] at hrun + cases classified with + | none => + simp only at hrun + cases hrun + | some actual => + simp only at hrun + split at hrun + · have hactual : actual = expected := by + cases actual <;> cases expected + all_goals first + | rfl + | (change false = true at *; contradiction) + subst actual + cases hrun + exact .run members loaded hlookup + (tryQuestion_some_eq hclass) + · cases hrun + +/-- A successful production route places the requested declaration in the +exact immutable member array of the returned block. Constructor routing is +resolved through the exact parent inductive loaded by production. + +The theorem is representation-only: neither the requested declaration nor +its peers become trusted here. -/ +theorem coordinatedBlockFor_some_exact + {trProj : RawProjRel} {world : VerifyWorld} + {id routed : KId .anon} {concrete : KConst .anon} + {methods : Methods .anon} {before after : TcState .anon} + (hcatalog : world.catalog id = some concrete) + (hblocks : ExactCoordinatedCatalog world) + (hstate : BlockStateWF trProj before world) + (hfault : TcM.LazyFaultPreserves + (fun state => BlockStateWF trProj state world)) + (hrun : (coordinatedBlockFor concrete).run methods before = + .ok (some routed) after) : + ∃ members kind, + ExactCheckBlock world routed members kind ∧ id ∈ members := by + cases concrete with + | defn name levelParams defKind safety hints levels type value leanAll owner => + have hroute : routed = owner := + coordinatedBlockIfKind_some_eq owner routed .defn methods before after + (by simpa [coordinatedBlockFor] using hrun) + subst routed + have hshape : + (KConst.defn name levelParams defKind safety hints levels type value + leanAll owner).IsMemberOfKind world.catalog owner .defn := by + rfl + obtain ⟨members, hexact, hmember⟩ := + hblocks.resolve hcatalog hshape + exact ⟨members, .defn, hexact, hmember⟩ + | recr name levelParams k isUnsafe levels params indices motives minors owner + memberIdx type rules leanAll => + have hroute : routed = owner := + coordinatedBlockIfKind_some_eq owner routed .recursor methods before + after (by simpa [coordinatedBlockFor] using hrun) + subst routed + have hshape : + (KConst.recr name levelParams k isUnsafe levels params indices + motives minors owner memberIdx type rules leanAll).IsMemberOfKind + world.catalog owner .recursor := by + rfl + obtain ⟨members, hexact, hmember⟩ := + hblocks.resolve hcatalog hshape + exact ⟨members, .recursor, hexact, hmember⟩ + | axio name levelParams isUnsafe levels type => + simp only [coordinatedBlockFor] at hrun + change EStateM.Result.ok none before = + EStateM.Result.ok (some routed) after at hrun + cases hrun + | quot name levelParams quotKind levels type => + simp only [coordinatedBlockFor] at hrun + change EStateM.Result.ok none before = + EStateM.Result.ok (some routed) after at hrun + cases hrun + | indc name levelParams levels params indices isUnsafe owner memberIdx type + ctors leanAll => + have hroute : routed = owner := + coordinatedBlockIfKind_some_eq owner routed .inductive' methods before + after (by simpa [coordinatedBlockFor] using hrun) + subst routed + have hshape : + (KConst.indc name levelParams levels params indices isUnsafe owner + memberIdx type ctors leanAll).IsMemberOfKind world.catalog owner + .inductive' := by + rfl + obtain ⟨members, hexact, hmember⟩ := + hblocks.resolve hcatalog hshape + exact ⟨members, .inductive', hexact, hmember⟩ + | ctor name levelParams isUnsafe levels parent cidx params fields type => + unfold coordinatedBlockFor at hrun + simp only [ReaderT.run_bind, ReaderT.run_monadLift] at hrun + rw [runTcBind] at hrun + cases hlookup : (monadLift (TcM.tryGetConst parent) : + TcM .anon (Option (KConst .anon))) before with + | error err failed => simp [hlookup] at hrun + | ok found afterLookup => + have hlookup' : TcM.tryGetConst parent before = + .ok found afterLookup := hlookup + have hlookupWF := TcM.tryGetConst_wf hfault parent before hstate + rw [hlookup'] at hlookupWF + have hstateLookup : BlockStateWF trProj afterLookup world := + hlookupWF.1 + rw [hlookup] at hrun + cases found with + | none => + simp only at hrun + change EStateM.Result.ok none afterLookup = + EStateM.Result.ok (some routed) after at hrun + cases hrun + | some parentConst => + have hparentLoaded : afterLookup.env.get? parent = some parentConst := + TcM.tryGetConst_success_loaded hlookup' + have hparentCatalog : world.catalog parent = some parentConst := + hstateLookup.core.loaded hparentLoaded + cases parentConst with + | defn => + simp only at hrun + change EStateM.Result.ok none afterLookup = + EStateM.Result.ok (some routed) after at hrun + cases hrun + | recr => + simp only at hrun + change EStateM.Result.ok none afterLookup = + EStateM.Result.ok (some routed) after at hrun + cases hrun + | axio => + simp only at hrun + change EStateM.Result.ok none afterLookup = + EStateM.Result.ok (some routed) after at hrun + cases hrun + | quot => + simp only at hrun + change EStateM.Result.ok none afterLookup = + EStateM.Result.ok (some routed) after at hrun + cases hrun + | @indc parentName parentLevelParams parentLevels parentParams + parentIndices parentUnsafe owner parentMemberIdx parentType + parentCtors parentLeanAll => + simp only at hrun + have hroute : routed = owner := + coordinatedBlockIfKind_some_eq owner routed .inductive' + methods afterLookup after hrun + subst routed + have hshape : + (KConst.ctor name levelParams isUnsafe levels parent cidx + params fields type).IsMemberOfKind world.catalog owner + .inductive' := by + refine ⟨KConst.indc parentName parentLevelParams parentLevels + parentParams parentIndices parentUnsafe owner parentMemberIdx + parentType parentCtors parentLeanAll, hparentCatalog, ?_⟩ + rfl + obtain ⟨members, hexact, hmember⟩ := + hblocks.resolve hcatalog hshape + exact ⟨members, .inductive', hexact, hmember⟩ + | ctor => + simp only at hrun + change EStateM.Result.ok none afterLookup = + EStateM.Result.ok (some routed) after at hrun + cases hrun + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/BlockTransaction.lean b/Ix/Tc/Verify/Check/BlockTransaction.lean new file mode 100644 index 000000000..9b7724e17 --- /dev/null +++ b/Ix/Tc/Verify/Check/BlockTransaction.lean @@ -0,0 +1,407 @@ +import Ix.Tc.Verify.Check.BlockExecution + +/-! +# Atomic coordinated-block transactions + +This module joins the operational trace of `checkCoordinatedBlock` to the +semantic admission model. The join is indexed by the exact physical member +array and by the `CheckBlockKind` returned by production classification, so +neither an unrelated array nor a different checker branch can justify a +successful verdict. + +There are exactly two currently supported semantic sources: + +* a singleton definition, whose successful K3 result supplies ordinary + declaration acceptance; and +* an inductive or recursor block, relative to the explicit inductive oracle + which E2 must construct from the corresponding production checker. + +Lean4Lean does not yet expose an atomic mutual-definition declaration, so no +constructor below decomposes a multi-definition production block into a +sequence of stronger semantic claims. +-/ + +namespace Ix.Tc + +/-- The complete checker invariant while one exact coordinated block is +active. Only structural block caches may use the additional member +authority; all reduction, inference, and definitional-equality entries remain +subject to the restrictions in `CacheEntry.ReferencesAuthorized`. -/ +structure ActiveBlockStateWF (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (members : Array (KId .anon)) (state : TcState .anon) : Prop where + blockState : BlockStateWF trProj state world + internSupport : support.CoversIntern state.env.intern + caches : CacheInvariant semantics + (CacheAuthority.coordinatedBlock world members) support state.env + equivalences : EquivManager.WF + (semantics.Equiv (CacheAuthority.coordinatedBlock world members) support) + state.equivManager + +namespace ActiveBlockStateWF + +/-- Enter temporary block authority from an ordinary stable kernel state. +The additional authority does not validate any new cache entry; it only +weakens the authority relation under which already-valid entries are viewed. +Exact loaded-block agreement is supplied separately because the legacy K1/K2 +kernel invariant intentionally tracks constants but not block arrays. -/ +theorem ofKernel + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {members : Array (KId .anon)} {state : TcState .anon} + (h : KernelStateWF semantics trProj world support state) + (hblocks : LoadedBlocksAgrees world.blocks state.env) : + ActiveBlockStateWF semantics trProj world support members state := by + have hauthority : CacheAuthority.stable world ≤ + CacheAuthority.coordinatedBlock world members := by + refine ⟨VerifyWorld.LE.rfl, ?_⟩ + intro id hauthorized + rcases hauthorized with htrusted | hactive + · exact .inl htrusted + · exact False.elim hactive + exact + { blockState := ⟨h.core, hblocks⟩ + internSupport := h.internSupport + caches := h.caches.mono hauthority + equivalences := EquivManager.WF.mono + (fun hrel => semantics.equivMono hauthority hrel) h.equivalences } + +/-- Once the exact block has been admitted, eliminate temporary member +authority and publish the successful physical verdict. The result is the +ordinary stable kernel invariant in the admitted world. -/ +theorem closeSuccess + {semantics : CacheSemantics} {trProj : RawProjRel} + {beforeWorld afterWorld : VerifyWorld} {support : RunSupport} + {members : Array (KId .anon)} {block : KId .anon} + {kind : CheckBlockKind} {state : TcState .anon} + (h : ActiveBlockStateWF semantics trProj beforeWorld support members state) + (hadmission : AtomicBlockAdmission trProj beforeWorld afterWorld block + members kind) + (hstate : BlockStateWF trProj state afterWorld) : + KernelStateWF semantics trProj afterWorld support + (state.withBlockCheckResult block (.ok ())) := by + have hauthority : CacheAuthority.coordinatedBlock beforeWorld members ≤ + CacheAuthority.stable afterWorld := + CacheAuthority.coordinatedBlock_le_stable hadmission.promotion.le + hadmission.exactAfter.blockLookup hadmission.accepted + refine ⟨(BlockStateWF.withBlockCheckResult hstate block (.ok ())).core, + ?_, ?_, ?_⟩ + · simpa [TcState.withBlockCheckResult] using h.internSupport + · simpa [TcState.withBlockCheckResult] using + hadmission.closeCacheSuccess h.caches + · have hequiv := EquivManager.WF.mono + (fun hrel => semantics.equivMono hauthority hrel) h.equivalences + simpa [TcState.withBlockCheckResult] using hequiv + +end ActiveBlockStateWF + +/-! ## Semantic evidence tied to one classified array -/ + +/-- Semantic evidence admitted by E0. Its indices are the production array +and classified kind; this rules out pairing an operational trace with a +certificate for a different block shape. + +The singleton-definition constructor retains the actual K3 checker result, +not merely an assumed `VDecl.WF`. The oracle-backed constructor is limited +definitionally to inductive/recursor kinds and remains the named E2 boundary. +-/ +inductive BlockAdmissionEvidence (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (block : KId .anon) : + Array (KId .anon) → CheckBlockKind → Prop + | singletonDefinition {id : KId .anon} {concrete : KConst .anon} + {decl : Lean4Lean.VDecl} : + PendingDecl trProj world id decl → + StandaloneCheckResult trProj world support id concrete decl → + BlockAdmissionEvidence trProj world support block #[id] .defn + | oracleBacked {members : Array (KId .anon)} + {kind : CheckBlockKind} : + kind.OracleBacked → + (oracle : InductiveOracle trProj world.catalog world.nameOf + world.trusted world.venv) → + (∀ id, oracle.members id ↔ id ∈ members) → + BlockAdmissionEvidence trProj world support block members kind + +namespace BlockAdmissionEvidence + +/-- Turn supported semantic evidence into one exact ghost admission. No +concrete mutation occurs here; the post-state relation is obtained by +rebasing the same concrete state across the proved world extension. -/ +theorem admit + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {block : KId .anon} {members : Array (KId .anon)} + {kind : CheckBlockKind} {state : TcState .anon} + (evidence : BlockAdmissionEvidence trProj world support block members kind) + (hexact : ExactCheckBlock world block members kind) + (hstate : BlockStateWF trProj state world) : + ∃ after, + AtomicBlockAdmission trProj world after block members kind ∧ + BlockStateWF trProj state after := by + cases evidence with + | singletonDefinition hpending checked => + let certificate : SingletonDefinitionCertificate trProj world block _ _ := + { exactBlock := hexact + pending := hpending + accepted := checked.accepted } + obtain ⟨after, hadmission, hafter, _⟩ := certificate.admit hstate + exact ⟨after, hadmission, hafter⟩ + | @oracleBacked members kind horacleBacked oracle hmembers => + let certificate : OracleBlockCertificate trProj world block members kind := + { oracleBacked := horacleBacked + exactBlock := hexact + oracle := oracle + memberIff := hmembers } + have h := certificate.admitState hstate + exact ⟨world.admitOracle oracle, h.1, h.2⟩ + +end BlockAdmissionEvidence + +/-- A successful fresh body together with the exact operational and semantic +resources needed to commit it. `trace` is the real production lookup, +classification, and classified-branch run; it is not an abstract callback +result. -/ +structure CertifiedBlockBodySuccess + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (methods : Methods .anon) + (block requested : KId .anon) (members : Array (KId .anon)) + (kind : CheckBlockKind) (before after : TcState .anon) : Prop where + trace : RecM.ExactBlockBodySuccessTrace methods block requested members kind + before after + exactBlock : ExactCheckBlock world block members kind + activePost : ActiveBlockStateWF semantics trProj world support members after + evidence : BlockAdmissionEvidence trProj world support block members kind + +namespace CertifiedBlockBodySuccess + +/-- Commit a certified fresh body, preserving the exact production trace and +closing in a stable state only after semantic admission. -/ +theorem commit + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {methods : Methods .anon} + {block requested : KId .anon} {members : Array (KId .anon)} + {kind : CheckBlockKind} {before after : TcState .anon} + (certificate : CertifiedBlockBodySuccess semantics trProj world support + methods block requested members kind before after) : + ∃ admittedWorld, + AtomicBlockAdmission trProj world admittedWorld block members kind ∧ + KernelStateWF semantics trProj admittedWorld support + (after.withBlockCheckResult block (.ok ())) := by + obtain ⟨admittedWorld, hadmission, hstate⟩ := + certificate.evidence.admit certificate.exactBlock + certificate.activePost.blockState + exact ⟨admittedWorld, hadmission, + certificate.activePost.closeSuccess hadmission hstate⟩ + +end CertifiedBlockBodySuccess + +/-! ## Post-admission cache validation + +An inductive checker may construct reduction and inference memo entries whose +results mention declarations in the block being checked. Those entries are +not sound in the pre-admission world, and production does not expose the +intermediate body state to another check: semantic admission and publication +of the block verdict form one atomic close. + +`CertifiedAdmittedBlockBodySuccess` is the corresponding proof shape. It +retains the exact production body trace, but validates the complete physical +post-state directly in the exact admitted world. This avoids the false +requirement that newly generated reduction entries already be meaningful +before their family has entered the Theory environment. -/ + +/-- An exact successful body together with its exact semantic admission and +the complete post-state invariant in that admitted world. -/ +structure CertifiedAdmittedBlockBodySuccess + (semantics : CacheSemantics) (trProj : RawProjRel) + (world admittedWorld : VerifyWorld) (support : RunSupport) + (methods : Methods .anon) (block requested : KId .anon) + (members : Array (KId .anon)) (kind : CheckBlockKind) + (before after : TcState .anon) : Prop where + trace : RecM.ExactBlockBodySuccessTrace methods block requested members kind + before after + admission : AtomicBlockAdmission trProj world admittedWorld block members + kind + post : KernelStateWF semantics trProj admittedWorld support after + +namespace CertifiedAdmittedBlockBodySuccess + +/-- Publish the successful physical verdict after the post-state has already +been validated in the exact admitted world. -/ +theorem commit + {semantics : CacheSemantics} {trProj : RawProjRel} + {world admittedWorld : VerifyWorld} {support : RunSupport} + {methods : Methods .anon} {block requested : KId .anon} + {members : Array (KId .anon)} {kind : CheckBlockKind} + {before after : TcState .anon} + (certificate : CertifiedAdmittedBlockBodySuccess semantics trProj world + admittedWorld support methods block requested members kind before + after) : + KernelStateWF semantics trProj admittedWorld support + (after.withBlockCheckResult block (.ok ())) := by + refine ⟨certificate.post.core.of_consts_eq rfl ?_, ?_, ?_, ?_⟩ + · simpa [TcState.withBlockCheckResult] using certificate.post.core.intern + · simpa [TcState.withBlockCheckResult] using certificate.post.internSupport + · simpa [TcState.withBlockCheckResult] using + certificate.post.caches.insertBlockSuccess + certificate.admission.accepted + · simpa [TcState.withBlockCheckResult] using certificate.post.equivalences + +end CertifiedAdmittedBlockBodySuccess + +/-! ## Stable result publication -/ + +namespace KernelStateWF + +/-- Publishing a failed block verdict preserves the exact semantic world. +An error result has unconditional cache provenance and carries no declaration +acceptance claim. -/ +theorem withBlockError + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {state : TcState .anon} + (h : KernelStateWF semantics trProj world support state) + (block : KId .anon) (err : TcError .anon) : + KernelStateWF semantics trProj world support + (state.withBlockCheckResult block (.error err)) := by + refine ⟨h.core.of_consts_eq rfl h.core.intern, ?_, ?_, ?_⟩ + · simpa [TcState.withBlockCheckResult] using h.internSupport + · simpa [TcState.withBlockCheckResult] using + h.caches.insertBlockError (block := block) (err := err) + · simpa [TcState.withBlockCheckResult] using h.equivalences + +end KernelStateWF + +/-- Exhaustive semantic result of a successful production coordinated call. +A cache hit reuses an already accepted block in the same world. A fresh run +contains the exact body certificate and one atomic world admission. -/ +inductive CoordinatedBlockAccepted + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (methods : Methods .anon) + (block requested : KId .anon) (before after : TcState .anon) : Prop + | replay : + before.env.blockCheckResults[block]? = some (.ok ()) → + after = before → + world.AcceptedBlock block → + KernelStateWF semantics trProj world support after → + CoordinatedBlockAccepted semantics trProj world support methods block + requested before after + | fresh {members : Array (KId .anon)} {kind : CheckBlockKind} + {bodyAfter : TcState .anon} {admittedWorld : VerifyWorld} : + before.env.blockCheckResults[block]? = none → + CertifiedBlockBodySuccess semantics trProj world support methods block + requested members kind before bodyAfter → + AtomicBlockAdmission trProj world admittedWorld block members kind → + after = bodyAfter.withBlockCheckResult block (.ok ()) → + KernelStateWF semantics trProj admittedWorld support after → + CoordinatedBlockAccepted semantics trProj world support methods block + requested before after + +namespace CoordinatedBlockAccepted + +/-- Every successful path ends with an accepted exact block: by cache +provenance on replay, or by the fresh atomic admission. -/ +theorem accepted + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {methods : Methods .anon} + {block requested : KId .anon} {before after : TcState .anon} + (h : CoordinatedBlockAccepted semantics trProj world support methods block + requested before after) : + ∃ admittedWorld, world ≤ admittedWorld ∧ + admittedWorld.AcceptedBlock block := by + cases h with + | replay _ _ haccepted _ => + exact ⟨world, VerifyWorld.LE.rfl, haccepted⟩ + | fresh _ _ hadmission _ _ => + exact ⟨_, hadmission.promotion.le, hadmission.accepted⟩ + +end CoordinatedBlockAccepted + +namespace RecM + +/-- Production success is all-or-nothing relative to a verifier for the +fresh classified body. The verifier receives the exact trace extracted +from this very run; in particular it cannot certify a different kind or +member array. -/ +theorem checkCoordinatedBlock_accepted + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {methods : Methods .anon} + {block requested : KId .anon} {before after : TcState .anon} + (hbefore : KernelStateWF semantics trProj world support before) + (certify : ∀ {members : Array (KId .anon)} + {kind : CheckBlockKind} {bodyAfter : TcState .anon}, + ExactBlockBodySuccessTrace methods block requested members kind before + bodyAfter → + CertifiedBlockBodySuccess semantics trProj world support methods block + requested members kind before bodyAfter) + (hrun : (checkCoordinatedBlock block requested).run methods before = + .ok () after) : + CoordinatedBlockAccepted semantics trProj world support methods block + requested before after := by + cases checkCoordinatedBlock_success_trace hrun with + | cached hhit hafter => + subst after + exact .replay hhit rfl + (hbefore.caches.acceptedBlock_of_success_hit hhit) hbefore + | @fresh bodyAfter hmiss hbody hafter => + obtain ⟨members, kind, htrace⟩ := checkBlockBody_success_trace hbody + let certificate := certify htrace + obtain ⟨admittedWorld, hadmission, hfinal⟩ := certificate.commit + exact .fresh hmiss certificate hadmission hafter + (hafter ▸ hfinal) + +end RecM + +/-- Exhaustive semantic result of a failing coordinated call. Both cases +retain the same verification world; the fresh case records the actual body +failure and publishes only an error cache entry. -/ +inductive CoordinatedBlockRejected + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (methods : Methods .anon) + (block requested : KId .anon) (before : TcState .anon) + (err : TcError .anon) (after : TcState .anon) : Prop + | replay : + before.env.blockCheckResults[block]? = some (.error err) → + after = before → + KernelStateWF semantics trProj world support after → + CoordinatedBlockRejected semantics trProj world support methods block + requested before err after + | fresh {failed : TcState .anon} : + before.env.blockCheckResults[block]? = none → + (RecM.captureBlockCheckResult block requested).run methods before = + .ok (.error err) failed → + (RecM.checkBlockBody block requested).run methods before = + .error err failed → + after = failed.withBlockCheckResult block (.error err) → + KernelStateWF semantics trProj world support after → + CoordinatedBlockRejected semantics trProj world support methods block + requested before err after + +namespace RecM + +/-- Production failure cannot perform semantic admission. A verifier for +the exact partial-error state is sufficient to re-establish the stable +invariant after the unconditional error-only cache insertion; the world in +the conclusion is definitionally the original world. -/ +theorem checkCoordinatedBlock_rejected + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {methods : Methods .anon} + {block requested : KId .anon} {before after : TcState .anon} + {err : TcError .anon} + (hbefore : KernelStateWF semantics trProj world support before) + (errorFrame : ∀ {failed : TcState .anon} {caught : TcError .anon}, + (checkBlockBody block requested).run methods before = + .error caught failed → + KernelStateWF semantics trProj world support failed) + (hrun : (checkCoordinatedBlock block requested).run methods before = + .error err after) : + CoordinatedBlockRejected semantics trProj world support methods block + requested before err after := by + cases checkCoordinatedBlock_error_trace hrun with + | cached hhit hafter => + subst after + exact .replay hhit rfl hbefore + | @fresh failed hmiss hcapture hbody hafter => + have hfailed := errorFrame hbody + have hfinal := hfailed.withBlockError block err + exact .fresh hmiss hcapture hbody hafter (hafter ▸ hfinal) + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/BoundedPipelines.lean b/Ix/Tc/Verify/Check/BoundedPipelines.lean new file mode 100644 index 000000000..30055a116 --- /dev/null +++ b/Ix/Tc/Verify/Check/BoundedPipelines.lean @@ -0,0 +1,474 @@ +import Ix.Tc.Verify.Check.CheckerEvidence +import Ix.Tc.Verify.Check.FullInferenceKnot +import Ix.Tc.Verify.Check.RecursiveMethodPolicy +import Ix.Tc.Verify.RecursiveMethods.CallDomains + +/-! +# Bounded standalone-checker pipelines + +The legacy K3 checker proof quantified strong full inference over every +expression in one finite `RunSupport`. That is too strong: a successful sort +inference places its successor sort in the result footprint, and reusing the +same footprint as the next input domain demands an infinite successor tower. + +This module separates the two roles. `RunSupport` remains the finite state, +cache, collision, and result footprint. `Methods.FullInferenceWFAtOn` +restricts the stronger pretranslation-to-typing contract to one explicit +method-call domain. `StandalonePipelineResources` then records only the +type/value calls made by one concrete standalone declaration and the bounded +follow-up calls made on their results. +-/ + +namespace Ix.Tc + +namespace Methods + +namespace CallDomain + +/-- `ensureSortDirect` performs no recursive WHNF call when its input is +already syntactically a sort. Every other input must be admitted by the +domain's WHNF component. -/ +def AdmitsEnsureSortDirect (calls : CallDomain) : KExpr .anon → Prop + | .sort _ _ => True + | source => calls.whnf source + +end CallDomain + +/-- Strong K3 inference, restricted to the inference calls admitted at one +finite method-table depth. Unlike ordinary C1A inference, the premise is an +untyped `PreTrKExprS` and the successful postcondition constructs the typed +translation. -/ +def FullInferenceWFAtOn + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) + (calls : CallDomain) (methods : Methods .anon) : Prop := + ∀ {Delta : KVLCtx} {s : TcState .anon} + {source : KExpr .anon} {sourceV : Lean4Lean.VExpr}, + calls.infer source → + s.inferOnly = false → + PreTrKExprS world.venv uvars world.nameOf trProj Delta source sourceV → + TcM.WF + (WhnfStateInv .noAccel semantics trProj world support uvars Delta) s + (methods.infer source) + (fun result after => + after.inferOnly = false ∧ + FullInferPost trProj world support uvars Delta source sourceV + result) + (fun _ after => after.inferOnly = false) + +namespace FullInferenceWFAtOn + +/-- Ordinary bounded inference already implies the stronger K3 contract on +an input domain whose pretranslations can be upgraded without running the +checker. This covers syntax-directed typed leaves such as sorts while +retaining the independent inference-policy frame on both outcomes. -/ +theorem ofTypedIngress + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {calls : CallDomain} {methods : Methods .anon} + (semantic : Methods.WFAtOn .noAccel semantics trProj world support + uvars calls methods) + (policy : methods.PreservesInferOnly) + (upgrade : ∀ {Delta : KVLCtx} {source : KExpr .anon} + {sourceV : Lean4Lean.VExpr}, + calls.infer source → + PreTrKExprS world.venv uvars world.nameOf trProj Delta source sourceV → + TrKExprS world.venv uvars world.nameOf trProj Delta source sourceV) : + Methods.FullInferenceWFAtOn semantics trProj world support uvars calls + methods := by + intro Delta s source sourceV hcall hbefore hsource + have htyped := upgrade hcall hsource + apply TcM.WF.mono + (TcM.PreservesInferOnly.strengthenWFValue + (semantic.infer hcall htyped) (policy.infer source) hbefore) + · intro _ _ post + exact ⟨post.1, FullInferPost.of_typed htyped post.2⟩ + · intro _ _ post + exact post.1 + +/-- A singleton sort domain is a typed-ingress domain: its `PreTrKExprS` +constructor already contains the level well-formedness needed by +`TrKExprS.sort`. -/ +theorem ofSingletonSort + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {u : KUniv .anon} {info : ExprInfo .anon} {methods : Methods .anon} + (semantic : Methods.WFAtOn .noAccel semantics trProj world support + uvars (.singletonInfer (.sort u info)) methods) + (policy : methods.PreservesInferOnly) : + Methods.FullInferenceWFAtOn semantics trProj world support uvars + (.singletonInfer (.sort u info)) methods := by + apply ofTypedIngress semantic policy + intro Delta source sourceV hcall hsource + change source = .sort u info at hcall + subst source + cases hsource with + | sort hu => exact .sort hu + +/-- Restrict the legacy all-support strong contract to an explicit call +domain. This is a migration adapter; new public results consume the bounded +contract directly. -/ +theorem ofFullInferenceWFAt + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {calls : CallDomain} {methods : Methods .anon} + (within : calls.Within support) + (contract : Methods.FullInferenceWFAt semantics trProj world support + uvars methods) : + Methods.FullInferenceWFAtOn semantics trProj world support uvars calls + methods := by + intro Delta s source sourceV hcall hpolicy hsource + exact contract hpolicy (within.infer hcall) hsource + +/-- The exhausted method table satisfies the strong contract for every +bounded domain because its inference field throws without changing state. -/ +theorem methodsOut + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) + (calls : CallDomain) : + Methods.FullInferenceWFAtOn semantics trProj world support uvars calls + (Ix.Tc.methodsOut : Methods .anon) := by + intro Delta s source sourceV hcall hpolicy hsource + exact TcM.WF.throw fun _ => hpolicy + +end FullInferenceWFAtOn + +end Methods + +/-- Declaration-local resources for the two production checker pipelines. + +`calls` is the successor-layer domain: `checkConstMember` executes +`RecM.infer`, `RecM.whnf`, and `RecM.isDefEq` over `methods`, which are exactly +the fields of `Methods.next methods`. The two source predicates need not be +closed under results; the explicit `typeWhnf` and `valueDefEq` fields admit +only the follow-up calls actually made by the pipelines. -/ +structure StandalonePipelineResources + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) + (calls : Methods.CallDomain) (methods : Methods .anon) : Type where + fullInference : Methods.FullInferenceWFAtOn semantics trProj world support + uvars calls (Methods.next methods) + sorts : SortComponentResources support + typeSources : KExpr .anon → Prop + valueSources : KExpr .anon → KExpr .anon → Prop + typeInfer : ∀ {source}, typeSources source → calls.infer source + valueInfer : ∀ {value declaredType}, + valueSources value declaredType → calls.infer value + typeWhnf : ∀ {Delta : KVLCtx} {source : KExpr .anon} + {sourceV : Lean4Lean.VExpr} {inferred : KExpr .anon}, + typeSources source → + FullInferPost trProj world support uvars Delta source sourceV inferred → + calls.AdmitsEnsureSortDirect inferred + valueDefEq : ∀ {Delta : KVLCtx} {value declaredType : KExpr .anon} + {valueV : Lean4Lean.VExpr} {inferred : KExpr .anon}, + valueSources value declaredType → + FullInferPost trProj world support uvars Delta value valueV inferred → + calls.isDefEq inferred declaredType + +namespace StandalonePipelineResources + +/-- The exact declaration roots admitted by a bounded pipeline resource. +Only standalone axioms and definition-family declarations have constructors; +the remaining production shapes belong to the later atomic-block theorem. -/ +inductive Covers + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {calls : Methods.CallDomain} {methods : Methods .anon} + (resources : StandalonePipelineResources semantics trProj world support + uvars calls methods) : KConst .anon → Prop + | axiom + {name : Mode.anon.F Name} {levelParams : Mode.anon.F (Array Name)} + {isUnsafe : Bool} {levels : UInt64} {type : KExpr .anon} : + resources.typeSources type → + Covers resources (.axio name levelParams isUnsafe levels type) + | defn + {name : Mode.anon.F Name} {levelParams : Mode.anon.F (Array Name)} + {kind : Ix.DefKind} {safety : Ix.DefinitionSafety} + {hints : Lean.ReducibilityHints} {levels : UInt64} + {type value : KExpr .anon} + {leanAll : Mode.anon.F (Array (KId .anon))} {block : KId .anon} : + resources.typeSources type → + resources.valueSources value type → + Covers resources + (.defn name levelParams kind safety hints levels type value leanAll + block) + +/-- Compatibility constructor from the legacy all-support full-inference +context. Its resulting call domain is explicitly `.support support`, making +the old over-approximation visible instead of baking it into the new public +interface. -/ +def ofFullInferenceWFAt + {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {methods : Methods .anon} + (hfull : Methods.FullInferenceWFAt semantics trProj world support uvars + (Methods.next methods)) + (hsorts : SortComponentResources support) : + StandalonePipelineResources semantics trProj world support uvars + (.support support) methods where + fullInference := Methods.FullInferenceWFAtOn.ofFullInferenceWFAt + (Methods.CallDomain.support_within support) hfull + sorts := hsorts + typeSources := support + valueSources := fun value declaredType => + support value ∧ support declaredType + typeInfer hsource := hsource + valueInfer hsource := hsource.1 + typeWhnf := by + intro Delta source sourceV inferred hsource hpost + cases inferred <;> simp [Methods.CallDomain.AdmitsEnsureSortDirect] + all_goals exact hpost.1 + valueDefEq hsource hpost := ⟨hpost.1, hsource.2⟩ + +/-- Exact resources for an axiom whose type is one concrete sort. The +result-footprint premise is intentionally representation-level: if every +possible inference result in this small fixture is syntactically a sort, +`ensureSortDirect` takes its no-callback fast path. -/ +def singletonSortAxiom + {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {u : KUniv .anon} {info : ExprInfo .anon} + {methods : Methods .anon} + (hfull : Methods.FullInferenceWFAtOn semantics trProj world support uvars + (.singletonInfer (.sort u info)) (Methods.next methods)) + (hsorts : SortComponentResources support) + (hresults : ∀ {result : KExpr .anon}, support result → + ∃ resultUniv resultInfo, result = .sort resultUniv resultInfo) : + StandalonePipelineResources semantics trProj world support uvars + (.singletonInfer (.sort u info)) methods where + fullInference := hfull + sorts := hsorts + typeSources := fun source => source = .sort u info + valueSources := fun _ _ => False + typeInfer hsource := hsource + valueInfer hsource := False.elim hsource + typeWhnf := by + intro Delta source sourceV inferred hsource hpost + obtain ⟨resultUniv, resultInfo, rfl⟩ := hresults hpost.1 + trivial + valueDefEq hsource := False.elim hsource + +end StandalonePipelineResources + +namespace RecM + +/-- Sort exposure using one explicitly admitted direct-WHNF call rather than +the legacy all-support `DirectWhnf.WFAt` callback. -/ +private theorem ensureSortDirect_wfAtOn + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {calls : Methods.CallDomain} {methods : Methods .anon} + {Delta : KVLCtx} {s : TcState .anon} {input : KExpr .anon} + {inputV : Lean4Lean.VExpr} + (hmethods : Methods.WFAtOn .noAccel semantics trProj world support uvars + calls (Methods.next methods)) + (hresources : SortComponentResources support) + (hcall : calls.AdmitsEnsureSortDirect input) + (hinputSupport : support input) + (hinput : TrKExpr world.venv uvars world.nameOf trProj Delta input + inputV) : + TcM.WF + (WhnfStateInv .noAccel semantics trProj world support uvars Delta) s + ((ensureSortDirect input).run methods) + (fun result _ => SortView world support uvars Delta inputV result) := by + obtain ⟨inputCoreV, hinputCore, hinputEq⟩ := hinput + cases input <;> simp only [ensureSortDirect, ReaderT.run_pure, pure_bind] + case sort result info => + apply TcM.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 + have hwhnf := hmethods.whnf (s := s) hcall hinputCore + simp only [Methods.next] at hwhnf + unfold ensureSortWhnf + simp only [ReaderT.run_bind] + apply TcM.WF.bind hwhnf + 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 TcM.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 TcM.WF.throw fun _ => trivial + +/-- A bounded successful type pipeline constructs the same K3 evidence as +the legacy proof, but every method call is justified by the declaration's +successor-layer call domain. -/ +theorem checkTypePipeline_bounded_sound + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {calls : Methods.CallDomain} {methods : Methods .anon} + (resources : StandalonePipelineResources semantics trProj world support + uvars calls methods) + (hmethods : Methods.WFAtOn .noAccel semantics trProj world support uvars + calls (Methods.next methods)) + (hpolicyMethods : (Methods.next methods).PreservesInferOnly) + {Delta : KVLCtx} {s after : TcState .anon} + {source : KExpr .anon} {sourceV : Lean4Lean.VExpr} + (hsourceCall : resources.typeSources source) + (hsource : PreTrKExprS world.venv uvars world.nameOf trProj Delta source + sourceV) + (hpolicy : s.inferOnly = false) + (hI : WhnfStateInv .noAccel semantics trProj world support uvars Delta s) + (hrun : + ((do + let inferred ← infer source + let _ ← ensureSortDirect inferred).run methods) s = .ok () after) : + WhnfStateInv .noAccel semantics trProj world support uvars Delta after ∧ + after.inferOnly = false ∧ + TrKExprS world.venv uvars world.nameOf trProj Delta source sourceV ∧ + TypeCheckEvidence trProj world support uvars Delta sourceV := by + have hinfer : TcM.WF + (WhnfStateInv .noAccel semantics trProj world support uvars Delta) s + ((infer source).run methods) + (fun result after => after.inferOnly = false ∧ + FullInferPost trProj world support uvars Delta source sourceV result) + (fun _ after => after.inferOnly = false) := by + simpa [Methods.next] using + resources.fullInference (resources.typeInfer hsourceCall) hpolicy hsource + have hpipeline : TcM.WF + (WhnfStateInv .noAccel semantics trProj world support uvars Delta) s + ((do + let inferred ← infer source + let _ ← ensureSortDirect inferred).run methods) + (fun _ after => after.inferOnly = false ∧ + TrKExprS world.venv uvars world.nameOf trProj Delta source sourceV ∧ + TypeCheckEvidence trProj world support uvars Delta sourceV) + (fun _ after => after.inferOnly = false) := by + simp only [ReaderT.run_bind, ReaderT.run_pure] + apply TcM.WF.bind hinfer + intro inferred afterInfer hinferred + rcases hinferred with + ⟨hpolicyAfter, hinferredSupport, hsourceTr, inferredV, + hinferredTr, hsourceType⟩ + have hfull : FullInferPost trProj world support uvars Delta source sourceV + inferred := + ⟨hinferredSupport, hsourceTr, inferredV, hinferredTr, hsourceType⟩ + have hsortSemantic := ensureSortDirect_wfAtOn (s := afterInfer) hmethods + resources.sorts (resources.typeWhnf hsourceCall hfull) + hinferredSupport hinferredTr + have hwhnfPolicy : ∀ candidate, + ((whnf candidate).run methods).PreservesInferOnly := by + intro candidate + simpa [Methods.next] using hpolicyMethods.whnf candidate + have hsort : TcM.WF + (WhnfStateInv .noAccel semantics trProj world support uvars Delta) + afterInfer ((ensureSortDirect inferred).run methods) + (fun result after => after.inferOnly = false ∧ + SortView world support uvars Delta inferredV result) + (fun _ after => after.inferOnly = false) := by + apply TcM.WF.mono + (TcM.PreservesInferOnly.strengthenWFValue hsortSemantic + (ensureSortDirect_preservesInferOnly hwhnfPolicy) hpolicyAfter) + · intro _ _ post + exact post + · intro _ _ post + exact post.1 + apply TcM.WF.bind hsort + intro sort _ hsortPost + exact TcM.WF.pure fun _ => + ⟨hsortPost.1, hsourceTr, + inferred, inferredV, hinferredTr, hsourceType, sort, hsortPost.2⟩ + have hpost := hpipeline hI + rw [hrun] at hpost + exact hpost + +/-- A bounded successful value pipeline proves that the translated value has +the declaration's advertised type. The inferred result/declared-type DefEq +call is admitted explicitly rather than by all-support quantification. -/ +theorem checkValuePipeline_bounded_sound + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {calls : Methods.CallDomain} {methods : Methods .anon} + (resources : StandalonePipelineResources semantics trProj world support + uvars calls methods) + (hmethods : Methods.WFAtOn .noAccel semantics trProj world support uvars + calls (Methods.next methods)) + {Delta : KVLCtx} {s after : TcState .anon} + {value declaredType : KExpr .anon} + {valueV declaredTypeV : Lean4Lean.VExpr} + (hvalueCall : resources.valueSources value declaredType) + (hvalue : PreTrKExprS world.venv uvars world.nameOf trProj Delta value + valueV) + (hdeclared : TrKExprS world.venv uvars world.nameOf trProj Delta + declaredType declaredTypeV) + (hpolicy : s.inferOnly = false) + (hI : WhnfStateInv .noAccel semantics trProj world support uvars Delta s) + (hrun : + ((do + let inferredType ← infer value + if !(← isDefEq inferredType declaredType) then + throw TcError.declTypeMismatch).run methods) s = .ok () after) : + WhnfStateInv .noAccel semantics trProj world support uvars Delta after ∧ + ValueCheckEvidence world uvars Delta valueV declaredTypeV := by + have hinfer : TcM.WF + (WhnfStateInv .noAccel semantics trProj world support uvars Delta) s + ((infer value).run methods) + (fun result after => after.inferOnly = false ∧ + FullInferPost trProj world support uvars Delta value valueV result) + (fun _ after => after.inferOnly = false) := by + simpa [Methods.next] using + resources.fullInference (resources.valueInfer hvalueCall) hpolicy hvalue + have hpipeline : TcM.WF + (WhnfStateInv .noAccel semantics trProj world support uvars Delta) s + ((do + let inferredType ← infer value + if !(← isDefEq inferredType declaredType) then + throw TcError.declTypeMismatch).run methods) + (fun _ _ => ValueCheckEvidence world uvars Delta valueV declaredTypeV) := by + simp only [ReaderT.run_bind] + apply TcM.WF.bind + (TcM.WF.mono hinfer (fun _ _ post => post) + (fun _ _ _ => by trivial)) + intro inferredType afterInfer hinferred + rcases hinferred with + ⟨_hpolicyAfter, hinferredSupport, hvalueTr, inferredTypeV, + hinferredTr, hvalueType⟩ + have hfull : FullInferPost trProj world support uvars Delta value valueV + inferredType := + ⟨hinferredSupport, hvalueTr, inferredTypeV, hinferredTr, hvalueType⟩ + obtain ⟨inferredCoreV, hinferredCore, hcoreEq⟩ := hinferredTr + have hdefeq : TcM.WF + (WhnfStateInv .noAccel semantics trProj world support uvars Delta) + afterInfer + ((isDefEq inferredType declaredType).run methods) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx inferredCoreV declaredTypeV) := by + simpa [Methods.next] using + hmethods.isDefEq (resources.valueDefEq hvalueCall hfull) + hinferredCore hdeclared + apply TcM.WF.bind hdefeq + intro answer _ heq + cases answer with + | false => + simp only [Bool.not_false, if_true] + exact TcM.WF.throw fun _ => trivial + | true => + simp only [Bool.not_true, Bool.false_eq] + exact TcM.WF.pure fun _ => + ⟨inferredCoreV, + hvalueType.defeqU_r world.venvWF hI.2.1.wf.toCtx hcoreEq.symm, + heq rfl⟩ + have hpost := hpipeline hI + rw [hrun] at hpost + exact hpost + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/CheckConstExecution.lean b/Ix/Tc/Verify/Check/CheckConstExecution.lean new file mode 100644 index 000000000..fb8678b0d --- /dev/null +++ b/Ix/Tc/Verify/Check/CheckConstExecution.lean @@ -0,0 +1,68 @@ +import Ix.Tc.Verify.Check.BlockRouteFrame +import Ix.Tc.Verify.Check.BlockTransaction + +/-! +# Production `checkConst` dispatch traces + +The top-level recursive driver first loads the requested declaration, routes +it, and then executes exactly one of two branches. The coordinated branch +ends at `checkCoordinatedBlock`; the standalone branch ends at +`checkConstMemberFresh`. Keeping these equations explicit prevents a proof +for one branch from being reused for the other. +-/ + +namespace Ix.Tc + +namespace RecM + +/-- Exhaustive successful execution of the production recursive driver. -/ +inductive CheckConstSuccessTrace + (methods : Methods .anon) (id : KId .anon) + (before after : TcState .anon) : Prop + | coordinated (concrete : KConst .anon) (loaded : TcState .anon) + (block : KId .anon) (routed : TcState .anon) : + TcM.getConst id before = .ok concrete loaded → + (coordinatedBlockFor concrete).run methods loaded = + .ok (some block) routed → + (checkCoordinatedBlock block id).run methods routed = .ok () after → + CheckConstSuccessTrace methods id before after + | standalone (concrete : KConst .anon) (loaded routed : TcState .anon) : + TcM.getConst id before = .ok concrete loaded → + (coordinatedBlockFor concrete).run methods loaded = .ok none routed → + (checkConstMemberFresh id).run methods routed = .ok () after → + CheckConstSuccessTrace methods id before after + +/-- Invert a successful production `checkConst` run into its exact and +exclusive coordinated/standalone branch. -/ +theorem checkConst_success_trace + {methods : Methods .anon} {id : KId .anon} + {before after : TcState .anon} + (hrun : (checkConst id).run methods before = .ok () after) : + CheckConstSuccessTrace methods id before after := by + unfold checkConst at hrun + simp only [ReaderT.run_bind, ReaderT.run_monadLift] at hrun + change EStateM.bind (TcM.getConst id) _ before = .ok () after at hrun + unfold EStateM.bind at hrun + cases hget : TcM.getConst id before with + | error err failed => + rw [hget] at hrun + contradiction + | ok concrete loaded => + rw [hget] at hrun + change EStateM.bind ((coordinatedBlockFor concrete).run methods) _ + loaded = .ok () after at hrun + unfold EStateM.bind at hrun + cases hroute : (coordinatedBlockFor concrete).run methods loaded with + | error err failed => + rw [hroute] at hrun + contradiction + | ok selected routed => + rw [hroute] at hrun + cases selected with + | none => exact .standalone concrete loaded routed hget hroute hrun + | some block => + exact .coordinated concrete loaded block routed hget hroute hrun + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/CheckConstTransaction.lean b/Ix/Tc/Verify/Check/CheckConstTransaction.lean new file mode 100644 index 000000000..5b1bc35bc --- /dev/null +++ b/Ix/Tc/Verify/Check/CheckConstTransaction.lean @@ -0,0 +1,157 @@ +import Ix.Tc.Verify.Check.CheckConstExecution + +/-! +# Semantic assembly for production `checkConst` + +This module joins the real top-level dispatcher to exact coordinated-block +admission. The success theorem is exhaustive: a routed call yields semantic +block acceptance; an unrouted call is returned as the standalone branch +already covered by K3. + +The body certifier is relative to the remaining checker-specific semantic +source: K3 supplies singleton definitions, while E2 supplies inductive and +recursor oracles. Before invoking it, this module proves that the body's +second block lookup and classifier selected the same ordered members and kind +as the route. Thus the certifier cannot be applied to a TOCTOU-substituted +block. +-/ + +namespace Ix.Tc + +/-- Stable kernel state plus E0's physical/ghost block-table agreement. -/ +structure CoordinatedKernelStateWF (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (state : TcState .anon) : Prop where + kernel : KernelStateWF semantics trProj world support state + blocks : LoadedBlocksAgrees world.blocks state.env + +namespace CoordinatedKernelStateWF + +theorem blockState + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {state : TcState .anon} + (h : CoordinatedKernelStateWF semantics trProj world support state) : + BlockStateWF trProj state world := + ⟨h.kernel.core, h.blocks⟩ + +end CoordinatedKernelStateWF + +/-- Exhaustive semantic disposition of a successful production call. The +standalone constructor is intentionally operational: its semantic result is +the existing K3 theorem, with declaration-specific premises. -/ +inductive CheckConstSuccessDisposition + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (methods : Methods .anon) + (id : KId .anon) (before after : TcState .anon) : Prop + | coordinated {concrete : KConst .anon} {loaded routed : TcState .anon} + {block : KId .anon} {members : Array (KId .anon)} + {kind : CheckBlockKind} : + TcM.getConst id before = .ok concrete loaded → + (RecM.coordinatedBlockFor concrete).run methods loaded = + .ok (some block) routed → + ExactCheckBlock world block members kind → + id ∈ members → + CoordinatedBlockAccepted semantics trProj world support methods block id + routed after → + CheckConstSuccessDisposition semantics trProj world support methods id + before after + | standalone {concrete : KConst .anon} {loaded routed : TcState .anon} : + TcM.getConst id before = .ok concrete loaded → + (RecM.coordinatedBlockFor concrete).run methods loaded = + .ok none routed → + (RecM.checkConstMemberFresh id).run methods routed = .ok () after → + CheckConstSuccessDisposition semantics trProj world support methods id + before after + +namespace CheckConstSuccessDisposition + +/-- In the coordinated case, the requested declaration itself is trusted in +the admitted world. The standalone case is excluded explicitly rather than +silently treating member checking as block admission. -/ +theorem coordinated_trusted + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {methods : Methods .anon} + {id : KId .anon} {before after : TcState .anon} + (h : CheckConstSuccessDisposition semantics trProj world support methods + id before after) + (hcoordinated : ∀ {concrete : KConst .anon} {loaded routed : TcState .anon}, + TcM.getConst id before = .ok concrete loaded → + (RecM.coordinatedBlockFor concrete).run methods loaded = + .ok none routed → False) : + ∃ admittedWorld, world ≤ admittedWorld ∧ admittedWorld.trusted id := by + cases h with + | @coordinated concrete loaded routed block members kind hget hroute hexact + hmember haccepted => + obtain ⟨admittedWorld, hle, hblock⟩ := haccepted.accepted + exact ⟨admittedWorld, hle, + (hexact.rebaseWorld hle).trusted hblock hmember⟩ + | @standalone concrete loaded routed hget hroute hmember => + exact False.elim (hcoordinated hget hroute) + +end CheckConstSuccessDisposition + +namespace RecM + +/-- Assemble the real `checkConst` success path. `certify` is invoked only +after the route's exact block has been matched against the body's actual +lookup and classification. -/ +theorem checkConst_success_disposition + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {methods : Methods .anon} + {id : KId .anon} {before after : TcState .anon} + (hbefore : CoordinatedKernelStateWF semantics trProj world support before) + (hexactCatalog : ExactCoordinatedCatalog world) + (hfault : TcM.LazyFaultPreserves + (CoordinatedKernelStateWF semantics trProj world support)) + (hfaultBlock : TcM.LazyFaultPreserves + (fun state => BlockStateWF trProj state world)) + (certify : ∀ {block : KId .anon} + {members : Array (KId .anon)} {kind : CheckBlockKind} + {routed bodyAfter : TcState .anon}, + ExactCheckBlock world block members kind → + id ∈ members → + ExactBlockBodySuccessTrace methods block id members kind routed + bodyAfter → + CertifiedBlockBodySuccess semantics trProj world support methods block + id members kind routed bodyAfter) + (hrun : (checkConst id).run methods before = .ok () after) : + CheckConstSuccessDisposition semantics trProj world support methods id + before after := by + cases checkConst_success_trace hrun with + | coordinated concrete loaded block routed hget hroute hcoordinated => + have hgetPost := TcM.getConst_loaded_wf hfault id before hbefore + rw [hget] at hgetPost + have hcatalog : world.catalog id = some concrete := + hgetPost.1.kernel.core.loaded hgetPost.2 + have hroutePost := coordinatedBlockFor_some_preserves hfault hgetPost.1 + hroute + obtain ⟨members, kind, hexact, hmember⟩ := + coordinatedBlockFor_some_exact hcatalog hexactCatalog + hgetPost.1.blockState hfaultBlock hroute + have haccepted := checkCoordinatedBlock_accepted hroutePost.kernel + (fun {actualMembers} {actualKind} {bodyAfter} trace => by + cases trace with + | run bodyLoaded classified hlookup hclassification hclassified => + have hlookupPost := TcM.tryGetBlock_wf hfault block routed + hroutePost + rw [hlookup] at hlookupPost + have hphysical := TcM.tryGetBlock_success_loaded hlookup + have hworldActual := hlookupPost.1.blocks hphysical + have hmembers : actualMembers = members := + Option.some.inj (hworldActual.symm.trans hexact.blockLookup) + subst actualMembers + have hkind := classifyBlock_success_exact + (I := CoordinatedKernelStateWF semantics trProj world support) + (fun hI => hI.kernel.core.loaded) hfault hexact + hlookupPost.1 hclassification + cases hkind.2 + exact certify hexact hmember + (.run bodyLoaded classified hlookup hclassification hclassified)) + hcoordinated + exact .coordinated hget hroute hexact hmember haccepted + | standalone concrete loaded routed hget hroute hmember => + exact .standalone hget hroute hmember + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/CheckerEvidence.lean b/Ix/Tc/Verify/Check/CheckerEvidence.lean new file mode 100644 index 000000000..adc4a0035 --- /dev/null +++ b/Ix/Tc/Verify/Check/CheckerEvidence.lean @@ -0,0 +1,174 @@ +import Ix.Tc.Verify.Check.Acceptance +import Ix.Tc.Verify.Check.FullInferenceCache + +/-! +# Semantic evidence from the standalone checker pipelines + +This module connects the two sequential computation fragments used by +`checkConstMember` to the declaration-local evidence consumed by acceptance. +The inference premise is K3's stronger full-mode contract: it starts from a +raw pretranslation and establishes the typed structural translation itself. + +The value pipeline is parameterized by the semantic contract for the actual +`RecM.isDefEq` entry point. This is intentionally not the smaller-table +`methods.isDefEq` callback used inside recursive inference. +-/ + +namespace Ix.Tc + +namespace RecM + +/-- A successful execution of the production type-checking fragment retains +full-inference mode and proves that the source translates to a Theory type. -/ +theorem checkTypePipeline_sound + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {model : KernelSuffixModel trProj world} {methods : Methods .anon} + (context : FullUncachedInference.Context initial program requests + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars methods) + {Delta : KVLCtx} {s after : TcState .anon} + {source : KExpr .anon} {sourceV : Lean4Lean.VExpr} + (hsourceSupport : support source) + (hsource : PreTrKExprS world.venv model.keys.uvars world.nameOf trProj + Delta source sourceV) + (hpolicy : s.inferOnly = false) + (hI : WhnfStateInv .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars Delta s) + (hrun : + ((do + let inferred ← infer source + let _ ← ensureSortDirect inferred).run methods) s = .ok () after) : + WhnfStateInv .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars Delta after ∧ + after.inferOnly = false ∧ + TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta + source sourceV ∧ + TypeCheckEvidence trProj world support model.keys.uvars Delta + sourceV := by + have hinfer := infer_full_wf context hsourceSupport hsource hpolicy + have hpipeline : + TcM.WF + (WhnfStateInv .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars Delta) s + ((do + let inferred ← infer source + let _ ← ensureSortDirect inferred).run methods) + (fun _ after => after.inferOnly = false ∧ + TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta + source sourceV ∧ + TypeCheckEvidence trProj world support model.keys.uvars Delta + sourceV) + (fun _ after => after.inferOnly = false) := by + simp only [ReaderT.run_bind] + apply TcM.WF.bind + (TcM.WF.mono hinfer (fun _ _ post => post) + (fun _ _ post => post)) + intro inferred afterInfer hinferred + rcases hinferred with + ⟨hpolicyAfter, hinferredSupport, hsourceTr, inferredV, + hinferredTr, hsourceType⟩ + apply TcM.WF.bind + (context.callbacks.ensureSort hpolicyAfter hinferredSupport hinferredTr) + intro sort _ hsort + rcases hsort with ⟨hpolicySort, hsort⟩ + exact TcM.WF.pure fun _ => + ⟨hpolicySort, + hsourceTr, + inferred, inferredV, hinferredTr, hsourceType, sort, hsort⟩ + have hpost := hpipeline hI + rw [hrun] at hpost + exact hpost + +/-- A successful execution of the production value-checking fragment +preserves the checker invariant and proves that the translated value has the +declaration's advertised Theory type. -/ +theorem checkValuePipeline_sound + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {model : KernelSuffixModel trProj world} {methods : Methods .anon} + (context : FullUncachedInference.Context initial program requests + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars methods) + (hdefeq : ∀ {Delta : KVLCtx} {s : TcState .anon} + {left right : KExpr .anon} {leftV rightV : Lean4Lean.VExpr}, + support left → support right → + TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta left + leftV → + TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta right + rightV → + RecM.WF .noAccel (kernelCacheSemantics model.keys trProj) trProj world + support model.keys.uvars Delta s (isDefEq left right) + (fun answer _ => answer = true → + world.venv.IsDefEqU model.keys.uvars Delta.toCtx leftV rightV)) + {Delta : KVLCtx} {s after : TcState .anon} + {value declaredType : KExpr .anon} + {valueV declaredTypeV : Lean4Lean.VExpr} + (hvalueSupport : support value) + (hdeclaredSupport : support declaredType) + (hvalue : PreTrKExprS world.venv model.keys.uvars world.nameOf trProj + Delta value valueV) + (hdeclared : TrKExprS world.venv model.keys.uvars world.nameOf trProj + Delta declaredType declaredTypeV) + (hpolicy : s.inferOnly = false) + (hI : WhnfStateInv .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars Delta s) + (hrun : + ((do + let inferredType ← infer value + if !(← isDefEq inferredType declaredType) then + throw TcError.declTypeMismatch).run methods) s = .ok () after) : + WhnfStateInv .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars Delta after ∧ + ValueCheckEvidence world model.keys.uvars Delta valueV + declaredTypeV := by + have hinfer := infer_full_wf context hvalueSupport hvalue hpolicy + have hpipeline : + TcM.WF + (WhnfStateInv .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars Delta) s + ((do + let inferredType ← infer value + if !(← isDefEq inferredType declaredType) then + throw TcError.declTypeMismatch).run methods) + (fun _ _ => + ValueCheckEvidence world model.keys.uvars Delta valueV + declaredTypeV) := by + simp only [ReaderT.run_bind] + apply TcM.WF.bind + (TcM.WF.mono hinfer (fun _ _ post => post) + (fun _ _ _ => by trivial)) + intro inferredType _ hinferred + rcases hinferred with + ⟨_hpolicyAfter, hinferredSupport, _hvalueTr, inferredTypeV, + hinferredTr, hvalueType⟩ + obtain ⟨inferredCoreV, hinferredCore, hcoreEq⟩ := hinferredTr + apply TcM.WF.bind + ((hdefeq hinferredSupport hdeclaredSupport hinferredCore hdeclared) + methods context.methodSemantics) + intro answer _ heq + cases answer with + | false => + simp only [Bool.not_false, if_true] + exact TcM.WF.throw fun _ => trivial + | true => + simp only [Bool.not_true, Bool.false_eq] + exact TcM.WF.pure fun _ => + ⟨inferredCoreV, + hvalueType.defeqU_r world.venvWF hI.2.1.wf.toCtx hcoreEq.symm, + heq rfl⟩ + have hpost := hpipeline hI + rw [hrun] at hpost + exact hpost + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/DeclarationIngress.lean b/Ix/Tc/Verify/Check/DeclarationIngress.lean new file mode 100644 index 000000000..b2d89361c --- /dev/null +++ b/Ix/Tc/Verify/Check/DeclarationIngress.lean @@ -0,0 +1,124 @@ +import Ix.Tc.Verify.Check.PreTranslationIngress + +/-! +# Standalone declaration ingress + +This module packages the expression-level raw-to-`PreTrKExprS` theorem at the +declaration boundary. `StandaloneScope` is exactly the syntax and arithmetic +certificate that the production `validateConstWellScoped` proof must return +for axioms and definitions. `PreDeclRel` is the untyped declaration relation +consumed by the two `checkConstMember` pipelines. + +Neither relation contains a typing judgment or a declaration-WF premise. +-/ + +namespace Ix.Tc + +open Lean4Lean (VDecl VExpr) + +/-- Successful standalone validation facts, including the no-wrap budget +needed to interpret the validator's `UInt64` binder depth. -/ +inductive StandaloneScope : KConst .anon -> Prop + | axiom + {name : Mode.anon.F Name} {levelParams : Mode.anon.F (Array Name)} + {isUnsafe : Bool} {levels : UInt64} {type : KExpr .anon} : + type.Scoped 0 levels.toNat -> + type.size < UInt64.size -> + StandaloneScope (.axio name levelParams isUnsafe levels type) + | defn + {name : Mode.anon.F Name} {levelParams : Mode.anon.F (Array Name)} + {kind : Ix.DefKind} {safety : Ix.DefinitionSafety} + {hints : Lean.ReducibilityHints} {levels : UInt64} + {type value : KExpr .anon} + {leanAll : Mode.anon.F (Array (KId .anon))} {block : KId .anon} : + type.Scoped 0 levels.toNat -> + type.size < UInt64.size -> + value.Scoped 0 levels.toNat -> + value.size < UInt64.size -> + StandaloneScope + (.defn name levelParams kind safety hints levels type value leanAll block) + +/-- Raw standalone correspondence after scoping validation, but before any +typing has been established. -/ +inductive PreDeclRel (env : Lean4Lean.VEnv) + (nameOf : Address -> Option Lean.Name) (trProj : RawProjRel) + (id : KId .anon) : KConst .anon -> VDecl -> Prop + | axiom + {name : Mode.anon.F Name} {levelParams : Mode.anon.F (Array Name)} + {isUnsafe : Bool} {levels : UInt64} {type : KExpr .anon} + {theoryName : Lean.Name} {typeV : VExpr} : + nameOf id.addr = some theoryName -> + PreTrKExprS env levels.toNat nameOf trProj [] type typeV -> + PreDeclRel env nameOf trProj id + (.axio name levelParams isUnsafe levels type) + (.axiom { name := theoryName, uvars := levels.toNat, type := typeV }) + | defn + {name : Mode.anon.F Name} {levelParams : Mode.anon.F (Array Name)} + {kind : Ix.DefKind} {safety : Ix.DefinitionSafety} + {hints : Lean.ReducibilityHints} {levels : UInt64} + {type value : KExpr .anon} + {leanAll : Mode.anon.F (Array (KId .anon))} {block : KId .anon} + {theoryName : Lean.Name} {typeV valueV : VExpr} {decl : VDecl} : + nameOf id.addr = some theoryName -> + PreTrKExprS env levels.toNat nameOf trProj [] type typeV -> + PreTrKExprS env levels.toNat nameOf trProj [] value valueV -> + RawDefKindRel + { name := theoryName, uvars := levels.toNat, + type := typeV, value := valueV } kind decl -> + PreDeclRel env nameOf trProj id + (.defn name levelParams kind safety hints levels type value leanAll block) + decl + +namespace RawDeclRel + +/-- The exact raw declaration becomes a pre-translation declaration once the +production validator's standalone certificate is available. -/ +theorem toPre_of_scope + {env : Lean4Lean.VEnv} {nameOf : Address -> Option Lean.Name} + {trProj : RawProjRel} {id : KId .anon} + (hprojection : trProj.SubstCompatible) + (hliterals : forall literal, env.ContainsLits literal) + {concrete : KConst .anon} {decl : VDecl} + (hraw : RawDeclRel env nameOf trProj id concrete decl) + (hscope : StandaloneScope concrete) : + PreDeclRel env nameOf trProj id concrete decl := by + cases hraw with + | «axiom» hname htype => + cases hscope with + | «axiom» hscoped hbound => + exact .axiom hname + (htype.toPre_of_scoped hprojection hliterals hscoped hbound) + | defn hname htype hvalue hkind => + cases hscope with + | defn htypeScoped htypeBound hvalueScoped hvalueBound => + exact .defn hname + (htype.toPre_of_scoped hprojection hliterals + htypeScoped htypeBound) + (hvalue.toPre_of_scoped hprojection hliterals + hvalueScoped hvalueBound) + hkind + +end RawDeclRel + +namespace PendingDecl + +/-- A pending standalone target plus validator evidence reaches the exact +pre-translation declaration without assuming semantic acceptance. -/ +theorem toPre_of_scope + {trProj : RawProjRel} {world : VerifyWorld} {id : KId .anon} + {decl : VDecl} + (hprojection : trProj.SubstCompatible) + (hliterals : forall literal, world.venv.ContainsLits literal) + (hpending : PendingDecl trProj world id decl) + {concrete : KConst .anon} + (hcatalog : world.catalog id = some concrete) + (hscope : StandaloneScope concrete) : + PreDeclRel world.venv world.nameOf trProj id concrete decl := by + obtain ⟨pendingConcrete, hpendingCatalog, hraw, _⟩ := hpending + rw [hcatalog] at hpendingCatalog + cases hpendingCatalog + exact hraw.toPre_of_scope hprojection hliterals hscope + +end PendingDecl + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/DeclarationValidation.lean b/Ix/Tc/Verify/Check/DeclarationValidation.lean new file mode 100644 index 000000000..db8b7cd33 --- /dev/null +++ b/Ix/Tc/Verify/Check/DeclarationValidation.lean @@ -0,0 +1,129 @@ +import Ix.Tc.Verify.Check.ValidatorSoundness +import Ix.Tc.Verify.Check.DeclarationIngress + +/-! +# Standalone declaration validation + +This module lifts expression-validator soundness to the production +`validateConstWellScoped` boundary for the standalone declaration kinds +handled by K3. Finite-run coverage and no-wrap size budgets are explicit +resources; neither is inferred from a successful validator return. +-/ + +namespace Ix.Tc + +/-- Static resources needed to interpret successful standalone validation. +The size inequalities justify transporting the validator's `UInt64` binder +depths into the unbounded raw-to-Theory scoping relation. -/ +inductive StandaloneValidationResources (support : RunSupport) : + KConst .anon → Prop + | axiom + {name : Mode.anon.F Name} {levelParams : Mode.anon.F (Array Name)} + {isUnsafe : Bool} {levels : UInt64} {type : KExpr .anon} : + type.ValidationCoverage support → + type.size < UInt64.size → + StandaloneValidationResources support + (.axio name levelParams isUnsafe levels type) + | defn + {name : Mode.anon.F Name} {levelParams : Mode.anon.F (Array Name)} + {kind : Ix.DefKind} {safety : Ix.DefinitionSafety} + {hints : Lean.ReducibilityHints} {levels : UInt64} + {type value : KExpr .anon} + {leanAll : Mode.anon.F (Array (KId .anon))} {block : KId .anon} : + type.ValidationCoverage support → + type.size < UInt64.size → + value.ValidationCoverage support → + value.size < UInt64.size → + StandaloneValidationResources support + (.defn name levelParams kind safety hints levels type value leanAll block) + +namespace RecM + +/-- Expose one concrete `TcM` bind generated by declaration validation. -/ +private theorem runTcBind {α β : Type} + (x : TcM .anon α) (k : α → TcM .anon β) + (state : TcState .anon) : + (x >>= k) state = match x state with + | .ok value after => k value after + | .error err after => .error err after := by + show EStateM.bind x k state = _ + unfold EStateM.bind + cases x state <;> rfl + +/-- Successful execution of the exact production declaration validator +establishes the standalone syntax certificate consumed by raw ingress. -/ +theorem validateConstWellScoped_sound + {support : RunSupport} {c : KConst .anon} + (hresources : StandaloneValidationResources support c) + (hcollision : support.CollisionFree) + {methods : Methods .anon} {state after : TcState .anon} + (hrun : (validateConstWellScoped c).run methods state = .ok () after) : + StandaloneScope c := by + cases hresources with + | @«axiom» name levelParams isUnsafe levels type hcoverage hsize => + unfold validateConstWellScoped at hrun + rw [ReaderT.run_bind, runTcBind] at hrun + simp only [KConst.ty, KConst.lvls] at hrun + cases htype : + (validateExprWellScoped type 0 levels.toNat).run methods state with + | error err failed => + rw [htype] at hrun + contradiction + | ok _ nextState => + rw [htype] at hrun + have hscope := validateExprWellScoped_sound hcoverage hcollision + htype + exact .axiom hscope.choose_spec.choose_spec.2 hsize + | @defn name levelParams kind safety hints levels type value leanAll block + htypeCoverage htypeSize hvalueCoverage hvalueSize => + unfold validateConstWellScoped at hrun + rw [ReaderT.run_bind, runTcBind] at hrun + simp only [KConst.ty, KConst.lvls] at hrun + cases htype : + (validateExprWellScoped type 0 levels.toNat).run methods state with + | error err failed => + rw [htype] at hrun + contradiction + | ok _ nextState => + rw [htype] at hrun + simp only at hrun + cases hvalue : + (validateExprWellScoped value 0 levels.toNat).run methods + nextState with + | error err failed => + rw [hvalue] at hrun + contradiction + | ok _ finalState => + rw [hvalue] at hrun + have htypeScope := validateExprWellScoped_sound + htypeCoverage hcollision htype + have hvalueScope := validateExprWellScoped_sound + hvalueCoverage hcollision hvalue + exact .defn htypeScope.choose_spec.choose_spec.2 htypeSize + hvalueScope.choose_spec.choose_spec.2 hvalueSize + +end RecM + +namespace PendingDecl + +/-- Exact production validation supplies the scope premise needed to move a +pending raw declaration into the pre-translation relation. -/ +theorem toPre_of_validation + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {id : KId .anon} {decl : Lean4Lean.VDecl} {concrete : KConst .anon} + (hprojection : trProj.SubstCompatible) + (hliterals : ∀ literal, world.venv.ContainsLits literal) + (hpending : PendingDecl trProj world id decl) + (hcatalog : world.catalog id = some concrete) + (hresources : StandaloneValidationResources support concrete) + (hcollision : support.CollisionFree) + {methods : Methods .anon} {state after : TcState .anon} + (hrun : (RecM.validateConstWellScoped concrete).run methods state = + .ok () after) : + PreDeclRel world.venv world.nameOf trProj id concrete decl := + hpending.toPre_of_scope hprojection hliterals hcatalog + (RecM.validateConstWellScoped_sound hresources hcollision hrun) + +end PendingDecl + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/DefEqBasicPolicy.lean b/Ix/Tc/Verify/Check/DefEqBasicPolicy.lean new file mode 100644 index 000000000..05451c52f --- /dev/null +++ b/Ix/Tc/Verify/Check/DefEqBasicPolicy.lean @@ -0,0 +1,411 @@ +import Ix.Tc.DefEq +import Ix.Tc.Verify.Check.WhnfHelperPolicy + +/-! +# Operational policy for basic definitional-equality helpers + +This module establishes the inference-policy frame for the non-recursive +DefEq substrate: recursive method calls, caught errors, cheap-reduction +scopes, primitive classifiers, Nat peeling, binder comparison, and finite +application-spine recursion. Later DefEq phase proofs build exclusively on +these concrete lemmas. +-/ + +namespace Ix.Tc + +namespace TcM.PreservesInferOnly + +/-- The let-opening variant which also returns its fresh-variable expression +has the same policy frame as ordinary let opening. -/ +theorem openLetWithFV + (name : Mode.anon.F Name) (type value body : KExpr .anon) : + (TcM.openLetWithFV name type value body).PreservesInferOnly := by + unfold TcM.openLetWithFV + apply bind freshFVarId + intro fvId + apply bind (runIntern _) + intro fv + apply bind (modify + (f := fun state => + { state with lctx := state.lctx.push fvId (.ldecl name type value) }) + fun _ => rfl) + intro _ + apply bind (runIntern (instantiateRev body #[fv])) + intro bodyOpen + exact pure (bodyOpen, fv, fvId) + +end TcM.PreservesInferOnly + +namespace RecM + +theorem prims_preservesInferOnly (methods : Methods .anon) : + ((prims : RecM .anon (Primitives .anon)).run methods).PreservesInferOnly := by + unfold prims + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind TcM.PreservesInferOnly.get + intro state + exact TcM.PreservesInferOnly.pure state.prims + +/-- A recursive DefEq edge is exactly the predecessor table's framed +callback. -/ +theorem isDefEqCall_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (left right : KExpr .anon) : + ((isDefEqCall left right).run methods).PreservesInferOnly := by + unfold isDefEqCall + simpa using hmethods.isDefEq left right + +/-- Infer-only validation restores the policy value which was in force at +the call site, irrespective of the callback outcome. -/ +theorem inferOnlyCall_preservesInferOnly + {methods : Methods .anon} (_hmethods : methods.PreservesInferOnly) + (source : KExpr .anon) : + ((inferOnlyCall source).run methods).PreservesInferOnly := by + unfold inferOnlyCall + simp only [ReaderT.run_bind] + exact TcM.PreservesInferOnly.withInferOnly (methods.infer source) + +/-- DefEq's caught-error operator retains all inner state changes but still +preserves the flag whenever its body does. -/ +theorem tryQuestion_preservesInferOnly + {methods : Methods .anon} {x : RecM .anon alpha} + (hx : (x.run methods).PreservesInferOnly) : + ((try? x).run methods).PreservesInferOnly := by + unfold try? + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind + · exact TcM.PreservesInferOnly.tryCatch + (TcM.PreservesInferOnly.bind hx + (fun value => TcM.PreservesInferOnly.pure (some value))) + (fun _ => TcM.PreservesInferOnly.pure none) + · intro result + exact TcM.PreservesInferOnly.pure result + +/-- Cheap-recursion depth is balanced by `finally`, including on errors. -/ +theorem withCheapRecursionDepth_preservesInferOnly + {methods : Methods .anon} {x : RecM .anon alpha} + (hx : (x.run methods).PreservesInferOnly) : + ((withCheapRecursionDepth x).run methods).PreservesInferOnly := by + unfold withCheapRecursionDepth + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.modify + (f := fun state : TcState .anon => { state with + cheapRecursionDepth := state.cheapRecursionDepth + 1 }) + (fun _ => rfl)) + intro _ + change (tryFinally (x.run methods) + (modify (fun state : TcState .anon => { state with + cheapRecursionDepth := state.cheapRecursionDepth - 1 }) : + TcM .anon PUnit)).PreservesInferOnly + exact TcM.PreservesInferOnly.tryFinally hx + (TcM.PreservesInferOnly.modify fun _ => rfl) + +theorem whnfCoreForDefEq_preservesInferOnly + {methods : Methods .anon} (policy : WhnfNoDeltaPolicyAt methods) + (source : KExpr .anon) : + ((whnfCoreForDefEq source).run methods).PreservesInferOnly := by + unfold whnfCoreForDefEq + exact withCheapRecursionDepth_preservesInferOnly + (whnfCoreWithFlags_preservesInferOnly policy source .DEF_EQ_CORE) + +theorem whnfNoDeltaForDefEq_preservesInferOnly + {methods : Methods .anon} (policy : WhnfNoDeltaPolicyAt methods) + (source : KExpr .anon) : + ((whnfNoDeltaForDefEq source).run methods).PreservesInferOnly := by + unfold whnfNoDeltaForDefEq + exact withCheapRecursionDepth_preservesInferOnly + (whnfNoDeltaImpl_preservesInferOnly policy source .DEF_EQ_CORE .collapse) + +theorem isNatLike_preservesInferOnly + {methods : Methods .anon} (source : KExpr .anon) : + ((isNatLike source).run methods).PreservesInferOnly := by + unfold isNatLike + refine bind_preservesInferOnly (prims_preservesInferOnly methods) ?_ + intro primitives + cases source with + | app function argument info => + cases function <;> exact TcM.PreservesInferOnly.pure _ + | var | fvar | sort | const | lam | all | letE | prj | nat | str => + exact TcM.PreservesInferOnly.pure _ + +theorem isNatZero_preservesInferOnly + {methods : Methods .anon} (source : KExpr .anon) : + ((isNatZero source).run methods).PreservesInferOnly := by + unfold isNatZero + refine bind_preservesInferOnly (prims_preservesInferOnly methods) ?_ + intro primitives + cases source <;> exact TcM.PreservesInferOnly.pure _ + +theorem natSuccOf_preservesInferOnly + {methods : Methods .anon} (source : KExpr .anon) : + ((natSuccOf source).run methods).PreservesInferOnly := by + unfold natSuccOf + refine bind_preservesInferOnly (prims_preservesInferOnly methods) ?_ + intro primitives + cases source with + | nat value blob info => + simp only + split + · exact TcM.PreservesInferOnly.pure none + · simp only [pure_bind] + refine bindIntern_preservesInferOnly + (natExprFromValue (value - 1) : KExpr .anon) ?_ + intro result + simpa using TcM.PreservesInferOnly.pure (some result) + | app function argument info => + cases function with + | const id universes headInfo => + simp only + split <;> exact TcM.PreservesInferOnly.pure _ + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + exact TcM.PreservesInferOnly.pure none + | var | fvar | sort | const | lam | all | letE | prj | str => + exact TcM.PreservesInferOnly.pure none + +theorem isBoolTrue_preservesInferOnly + {methods : Methods .anon} (source : KExpr .anon) : + ((isBoolTrue source).run methods).PreservesInferOnly := by + unfold isBoolTrue + cases source with + | const id universes info => + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind (prims_preservesInferOnly methods) + intro primitives + exact TcM.PreservesInferOnly.pure _ + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + exact TcM.PreservesInferOnly.pure false + +theorem boolTrueReductionAllowed_preservesInferOnly + {methods : Methods .anon} (source : KExpr .anon) : + ((boolTrueReductionAllowed source).run methods).PreservesInferOnly := by + unfold boolTrueReductionAllowed + simp only + split + · exact TcM.PreservesInferOnly.pure true + · simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind TcM.PreservesInferOnly.get + intro state + exact TcM.PreservesInferOnly.pure state.eagerReduce + +theorem whnfIsBoolTrue_preservesInferOnly + {methods : Methods .anon} + (hwhnf : ∀ source, + ((whnf source).run methods).PreservesInferOnly) + (source : KExpr .anon) : + ((whnfIsBoolTrue source).run methods).PreservesInferOnly := by + unfold whnfIsBoolTrue + refine bind_preservesInferOnly (hwhnf source) ?_ + exact fun normalized => isBoolTrue_preservesInferOnly normalized + +theorem isDelta_preservesInferOnly + {methods : Methods .anon} (id : KId .anon) : + ((isDelta id).run methods).PreservesInferOnly := by + unfold isDelta + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.tryGetConst id) ?_ + intro declaration + cases declaration with + | none => exact TcM.PreservesInferOnly.pure false + | some declaration => + cases declaration with + | defn name levelParams kind safety hints levels type value leanAll block => + cases kind <;> exact TcM.PreservesInferOnly.pure _ + | recr | axio | quot | indc | ctor => + exact TcM.PreservesInferOnly.pure false + +theorem classifyDeltaHead_preservesInferOnly + {methods : Methods .anon} (source : KExpr .anon) : + ((classifyDeltaHead source).run methods).PreservesInferOnly := by + unfold classifyDeltaHead + cases headConstId source with + | none => exact TcM.PreservesInferOnly.pure false + | some id => exact isDelta_preservesInferOnly id + +theorem isRegular_preservesInferOnly + {methods : Methods .anon} (id : KId .anon) : + ((isRegular id).run methods).PreservesInferOnly := by + unfold isRegular + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.tryGetConst id) ?_ + intro declaration + cases declaration with + | none => exact TcM.PreservesInferOnly.pure false + | some declaration => + cases declaration with + | defn name levelParams kind safety hints levels type value leanAll block => + cases hints <;> exact TcM.PreservesInferOnly.pure _ + | recr | axio | quot | indc | ctor => + exact TcM.PreservesInferOnly.pure false + +theorem defRankId_preservesInferOnly + {methods : Methods .anon} (id : KId .anon) : + ((defRankId id).run methods).PreservesInferOnly := by + unfold defRankId + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.tryGetConst id) ?_ + intro declaration + cases declaration with + | none => exact TcM.PreservesInferOnly.pure (0, 0) + | some declaration => + cases declaration with + | defn name levelParams kind safety hints levels type value leanAll block => + cases kind with + | opaq | thm => exact TcM.PreservesInferOnly.pure (0, 0) + | defn => + cases hints <;> exact TcM.PreservesInferOnly.pure _ + | recr | axio | quot | indc | ctor => + exact TcM.PreservesInferOnly.pure (0, 0) + +theorem rankDeltaHead_preservesInferOnly + {methods : Methods .anon} (head : Option (KId .anon)) : + ((rankDeltaHead head).run methods).PreservesInferOnly := by + cases head with + | none => exact TcM.PreservesInferOnly.pure _ + | some id => exact defRankId_preservesInferOnly id + +theorem quickBinder_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (name : Mode.anon.F Name) (bi : Mode.anon.F Lean.BinderInfo) + (ty1 body1 ty2 body2 : KExpr .anon) : + ((quickBinder name bi ty1 body1 ty2 body2).run + methods).PreservesInferOnly := by + unfold quickBinder + refine bind_preservesInferOnly + (isDefEqCall_preservesInferOnly hmethods ty1 ty2) ?_ + intro typesEqual + cases typesEqual with + | false => exact TcM.PreservesInferOnly.pure false + | true => + simp only [Bool.not_true, Bool.false_eq_true, if_false] + apply withLctxScope_preservesInferOnly + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.openBinder name bi ty1 body1) + intro opened + rcases opened with ⟨body1Open, fvId⟩ + apply TcM.PreservesInferOnly.bind + (intern_preservesInferOnly (.mkFVar fvId name)) + intro fv + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.runIntern + (instantiateRev body2 #[fv])) + intro body2Open + exact isDefEqCall_preservesInferOnly hmethods body1Open body2Open + +theorem quickDefEq_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (left right : KExpr .anon) : + ((quickDefEq left right).run methods).PreservesInferOnly := by + cases left <;> cases right <;> simp only [quickDefEq] + all_goals + first + | exact TcM.PreservesInferOnly.pure _ + | exact quickBinder_preservesInferOnly hmethods _ _ _ _ _ _ + +theorem allDefEqSpineArgsList_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) : + ∀ pairs, + ((allDefEqSpineArgsList pairs).run methods).PreservesInferOnly + | [] => TcM.PreservesInferOnly.pure true + | (left, right) :: rest => by + rw [allDefEqSpineArgsList] + refine bind_preservesInferOnly + (isDefEqCall_preservesInferOnly hmethods left right) ?_ + intro equal + cases equal with + | false => exact TcM.PreservesInferOnly.pure false + | true => + simp only [Bool.not_true, Bool.false_eq_true, if_false] + exact allDefEqSpineArgsList_preservesInferOnly hmethods rest + +theorem allDefEqSpineArgs_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (pairs : Array (KExpr .anon × KExpr .anon)) : + ((allDefEqSpineArgs pairs).run methods).PreservesInferOnly := by + unfold allDefEqSpineArgs + exact allDefEqSpineArgsList_preservesInferOnly hmethods pairs.toList + +theorem trySameHeadSpine_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (left right : KExpr .anon) : + ((trySameHeadSpine left right).run methods).PreservesInferOnly := by + rcases hleft : left.collectSpine with ⟨leftHead, leftArgs⟩ + rcases hright : right.collectSpine with ⟨rightHead, rightArgs⟩ + unfold trySameHeadSpine + simp only [hleft, hright] + cases leftHead <;> + try exact TcM.PreservesInferOnly.pure none + case const leftId leftLevels leftInfo => + cases rightHead <;> + try exact TcM.PreservesInferOnly.pure none + case const rightId rightLevels rightInfo => + cases hshape : + (leftId.addr != rightId.addr || leftArgs.size != rightArgs.size) with + | true => + simp only [hshape, if_true] + exact TcM.PreservesInferOnly.pure none + | false => + simp only [hshape, Bool.false_eq_true, if_false, pure_bind] + cases huniverses : sameDefEqUniverses leftLevels rightLevels with + | false => + simp only [Bool.not_false, if_true] + exact TcM.PreservesInferOnly.pure none + | true => + simp only [Bool.not_true, Bool.false_eq_true, if_false] + refine bind_preservesInferOnly + (allDefEqSpineArgs_preservesInferOnly hmethods + (leftArgs.zip rightArgs)) ?_ + intro accepted + cases accepted with + | false => exact TcM.PreservesInferOnly.pure none + | true => + simp only [Bool.not_true, Bool.false_eq_true, if_false] + exact TcM.PreservesInferOnly.pure (some true) + +/-- The narrow same-head rejection cache updates only the environment. -/ +theorem trySameHeadSpineCached_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (left right : KExpr .anon) : + ((trySameHeadSpineCached left right).run + methods).PreservesInferOnly := by + unfold trySameHeadSpineCached + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.defEqCtxKey left right) ?_ + intro contextAddress + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind TcM.PreservesInferOnly.get + intro state + split + · exact TcM.PreservesInferOnly.pure none + · simp only [pure_bind] + apply TcM.PreservesInferOnly.bind + (trySameHeadSpine_preservesInferOnly hmethods left right) + intro result + cases result with + | some accepted => exact TcM.PreservesInferOnly.pure (some accepted) + | none => + intro before + rfl + +theorem tryDefEqWhnfApp_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (functionLeft argumentLeft functionRight argumentRight : KExpr .anon) : + ((tryDefEqWhnfApp functionLeft argumentLeft functionRight argumentRight).run + methods).PreservesInferOnly := by + unfold tryDefEqWhnfApp + refine bind_preservesInferOnly + (isDefEqCall_preservesInferOnly hmethods functionLeft functionRight) ?_ + intro functionsEqual + cases functionsEqual with + | false => exact TcM.PreservesInferOnly.pure none + | true => + simp only [if_true] + refine bind_preservesInferOnly + (isDefEqCall_preservesInferOnly hmethods argumentLeft argumentRight) ?_ + intro argumentsEqual + cases argumentsEqual <;> exact TcM.PreservesInferOnly.pure _ + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/DefEqCachePolicy.lean b/Ix/Tc/Verify/Check/DefEqCachePolicy.lean new file mode 100644 index 000000000..60f09a723 --- /dev/null +++ b/Ix/Tc/Verify/Check/DefEqCachePolicy.lean @@ -0,0 +1,345 @@ +import Ix.Tc.Verify.Check.DefEqPipelinePolicy + +/-! +# Operational policy for DefEq's cache and recursion shell + +The comparison tiers preserve `inferOnly`; this module proves that the +production tracing, cache, equivalence-manager, fuel, and balanced-depth +shell around those tiers preserves the same caller policy on success and on +every error path. +-/ + +namespace Ix.Tc + +namespace RecM + +attribute [local irreducible] EquivManager.addEquiv Std.HashMap.insert + +private theorem modifyRec_preservesInferOnly + {methods : Methods .anon} (update : TcState .anon → TcState .anon) + (hupdate : ∀ state, (update state).inferOnly = state.inferOnly) : + ((modify update : RecM .anon PUnit).run methods).PreservesInferOnly := by + intro before + exact hupdate before + +private theorem finishDefEqCacheWrite_preservesInferOnly + {methods : Methods .anon} (leftKey rightKey : EqKey) + (cacheKey : Address × Address × Address) (cheapMode answer : Bool) : + TcM.PreservesInferOnly + ((do + if answer then + modify fun state => { state with + equivManager := state.equivManager.addEquiv leftKey rightKey } + if cheapMode then + modify fun state => { state with env := { state.env with + defEqCheapCache := state.env.defEqCheapCache.insert cacheKey answer + defEqCache := if answer then + state.env.defEqCache.insert cacheKey true + else state.env.defEqCache } } + else + modify fun state => { state with env := { state.env with + defEqCache := state.env.defEqCache.insert cacheKey answer } } + pure answer : RecM .anon Bool).run methods) := by + by_cases hanswer : answer + · simp only [hanswer, if_true] + apply bind_preservesInferOnly + (modifyRec_preservesInferOnly + (fun state => { state with + equivManager := state.equivManager.addEquiv leftKey rightKey }) + fun _ => rfl) + intro _ + by_cases hcheap : cheapMode + · simp only [hcheap, if_true] + apply bind_preservesInferOnly + (modifyRec_preservesInferOnly + (fun state => { state with env := { state.env with + defEqCheapCache := state.env.defEqCheapCache.insert cacheKey true + defEqCache := state.env.defEqCache.insert cacheKey true } }) + fun _ => rfl) + intro _ + exact TcM.PreservesInferOnly.pure true + · simp only [hcheap, Bool.false_eq_true, if_false] + apply bind_preservesInferOnly + (modifyRec_preservesInferOnly + (fun state => { state with env := { state.env with + defEqCache := state.env.defEqCache.insert cacheKey true } }) + fun _ => rfl) + intro _ + exact TcM.PreservesInferOnly.pure true + · simp only [hanswer, Bool.false_eq_true, if_false, pure_bind] + by_cases hcheap : cheapMode + · simp only [hcheap, if_true] + apply bind_preservesInferOnly + (modifyRec_preservesInferOnly + (fun state => { state with env := { state.env with + defEqCheapCache := state.env.defEqCheapCache.insert cacheKey false + defEqCache := state.env.defEqCache } }) + fun _ => rfl) + intro _ + exact TcM.PreservesInferOnly.pure false + · simp only [hcheap, Bool.false_eq_true, if_false] + apply bind_preservesInferOnly + (modifyRec_preservesInferOnly + (fun state => { state with env := { state.env with + defEqCache := state.env.defEqCache.insert cacheKey false } }) + fun _ => rfl) + intro _ + exact TcM.PreservesInferOnly.pure false + +theorem isDefEqAfterRootCacheMiss_preservesInferOnly + {methods : Methods .anon} + (hinner : ∀ left right, + ((isDefEqInner left right).run methods).PreservesInferOnly) + (left right : KExpr .anon) (leftKey rightKey : EqKey) + (cacheKey : Address × Address × Address) (cheapMode : Bool) : + ((isDefEqAfterRootCacheMiss left right leftKey rightKey cacheKey + cheapMode).run methods).PreservesInferOnly := by + unfold isDefEqAfterRootCacheMiss + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.bumpStats _ fun _ => rfl) ?_ + intro _ + refine bindTcM_preservesInferOnly TcM.PreservesInferOnly.tick ?_ + intro _ + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.modify fun _ => rfl) ?_ + intro _ + refine bindTcM_preservesInferOnly TcM.PreservesInferOnly.get ?_ + intro state + by_cases hdepth : state.defEqDepth > maxDefEqDepth + · simp only [hdepth, if_true] + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.modify fun _ => rfl) ?_ + intro _ + exact TcM.PreservesInferOnly.throw .maxRecDepth + · simp only [hdepth, if_false, pure_bind] + refine bind_preservesInferOnly + (captureErrors_preservesInferOnly (hinner left right)) ?_ + intro result + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.modify fun _ => rfl) ?_ + intro _ + cases result with + | error error => exact TcM.PreservesInferOnly.throw error + | ok answer => + simp only + exact finishDefEqCacheWrite_preservesInferOnly leftKey rightKey + cacheKey cheapMode answer + +private theorem finishRootCacheHit_preservesInferOnly + {methods : Methods .anon} (leftKey rightKey : EqKey) + (cacheKey : Address × Address × Address) + (cheapMode cached fromCheap : Bool) : + TcM.PreservesInferOnly + ((do + if fromCheap then + modify fun state => { state with env := { state.env with + defEqCheapCache := state.env.defEqCheapCache.insert cacheKey cached + defEqCache := if cached then + state.env.defEqCache.insert cacheKey true + else state.env.defEqCache } } + else + modify fun state => { state with env := { state.env with + defEqCache := state.env.defEqCache.insert cacheKey cached + defEqCheapCache := if cheapMode then + state.env.defEqCheapCache.insert cacheKey cached + else state.env.defEqCheapCache } } + if cached then + modify fun state => { state with + equivManager := state.equivManager.addEquiv leftKey rightKey } + pure cached : RecM .anon Bool).run methods) := by + intro before + cases fromCheap <;> cases cheapMode <;> cases cached <;> rfl + +theorem isDefEqAfterDirectCacheMiss_preservesInferOnly + {methods : Methods .anon} + (hrootMiss : ∀ left right leftKey rightKey cacheKey cheapMode, + ((isDefEqAfterRootCacheMiss left right leftKey rightKey cacheKey + cheapMode).run methods).PreservesInferOnly) + (left right : KExpr .anon) (contextAddress : Address) + (leftKey rightKey : EqKey) + (cacheKey : Address × Address × Address) (cheapMode : Bool) : + ((isDefEqAfterDirectCacheMiss left right contextAddress leftKey rightKey + cacheKey cheapMode).run methods).PreservesInferOnly := by + unfold isDefEqAfterDirectCacheMiss + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.withEquiv fun manager => + let (leftRoot, manager) := manager.findRootKey leftKey + let (rightRoot, manager) := manager.findRootKey rightKey + ((leftRoot, rightRoot), manager)) ?_ + intro roots + rcases roots with ⟨leftRoot?, rightRoot?⟩ + cases leftRoot? with + | none => exact hrootMiss left right leftKey rightKey cacheKey cheapMode + | some leftRoot => + cases rightRoot? with + | none => exact hrootMiss left right leftKey rightKey cacheKey cheapMode + | some rightRoot => + simp only + by_cases hchanged : leftRoot != leftKey || rightRoot != rightKey + · simp only [hchanged, if_true] + by_cases hscope : leftRoot.rootCacheScopeMatches rightRoot + contextAddress (max left.lbr right.lbr) + · simp only [hscope, if_true] + let rootPair := canonicalPair leftRoot.exprAddr rightRoot.exprAddr + let rootCacheKey := (rootPair.1, rootPair.2, contextAddress) + refine bind_preservesInferOnly + (show ((get : RecM .anon (TcState .anon)).run + methods).PreservesInferOnly by intro before; rfl) ?_ + intro cacheState + cases hfull : cacheState.env.defEqCache[rootCacheKey]? with + | some cached => + simp only [pure_bind] + exact finishRootCacheHit_preservesInferOnly leftKey rightKey + cacheKey cheapMode cached false + | none => + by_cases hcheap : cheapMode + · simp only [hcheap, if_true] + refine bind_preservesInferOnly + (show ((get : RecM .anon (TcState .anon)).run + methods).PreservesInferOnly by intro before; rfl) ?_ + intro cheapState + cases hcheapHit : + cheapState.env.defEqCheapCache[rootCacheKey]? with + | some cached => + simp only [pure_bind] + exact finishRootCacheHit_preservesInferOnly leftKey + rightKey cacheKey cheapMode cached true + | none => + simp only [pure_bind] + exact hrootMiss left right leftKey rightKey cacheKey + true + · simp only [hcheap, Bool.false_eq_true, if_false, + pure_bind] + exact hrootMiss left right leftKey rightKey cacheKey + false + · simp only [hscope, Bool.false_eq_true, if_false] + exact hrootMiss left right leftKey rightKey cacheKey cheapMode + · simp only [hchanged, Bool.false_eq_true, if_false] + exact hrootMiss left right leftKey rightKey cacheKey cheapMode + +private theorem finishDirectFullCacheHit_preservesInferOnly + {methods : Methods .anon} (leftKey rightKey : EqKey) + (cacheKey : Address × Address × Address) + (cheapMode cached : Bool) : + TcM.PreservesInferOnly + ((do + if cheapMode then + modify fun state => { state with env := { state.env with + defEqCheapCache := state.env.defEqCheapCache.insert cacheKey cached } } + if cached then + modify fun state => { state with + equivManager := state.equivManager.addEquiv leftKey rightKey } + pure cached : RecM .anon Bool).run methods) := by + intro before + cases cheapMode <;> cases cached <;> rfl + +private theorem finishDirectCheapCacheHit_preservesInferOnly + {methods : Methods .anon} (leftKey rightKey : EqKey) + (cacheKey : Address × Address × Address) (cached : Bool) : + TcM.PreservesInferOnly + ((do + if cached then + modify fun state => { state with + env := { state.env with + defEqCache := state.env.defEqCache.insert cacheKey true } + equivManager := state.equivManager.addEquiv leftKey rightKey } + pure cached : RecM .anon Bool).run methods) := by + intro before + cases cached <;> rfl + +theorem isDefEq_preservesInferOnly + {methods : Methods .anon} + (hdirectMiss : ∀ left right contextAddress leftKey rightKey cacheKey + cheapMode, + ((isDefEqAfterDirectCacheMiss left right contextAddress leftKey rightKey + cacheKey cheapMode).run methods).PreservesInferOnly) + (left right : KExpr .anon) : + ((isDefEq left right).run methods).PreservesInferOnly := by + unfold isDefEq + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.stepTrace "deq" fun _ => + s!"{TcM.addr8 left.addr} ~ {TcM.addr8 right.addr}") ?_ + intro _ + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.bumpStats _ fun _ => rfl) ?_ + intro _ + by_cases haddress : left.addr == right.addr + · simp only [haddress, if_true] + exact TcM.PreservesInferOnly.pure true + · simp only [haddress, Bool.false_eq_true, if_false, pure_bind] + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.defEqCtxKey left right) ?_ + intro contextAddress + let commonRadius := max left.lbr right.lbr + let leftKey : EqKey := + ⟨left.addr, contextAddress, commonRadius, left.lbr⟩ + let rightKey : EqKey := + ⟨right.addr, contextAddress, commonRadius, right.lbr⟩ + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.withEquiv + (·.isEquiv leftKey rightKey)) ?_ + intro equivalent + cases equivalent with + | true => exact TcM.PreservesInferOnly.pure true + | false => + simp only [Bool.false_eq_true, if_false] + let pair := canonicalPair left.addr right.addr + let cacheKey := (pair.1, pair.2, contextAddress) + refine bind_preservesInferOnly + (show ((get : RecM .anon (TcState .anon)).run + methods).PreservesInferOnly by intro before; rfl) ?_ + intro cacheState + let cheapMode := cacheState.cheapRecursionDepth > 0 + refine bind_preservesInferOnly + (show ((get : RecM .anon (TcState .anon)).run + methods).PreservesInferOnly by intro before; rfl) ?_ + intro fullState + cases hfull : fullState.env.defEqCache[cacheKey]? with + | some cached => + simp only + by_cases hcheap : cacheState.cheapRecursionDepth > 0 + · simp only [hcheap] + exact finishDirectFullCacheHit_preservesInferOnly leftKey + rightKey cacheKey true cached + · simp only [hcheap] + exact finishDirectFullCacheHit_preservesInferOnly leftKey + rightKey cacheKey false cached + | none => + simp only + by_cases hcheap : cacheState.cheapRecursionDepth > 0 + · simp only [hcheap] + refine bind_preservesInferOnly + (show ((get : RecM .anon (TcState .anon)).run + methods).PreservesInferOnly by intro before; rfl) ?_ + intro cheapState + cases hcheapHit : cheapState.env.defEqCheapCache[cacheKey]? with + | some cached => + simp only + exact finishDirectCheapCacheHit_preservesInferOnly leftKey + rightKey cacheKey cached + | none => + simp only + exact hdirectMiss left right contextAddress leftKey rightKey + cacheKey true + · simp only [hcheap] + exact hdirectMiss left right contextAddress leftKey rightKey + cacheKey false + +theorem isDefEq_preservesInferOnly_of_inner + {methods : Methods .anon} + (hinner : ∀ left right, + ((isDefEqInner left right).run methods).PreservesInferOnly) + (left right : KExpr .anon) : + ((isDefEq left right).run methods).PreservesInferOnly := by + apply isDefEq_preservesInferOnly + intro directLeft directRight contextAddress leftKey rightKey cacheKey + cheapMode + apply isDefEqAfterDirectCacheMiss_preservesInferOnly + intro rootLeft rootRight rootLeftKey rootRightKey rootCacheKey + rootCheapMode + exact isDefEqAfterRootCacheMiss_preservesInferOnly hinner rootLeft rootRight + rootLeftKey rootRightKey rootCacheKey rootCheapMode + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/DefEqEtaPolicy.lean b/Ix/Tc/Verify/Check/DefEqEtaPolicy.lean new file mode 100644 index 000000000..4e53c30b5 --- /dev/null +++ b/Ix/Tc/Verify/Check/DefEqEtaPolicy.lean @@ -0,0 +1,362 @@ +import Ix.Tc.Verify.Check.DefEqPropositionPolicy + +/-! +# Operational policy for DefEq eta phases + +This module covers lambda eta construction and the complete structure-eta +pipeline, including caught normalization failures, declaration ingress, +infer-only type comparison, finite projection-field recursion, and the +common-base scan. +-/ + +namespace Ix.Tc + +namespace RecM + +theorem compareEtaExpansion_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (target source : KExpr .anon) (name : Mode.anon.F Name) + (binderInfo : Mode.anon.F Lean.BinderInfo) (type : KExpr .anon) : + ((compareEtaExpansion target source name binderInfo type).run + methods).PreservesInferOnly := by + unfold compareEtaExpansion + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.runIntern (lift source 1 0)) + intro lifted + apply TcM.PreservesInferOnly.bind + (intern_preservesInferOnly (.mkVar 0 anonN)) + intro argument + apply TcM.PreservesInferOnly.bind + (intern_preservesInferOnly (.mkApp lifted argument)) + intro body + apply TcM.PreservesInferOnly.bind + (intern_preservesInferOnly (.mkLam name binderInfo type body)) + intro abstraction + exact isDefEqCall_preservesInferOnly hmethods target abstraction + +theorem tryEtaExpansionAfterGuard_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hwhnf : ∀ source, + ((whnf source).run methods).PreservesInferOnly) + (target source : KExpr .anon) : + ((tryEtaExpansionAfterGuard target source).run + methods).PreservesInferOnly := by + unfold tryEtaExpansionAfterGuard + refine bind_preservesInferOnly + (tryQuestion_preservesInferOnly + (inferOnlyCall_preservesInferOnly hmethods source)) ?_ + intro typeResult + cases typeResult with + | none => exact TcM.PreservesInferOnly.pure false + | some type => + simp only + refine bind_preservesInferOnly + (tryQuestion_preservesInferOnly (hwhnf type)) ?_ + intro normalizedResult + cases normalizedResult with + | none => exact TcM.PreservesInferOnly.pure false + | some normalized => + cases normalized with + | all name binderInfo domain body info => + exact compareEtaExpansion_preservesInferOnly hmethods target + source name binderInfo domain + | var | fvar | sort | const | app | lam | letE | prj | nat | str => + exact TcM.PreservesInferOnly.pure false + +theorem tryEtaExpansion_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hwhnf : ∀ source, + ((whnf source).run methods).PreservesInferOnly) + (target source : KExpr .anon) : + ((tryEtaExpansion target source).run methods).PreservesInferOnly := by + cases target <;> cases source <;> simp only [tryEtaExpansion, pure_bind] + all_goals first + | exact TcM.PreservesInferOnly.pure false + | exact tryEtaExpansionAfterGuard_preservesInferOnly hmethods hwhnf _ _ + +theorem normalizeEtaStructSource_preservesInferOnly + {methods : Methods .anon} + (hnoDelta : ∀ source, + ((whnfNoDelta source).run methods).PreservesInferOnly) + (source : KExpr .anon) : + ((normalizeEtaStructSource source).run + methods).PreservesInferOnly := by + unfold normalizeEtaStructSource + refine bind_preservesInferOnly + (tryQuestion_preservesInferOnly (hnoDelta source)) ?_ + intro result + cases result <;> exact TcM.PreservesInferOnly.pure _ + +/-- The common-base scan is structurally recursive in its remaining field +count. Its helper seams are unfolded here so that both caught-normalization +outcomes are covered by the same induction hypothesis. -/ +theorem etaExpansionBaseLoop_preservesInferOnly + {methods : Methods .anon} + (hnoDelta : ∀ source, + ((whnfNoDelta source).run methods).PreservesInferOnly) + (inductiveId : KId .anon) (numParams : Nat) + (arguments : Array (KExpr .anon)) : ∀ fuel field base, + ((etaExpansionBaseLoop inductiveId numParams arguments fuel field base).run + methods).PreservesInferOnly + | 0, field, base => by + rw [etaExpansionBaseLoop] + exact TcM.PreservesInferOnly.pure base + | fuel + 1, field, base => by + rw [etaExpansionBaseLoop] + refine bind_preservesInferOnly + (hnoDelta arguments[numParams + field]!) ?_ + intro normalizedField + cases normalizedField with + | prj projectionId projectionIndex value info => + cases hshape : + (projectionId.addr != inductiveId.addr || + projectionIndex.toNat != field) with + | true => + simp only [hshape, if_true] + exact TcM.PreservesInferOnly.pure none + | false => + simp only [hshape, Bool.false_eq_true, if_false, pure_bind] + unfold etaExpansionBaseAfterProjection + refine bind_preservesInferOnly + (tryQuestion_preservesInferOnly (hnoDelta value)) ?_ + intro normalizedValueResult + unfold etaExpansionBaseAfterValue + cases normalizedValueResult with + | some normalizedValue => + cases base with + | none => + exact etaExpansionBaseLoop_preservesInferOnly hnoDelta + inductiveId numParams arguments fuel (field + 1) + (some normalizedValue) + | some prior => + cases hsame : (prior.addr != normalizedValue.addr) with + | true => + simp only [hsame, if_true] + exact TcM.PreservesInferOnly.pure none + | false => + simp only [hsame, Bool.false_eq_true, if_false, + pure_bind] + exact etaExpansionBaseLoop_preservesInferOnly hnoDelta + inductiveId numParams arguments fuel (field + 1) + (some prior) + | none => + cases base with + | none => + exact etaExpansionBaseLoop_preservesInferOnly hnoDelta + inductiveId numParams arguments fuel (field + 1) + (some value) + | some prior => + cases hsame : (prior.addr != value.addr) with + | true => + simp only [hsame, if_true] + exact TcM.PreservesInferOnly.pure none + | false => + simp only [hsame, Bool.false_eq_true, if_false, + pure_bind] + exact etaExpansionBaseLoop_preservesInferOnly hnoDelta + inductiveId numParams arguments fuel (field + 1) + (some prior) + | var | fvar | sort | const | app | lam | all | letE | nat | str => + exact TcM.PreservesInferOnly.pure none + +theorem etaExpansionBaseAfterValue_preservesInferOnly + {methods : Methods .anon} + (hnoDelta : ∀ source, + ((whnfNoDelta source).run methods).PreservesInferOnly) + (inductiveId : KId .anon) (numParams : Nat) + (arguments : Array (KExpr .anon)) (fuel field : Nat) + (base : Option (KExpr .anon)) (value : KExpr .anon) : + ((etaExpansionBaseAfterValue inductiveId numParams arguments fuel field + base value).run methods).PreservesInferOnly := by + unfold etaExpansionBaseAfterValue + cases base with + | none => + exact etaExpansionBaseLoop_preservesInferOnly hnoDelta inductiveId + numParams arguments fuel (field + 1) (some value) + | some prior => + cases hsame : (prior.addr != value.addr) with + | true => + simp only [hsame, if_true] + exact TcM.PreservesInferOnly.pure none + | false => + simp only [hsame, Bool.false_eq_true, if_false, pure_bind] + exact etaExpansionBaseLoop_preservesInferOnly hnoDelta inductiveId + numParams arguments fuel (field + 1) (some prior) + +theorem etaExpansionBaseAfterProjection_preservesInferOnly + {methods : Methods .anon} + (hnoDelta : ∀ source, + ((whnfNoDelta source).run methods).PreservesInferOnly) + (inductiveId : KId .anon) (numParams : Nat) + (arguments : Array (KExpr .anon)) (fuel field : Nat) + (base : Option (KExpr .anon)) (value : KExpr .anon) : + ((etaExpansionBaseAfterProjection inductiveId numParams arguments fuel + field base value).run methods).PreservesInferOnly := by + unfold etaExpansionBaseAfterProjection + refine bind_preservesInferOnly + (tryQuestion_preservesInferOnly (hnoDelta value)) ?_ + intro result + cases result with + | some normalized => + exact etaExpansionBaseAfterValue_preservesInferOnly hnoDelta inductiveId + numParams arguments fuel field base normalized + | none => + exact etaExpansionBaseAfterValue_preservesInferOnly hnoDelta inductiveId + numParams arguments fuel field base value + +theorem etaExpansionBase_preservesInferOnly + {methods : Methods .anon} + (hnoDelta : ∀ source, + ((whnfNoDelta source).run methods).PreservesInferOnly) + (inductiveId : KId .anon) (numParams numFields : Nat) + (arguments : Array (KExpr .anon)) : + ((etaExpansionBase inductiveId numParams numFields arguments).run + methods).PreservesInferOnly := by + unfold etaExpansionBase + exact etaExpansionBaseLoop_preservesInferOnly hnoDelta inductiveId numParams + arguments numFields 0 none + +theorem tryEtaStructFields_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (inductiveId : KId .anon) (numParams : Nat) + (target : KExpr .anon) (arguments : Array (KExpr .anon)) : ∀ fuel field, + ((tryEtaStructFields inductiveId numParams target arguments fuel field).run + methods).PreservesInferOnly + | 0, field => TcM.PreservesInferOnly.pure true + | fuel + 1, field => by + rw [tryEtaStructFields] + refine bindIntern_preservesInferOnly + (.mkPrj inductiveId field.toUInt64 target) ?_ + intro projection + refine bind_preservesInferOnly + (isDefEqCall_preservesInferOnly hmethods projection + arguments[numParams + field]!) ?_ + intro equal + cases equal with + | false => exact TcM.PreservesInferOnly.pure false + | true => + simp only [Bool.not_true, Bool.false_eq_true, if_false] + exact tryEtaStructFields_preservesInferOnly hmethods inductiveId + numParams target arguments fuel (field + 1) + +theorem tryEtaStructAfterTypes_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hnoDelta : ∀ source, + ((whnfNoDelta source).run methods).PreservesInferOnly) + (inductiveId : KId .anon) (numParams numFields : Nat) + (target : KExpr .anon) (arguments : Array (KExpr .anon)) : + ((tryEtaStructAfterTypes inductiveId numParams numFields target arguments).run + methods).PreservesInferOnly := by + unfold tryEtaStructAfterTypes + refine bind_preservesInferOnly + (etaExpansionBase_preservesInferOnly hnoDelta inductiveId numParams + numFields arguments) ?_ + intro baseResult + cases baseResult with + | none => + exact tryEtaStructFields_preservesInferOnly hmethods inductiveId + numParams target arguments numFields 0 + | some base => + simp only + refine bind_preservesInferOnly + (isDefEqCall_preservesInferOnly hmethods target base) ?_ + intro equal + cases equal with + | true => exact TcM.PreservesInferOnly.pure true + | false => + simp only [Bool.false_eq_true, if_false, pure_bind] + exact tryEtaStructFields_preservesInferOnly hmethods inductiveId + numParams target arguments numFields 0 + +theorem tryEtaStructAfterConstructor_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hnoDelta : ∀ source, + ((whnfNoDelta source).run methods).PreservesInferOnly) + (inductiveId : KId .anon) (numParams numFields : Nat) + (target source : KExpr .anon) (arguments : Array (KExpr .anon)) : + ((tryEtaStructAfterConstructor inductiveId numParams numFields target + source arguments).run methods).PreservesInferOnly := by + unfold tryEtaStructAfterConstructor + split + · exact TcM.PreservesInferOnly.pure false + · simp only [pure_bind] + refine bind_preservesInferOnly + (isStructLike_preservesInferOnly hmethods inductiveId) ?_ + intro isStructure + cases isStructure with + | false => exact TcM.PreservesInferOnly.pure false + | true => + simp only [Bool.not_true, Bool.false_eq_true, if_false] + refine bind_preservesInferOnly + (tryQuestion_preservesInferOnly + (inferOnlyCall_preservesInferOnly hmethods source)) ?_ + intro sourceTypeResult + cases sourceTypeResult with + | none => exact TcM.PreservesInferOnly.pure false + | some sourceType => + simp only + refine bind_preservesInferOnly + (tryQuestion_preservesInferOnly + (inferOnlyCall_preservesInferOnly hmethods target)) ?_ + intro targetTypeResult + cases targetTypeResult with + | none => exact TcM.PreservesInferOnly.pure false + | some targetType => + simp only + refine bind_preservesInferOnly + (isDefEqCall_preservesInferOnly hmethods targetType + sourceType) ?_ + intro typesEqual + cases typesEqual with + | false => exact TcM.PreservesInferOnly.pure false + | true => + simp only [Bool.not_true, Bool.false_eq_true, if_false] + exact tryEtaStructAfterTypes_preservesInferOnly hmethods + hnoDelta inductiveId numParams numFields target arguments + +theorem tryEtaStructAfterNormalization_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hnoDelta : ∀ source, + ((whnfNoDelta source).run methods).PreservesInferOnly) + (target source : KExpr .anon) : + ((tryEtaStructAfterNormalization target source).run + methods).PreservesInferOnly := by + rcases hspine : source.collectSpine with ⟨head, arguments⟩ + unfold tryEtaStructAfterNormalization + simp only [hspine] + cases head with + | const constructorId universes info => + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.tryGetConst constructorId) ?_ + intro declaration + cases declaration with + | none => exact TcM.PreservesInferOnly.pure false + | some declaration => + cases declaration with + | ctor name levelParams isUnsafe levels inductiveId constructorIndex + params fields type => + exact tryEtaStructAfterConstructor_preservesInferOnly hmethods + hnoDelta inductiveId params.toNat fields.toNat target source + arguments + | defn | recr | axio | quot | indc => + exact TcM.PreservesInferOnly.pure false + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + exact TcM.PreservesInferOnly.pure false + +theorem tryEtaStruct_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hnoDelta : ∀ source, + ((whnfNoDelta source).run methods).PreservesInferOnly) + (target source : KExpr .anon) : + ((tryEtaStruct target source).run methods).PreservesInferOnly := by + unfold tryEtaStruct + refine bind_preservesInferOnly + (normalizeEtaStructSource_preservesInferOnly hnoDelta target) ?_ + intro normalized + exact tryEtaStructAfterNormalization_preservesInferOnly hmethods hnoDelta + normalized source + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/DefEqFinalWhnfPolicy.lean b/Ix/Tc/Verify/Check/DefEqFinalWhnfPolicy.lean new file mode 100644 index 000000000..d966c4842 --- /dev/null +++ b/Ix/Tc/Verify/Check/DefEqFinalWhnfPolicy.lean @@ -0,0 +1,375 @@ +import Ix.Tc.Verify.Check.DefEqEtaPolicy + +/-! +# Operational policy for final-WHNF definitional equality + +The final comparison is an ordered fallback chain: constructor-directed +structural comparison, Nat bridging, lambda eta, String expansion, +structure eta, unit-like classification, and proof irrelevance. These +lemmas preserve that exact production order while framing every success and +partial error state. +-/ + +namespace Ix.Tc + +namespace RecM + +theorem tryDefEqWhnfLet_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (name : Mode.anon.F Name) + (typeLeft valueLeft bodyLeft typeRight valueRight bodyRight : + KExpr .anon) : + ((tryDefEqWhnfLet name typeLeft valueLeft bodyLeft typeRight valueRight + bodyRight).run methods).PreservesInferOnly := by + unfold tryDefEqWhnfLet + refine bind_preservesInferOnly + (isDefEqCall_preservesInferOnly hmethods typeLeft typeRight) ?_ + intro typesEqual + cases typesEqual with + | false => exact TcM.PreservesInferOnly.pure none + | true => + simp only [if_true] + refine bind_preservesInferOnly + (isDefEqCall_preservesInferOnly hmethods valueLeft valueRight) ?_ + intro valuesEqual + cases valuesEqual with + | false => exact TcM.PreservesInferOnly.pure none + | true => + simp only [if_true] + have hbody : + ((withLctxScope do + let (leftOpen, fresh, _) ← + (liftM (TcM.openLetWithFV name typeLeft valueLeft bodyLeft) : + RecM .anon (KExpr .anon × KExpr .anon × FVarId)) + let rightOpen ← + (liftM (TcM.runIntern (instantiateRev bodyRight #[fresh])) : + RecM .anon (KExpr .anon)) + isDefEqCall leftOpen rightOpen).run + methods).PreservesInferOnly := by + apply withLctxScope_preservesInferOnly + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.openLetWithFV name typeLeft valueLeft + bodyLeft) + intro opened + rcases opened with ⟨leftOpen, fresh, freshId⟩ + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.runIntern + (instantiateRev bodyRight #[fresh])) + intro rightOpen + exact isDefEqCall_preservesInferOnly hmethods leftOpen rightOpen + refine bind_preservesInferOnly hbody ?_ + intro bodiesEqual + cases bodiesEqual <;> exact TcM.PreservesInferOnly.pure _ + +theorem tryDefEqWhnfStructural_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (left right : KExpr .anon) : + ((tryDefEqWhnfStructural left right).run + methods).PreservesInferOnly := by + cases left with + | sort leftUniverse leftInfo => + cases right <;> simp only [tryDefEqWhnfStructural] <;> + exact TcM.PreservesInferOnly.pure _ + | var leftIndex leftName leftInfo => + cases right with + | var rightIndex rightName rightInfo => + simp only [tryDefEqWhnfStructural] + split + · exact TcM.PreservesInferOnly.pure (some true) + · intro before + rfl + | fvar | sort | const | app | lam | all | letE | prj | nat | str => + exact TcM.PreservesInferOnly.pure none + | fvar leftId leftName leftInfo => + cases right <;> simp only [tryDefEqWhnfStructural] <;> + exact TcM.PreservesInferOnly.pure none + | const leftId leftUniverses leftInfo => + cases right with + | const rightId rightUniverses rightInfo => + simp only [tryDefEqWhnfStructural] + split + · exact TcM.PreservesInferOnly.pure (some true) + · intro before + rfl + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + exact TcM.PreservesInferOnly.pure none + | app leftFunction leftArgument leftInfo => + cases right with + | app rightFunction rightArgument rightInfo => + simp only [tryDefEqWhnfStructural, ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind + (tryDefEqWhnfApp_preservesInferOnly hmethods leftFunction + leftArgument rightFunction rightArgument) + intro result + exact TcM.PreservesInferOnly.pure result + | var | fvar | sort | const | lam | all | letE | prj | nat | str => + simp only [tryDefEqWhnfStructural] + exact TcM.PreservesInferOnly.pure none + | lam name binderInfo leftType leftBody leftInfo => + cases right with + | lam rightName rightBinderInfo rightType rightBody rightInfo => + simp only [tryDefEqWhnfStructural] + refine bind_preservesInferOnly + (quickBinder_preservesInferOnly hmethods name binderInfo leftType + leftBody rightType rightBody) ?_ + intro equal + cases equal <;> exact TcM.PreservesInferOnly.pure _ + | var | fvar | sort | const | app | all | letE | prj | nat | str => + simp only [tryDefEqWhnfStructural] + exact TcM.PreservesInferOnly.pure none + | all name binderInfo leftType leftBody leftInfo => + cases right with + | all rightName rightBinderInfo rightType rightBody rightInfo => + simp only [tryDefEqWhnfStructural] + refine bind_preservesInferOnly + (quickBinder_preservesInferOnly hmethods name binderInfo leftType + leftBody rightType rightBody) ?_ + intro equal + cases equal <;> exact TcM.PreservesInferOnly.pure _ + | var | fvar | sort | const | app | lam | letE | prj | nat | str => + simp only [tryDefEqWhnfStructural] + exact TcM.PreservesInferOnly.pure none + | letE name leftType leftValue leftBody leftNonDependent leftInfo => + cases right with + | letE rightName rightType rightValue rightBody rightNonDependent + rightInfo => + simp only [tryDefEqWhnfStructural, ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind + (tryDefEqWhnfLet_preservesInferOnly hmethods name leftType leftValue + leftBody rightType rightValue rightBody) + intro result + exact TcM.PreservesInferOnly.pure result + | var | fvar | sort | const | app | lam | all | prj | nat | str => + simp only [tryDefEqWhnfStructural] + exact TcM.PreservesInferOnly.pure none + | prj leftId leftField leftValue leftInfo => + cases right <;> simp only [tryDefEqWhnfStructural] <;> + exact TcM.PreservesInferOnly.pure none + | nat leftValue leftBlob leftInfo => + cases right <;> simp only [tryDefEqWhnfStructural] <;> + exact TcM.PreservesInferOnly.pure _ + | str leftValue leftBlob leftInfo => + cases right <;> simp only [tryDefEqWhnfStructural] <;> + exact TcM.PreservesInferOnly.pure _ + +theorem tryDefEqWhnfNat_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (left right : KExpr .anon) : + ((tryDefEqWhnfNat left right).run methods).PreservesInferOnly := by + unfold tryDefEqWhnfNat + refine bind_preservesInferOnly (isNatLike_preservesInferOnly left) ?_ + intro leftNat + refine bind_preservesInferOnly (isNatLike_preservesInferOnly right) ?_ + intro rightNat + cases hboth : (leftNat && rightNat) with + | false => + simp only [Bool.false_eq_true, if_false] + exact TcM.PreservesInferOnly.pure none + | true => + simp only [if_true] + refine bind_preservesInferOnly + (isDefEqNat_preservesInferOnly hmethods left right) ?_ + intro answer + exact TcM.PreservesInferOnly.pure (some answer) + +theorem tryDefEqWhnfEtaAfterGuard_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hwhnf : ∀ source, + ((whnf source).run methods).PreservesInferOnly) + (left right : KExpr .anon) : + ((tryDefEqWhnfEtaAfterGuard left right).run + methods).PreservesInferOnly := by + unfold tryDefEqWhnfEtaAfterGuard + refine bind_preservesInferOnly + (tryEtaExpansion_preservesInferOnly hmethods hwhnf left right) ?_ + intro firstAccepted + cases firstAccepted with + | true => exact TcM.PreservesInferOnly.pure (some true) + | false => + simp only [Bool.false_eq_true, if_false, pure_bind] + refine bind_preservesInferOnly + (tryEtaExpansion_preservesInferOnly hmethods hwhnf right left) ?_ + intro secondAccepted + cases secondAccepted <;> exact TcM.PreservesInferOnly.pure _ + +theorem tryDefEqWhnfEta_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hwhnf : ∀ source, + ((whnf source).run methods).PreservesInferOnly) + (left right : KExpr .anon) : + ((tryDefEqWhnfEta left right).run methods).PreservesInferOnly := by + cases left <;> cases right <;> simp only [tryDefEqWhnfEta] + all_goals first + | exact TcM.PreservesInferOnly.pure none + | exact tryDefEqWhnfEtaAfterGuard_preservesInferOnly hmethods hwhnf _ _ + +theorem tryDefEqWhnfStringAfterGuard_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (left right : KExpr .anon) : + ((tryDefEqWhnfStringAfterGuard left right).run + methods).PreservesInferOnly := by + unfold tryDefEqWhnfStringAfterGuard + refine bind_preservesInferOnly + (tryStringLitExpansion_preservesInferOnly hmethods left right) ?_ + intro firstAccepted + cases firstAccepted with + | true => exact TcM.PreservesInferOnly.pure (some true) + | false => + simp only [Bool.false_eq_true, if_false, pure_bind] + refine bind_preservesInferOnly + (tryStringLitExpansion_preservesInferOnly hmethods right left) ?_ + intro secondAccepted + cases secondAccepted <;> exact TcM.PreservesInferOnly.pure _ + +theorem tryDefEqWhnfString_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (left right : KExpr .anon) : + ((tryDefEqWhnfString left right).run methods).PreservesInferOnly := by + unfold tryDefEqWhnfString + split + · exact tryDefEqWhnfStringAfterGuard_preservesInferOnly hmethods left right + · exact TcM.PreservesInferOnly.pure none + +theorem tryDefEqWhnfStructEta_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hnoDelta : ∀ source, + ((whnfNoDelta source).run methods).PreservesInferOnly) + (left right : KExpr .anon) : + ((tryDefEqWhnfStructEta left right).run + methods).PreservesInferOnly := by + unfold tryDefEqWhnfStructEta + refine bind_preservesInferOnly + (tryEtaStruct_preservesInferOnly hmethods hnoDelta left right) ?_ + intro firstAccepted + cases firstAccepted with + | true => exact TcM.PreservesInferOnly.pure (some true) + | false => + simp only [Bool.false_eq_true, if_false, pure_bind] + refine bind_preservesInferOnly + (tryEtaStruct_preservesInferOnly hmethods hnoDelta right left) ?_ + intro secondAccepted + cases secondAccepted <;> exact TcM.PreservesInferOnly.pure _ + +theorem isDefEqWhnfAfterUnit_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hwhnf : ∀ source, + ((whnf source).run methods).PreservesInferOnly) + (left right : KExpr .anon) : + ((isDefEqWhnfAfterUnit left right).run + methods).PreservesInferOnly := by + unfold isDefEqWhnfAfterUnit + exact tryProofIrrel_preservesInferOnly hmethods hwhnf left right + +theorem isDefEqWhnfAfterStructEta_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hwhnf : ∀ source, + ((whnf source).run methods).PreservesInferOnly) + (left right : KExpr .anon) : + ((isDefEqWhnfAfterStructEta left right).run + methods).PreservesInferOnly := by + unfold isDefEqWhnfAfterStructEta + refine bind_preservesInferOnly + (tryDefEqUnit_preservesInferOnly hmethods hwhnf left right) ?_ + intro accepted + cases accepted with + | true => exact TcM.PreservesInferOnly.pure true + | false => + simp only [Bool.false_eq_true, if_false, pure_bind] + exact isDefEqWhnfAfterUnit_preservesInferOnly hmethods hwhnf left right + +theorem isDefEqWhnfAfterString_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hwhnf : ∀ source, + ((whnf source).run methods).PreservesInferOnly) + (hnoDelta : ∀ source, + ((whnfNoDelta source).run methods).PreservesInferOnly) + (left right : KExpr .anon) : + ((isDefEqWhnfAfterString left right).run + methods).PreservesInferOnly := by + unfold isDefEqWhnfAfterString + refine bind_preservesInferOnly + (tryDefEqWhnfStructEta_preservesInferOnly hmethods hnoDelta left right) ?_ + intro result + cases result with + | some answer => exact TcM.PreservesInferOnly.pure answer + | none => + exact isDefEqWhnfAfterStructEta_preservesInferOnly hmethods hwhnf left + right + +theorem isDefEqWhnfAfterEta_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hwhnf : ∀ source, + ((whnf source).run methods).PreservesInferOnly) + (hnoDelta : ∀ source, + ((whnfNoDelta source).run methods).PreservesInferOnly) + (left right : KExpr .anon) : + ((isDefEqWhnfAfterEta left right).run methods).PreservesInferOnly := by + unfold isDefEqWhnfAfterEta + refine bind_preservesInferOnly + (tryDefEqWhnfString_preservesInferOnly hmethods left right) ?_ + intro result + cases result with + | some answer => exact TcM.PreservesInferOnly.pure answer + | none => + exact isDefEqWhnfAfterString_preservesInferOnly hmethods hwhnf hnoDelta + left right + +theorem isDefEqWhnfAfterNat_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hwhnf : ∀ source, + ((whnf source).run methods).PreservesInferOnly) + (hnoDelta : ∀ source, + ((whnfNoDelta source).run methods).PreservesInferOnly) + (left right : KExpr .anon) : + ((isDefEqWhnfAfterNat left right).run methods).PreservesInferOnly := by + unfold isDefEqWhnfAfterNat + refine bind_preservesInferOnly + (tryDefEqWhnfEta_preservesInferOnly hmethods hwhnf left right) ?_ + intro result + cases result with + | some answer => exact TcM.PreservesInferOnly.pure answer + | none => + exact isDefEqWhnfAfterEta_preservesInferOnly hmethods hwhnf hnoDelta left + right + +theorem isDefEqWhnfAfterStructural_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hwhnf : ∀ source, + ((whnf source).run methods).PreservesInferOnly) + (hnoDelta : ∀ source, + ((whnfNoDelta source).run methods).PreservesInferOnly) + (left right : KExpr .anon) : + ((isDefEqWhnfAfterStructural left right).run + methods).PreservesInferOnly := by + unfold isDefEqWhnfAfterStructural + refine bind_preservesInferOnly + (tryDefEqWhnfNat_preservesInferOnly hmethods left right) ?_ + intro result + cases result with + | some answer => exact TcM.PreservesInferOnly.pure answer + | none => + exact isDefEqWhnfAfterNat_preservesInferOnly hmethods hwhnf hnoDelta left + right + +theorem isDefEqWhnf_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hwhnf : ∀ source, + ((whnf source).run methods).PreservesInferOnly) + (hnoDelta : ∀ source, + ((whnfNoDelta source).run methods).PreservesInferOnly) + (left right : KExpr .anon) : + ((isDefEqWhnf left right).run methods).PreservesInferOnly := by + unfold isDefEqWhnf + refine bind_preservesInferOnly + (tryDefEqWhnfStructural_preservesInferOnly hmethods left right) ?_ + intro result + cases result with + | some answer => exact TcM.PreservesInferOnly.pure answer + | none => + exact isDefEqWhnfAfterStructural_preservesInferOnly hmethods hwhnf + hnoDelta left right + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/DefEqLazyDeltaPolicy.lean b/Ix/Tc/Verify/Check/DefEqLazyDeltaPolicy.lean new file mode 100644 index 000000000..9a3598303 --- /dev/null +++ b/Ix/Tc/Verify/Check/DefEqLazyDeltaPolicy.lean @@ -0,0 +1,482 @@ +import Ix.Tc.Verify.Check.DefEqProjectionDeltaPolicy + +/-! +# Operational policy for the main DefEq lazy-delta loop + +This module covers the production Tier-4 bounded loop: Nat-offset and +primitive accelerators, delta classification and ranking, same-head cache +probes, one- and two-sided unfolding, projection-app probes, and the stopped +continuation into final WHNF comparison. +-/ + +namespace Ix.Tc + +namespace RecM + +theorem tryReduceNat_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (source : KExpr .anon) : + ((tryReduceNat source).run methods).PreservesInferOnly := by + unfold tryReduceNat + exact tryReduceNatWithSuccMode_preservesInferOnly hmethods source .collapse + +theorem finishDefEqLazyDeltaStep_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (left right : KExpr .anon) : + ((finishDefEqLazyDeltaStep left right).run + methods).PreservesInferOnly := by + unfold finishDefEqLazyDeltaStep + by_cases haddress : left.addr == right.addr + · simp only [haddress, if_true] + exact TcM.PreservesInferOnly.pure + (BoundedStep.done (LazyDeltaLoopResult.answer true)) + · simp only [haddress, Bool.false_eq_true, if_false, pure_bind] + refine bind_preservesInferOnly + (quickDefEq_preservesInferOnly hmethods left right) ?_ + intro equal + cases equal with + | true => + exact TcM.PreservesInferOnly.pure + (BoundedStep.done (LazyDeltaLoopResult.answer true)) + | false => + exact TcM.PreservesInferOnly.pure (BoundedStep.next (left, right)) + +theorem defEqLazyDeltaStepAfterSameHeadMiss_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hcheapNoDelta : ∀ source, + ((whnfNoDeltaForDefEq source).run methods).PreservesInferOnly) + (left right : KExpr .anon) : + ((defEqLazyDeltaStepAfterSameHeadMiss left right).run + methods).PreservesInferOnly := by + unfold defEqLazyDeltaStepAfterSameHeadMiss + refine bind_preservesInferOnly + (deltaUnfoldOne_preservesInferOnly left) ?_ + intro leftUnfolded + refine bind_preservesInferOnly + (deltaUnfoldOne_preservesInferOnly right) ?_ + intro rightUnfolded + cases leftUnfolded with + | none => + cases rightUnfolded with + | none => + exact TcM.PreservesInferOnly.pure + (BoundedStep.done (LazyDeltaLoopResult.stopped left right)) + | some rightBody => + refine bind_preservesInferOnly (hcheapNoDelta rightBody) ?_ + intro rightReduced + exact finishDefEqLazyDeltaStep_preservesInferOnly hmethods left + rightReduced + | some leftBody => + cases rightUnfolded with + | none => + refine bind_preservesInferOnly (hcheapNoDelta leftBody) ?_ + intro leftReduced + exact finishDefEqLazyDeltaStep_preservesInferOnly hmethods + leftReduced right + | some rightBody => + refine bind_preservesInferOnly (hcheapNoDelta leftBody) ?_ + intro leftReduced + refine bind_preservesInferOnly (hcheapNoDelta rightBody) ?_ + intro rightReduced + exact finishDefEqLazyDeltaStep_preservesInferOnly hmethods + leftReduced rightReduced + +theorem defEqLazyDeltaStepWithLeftDelta_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hcheapNoDelta : ∀ source, + ((whnfNoDeltaForDefEq source).run methods).PreservesInferOnly) + (left right : KExpr .anon) : + ((defEqLazyDeltaStepWithLeftDelta left right).run + methods).PreservesInferOnly := by + unfold defEqLazyDeltaStepWithLeftDelta + refine bind_preservesInferOnly + (deltaUnfoldOne_preservesInferOnly left) ?_ + intro result + cases result with + | none => + exact TcM.PreservesInferOnly.pure + (BoundedStep.done (LazyDeltaLoopResult.stopped left right)) + | some unfolded => + refine bind_preservesInferOnly (hcheapNoDelta unfolded) ?_ + intro reduced + exact finishDefEqLazyDeltaStep_preservesInferOnly hmethods reduced right + +theorem defEqLazyDeltaStepWithRightDelta_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hcheapNoDelta : ∀ source, + ((whnfNoDeltaForDefEq source).run methods).PreservesInferOnly) + (left right : KExpr .anon) : + ((defEqLazyDeltaStepWithRightDelta left right).run + methods).PreservesInferOnly := by + unfold defEqLazyDeltaStepWithRightDelta + refine bind_preservesInferOnly + (deltaUnfoldOne_preservesInferOnly right) ?_ + intro result + cases result with + | none => + exact TcM.PreservesInferOnly.pure + (BoundedStep.done (LazyDeltaLoopResult.stopped left right)) + | some unfolded => + refine bind_preservesInferOnly (hcheapNoDelta unfolded) ?_ + intro reduced + exact finishDefEqLazyDeltaStep_preservesInferOnly hmethods left reduced + +theorem defEqLazyDeltaStepWithEqualRank_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hcheapNoDelta : ∀ source, + ((whnfNoDeltaForDefEq source).run methods).PreservesInferOnly) + (left right : KExpr .anon) + (leftHead rightHead : Option (KId .anon)) : + ((defEqLazyDeltaStepWithEqualRank left right leftHead rightHead).run + methods).PreservesInferOnly := by + unfold defEqLazyDeltaStepWithEqualRank + cases leftHead with + | none => + exact defEqLazyDeltaStepAfterSameHeadMiss_preservesInferOnly hmethods + hcheapNoDelta left right + | some leftId => + cases rightHead with + | none => + exact defEqLazyDeltaStepAfterSameHeadMiss_preservesInferOnly hmethods + hcheapNoDelta left right + | some rightId => + refine bind_preservesInferOnly + (isRegular_preservesInferOnly leftId) ?_ + intro regular + by_cases hguard : leftId.addr == rightId.addr && regular + · simp only [hguard, if_true] + refine bind_preservesInferOnly + (trySameHeadSpineCached_preservesInferOnly hmethods left right) ?_ + intro result + cases result with + | some answer => + exact TcM.PreservesInferOnly.pure + (BoundedStep.done (LazyDeltaLoopResult.answer answer)) + | none => + exact + defEqLazyDeltaStepAfterSameHeadMiss_preservesInferOnly + hmethods hcheapNoDelta left right + · simp only [hguard, Bool.false_eq_true, if_false, pure_bind] + exact defEqLazyDeltaStepAfterSameHeadMiss_preservesInferOnly + hmethods hcheapNoDelta left right + +theorem defEqLazyDeltaStepAfterProjectionMiss_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hcheapNoDelta : ∀ source, + ((whnfNoDeltaForDefEq source).run methods).PreservesInferOnly) + (left right : KExpr .anon) + (leftHead rightHead : Option (KId .anon)) + (leftDelta rightDelta : Bool) : + ((defEqLazyDeltaStepAfterProjectionMiss left right leftHead rightHead + leftDelta rightDelta).run methods).PreservesInferOnly := by + unfold defEqLazyDeltaStepAfterProjectionMiss + by_cases hboth : leftDelta && rightDelta + · simp only [hboth, if_true] + refine bind_preservesInferOnly + (rankDeltaHead_preservesInferOnly leftHead) ?_ + intro leftRank + refine bind_preservesInferOnly + (rankDeltaHead_preservesInferOnly rightHead) ?_ + intro rightRank + by_cases hequal : leftRank == rightRank + · simp only [hequal, if_true] + exact defEqLazyDeltaStepWithEqualRank_preservesInferOnly hmethods + hcheapNoDelta left right leftHead rightHead + · simp only [hequal, Bool.false_eq_true, if_false] + split + · exact defEqLazyDeltaStepWithLeftDelta_preservesInferOnly hmethods + hcheapNoDelta left right + · exact defEqLazyDeltaStepWithRightDelta_preservesInferOnly hmethods + hcheapNoDelta left right + · simp only [hboth, Bool.false_eq_true, if_false] + by_cases hleft : leftDelta + · simp only [hleft, if_true] + exact defEqLazyDeltaStepWithLeftDelta_preservesInferOnly hmethods + hcheapNoDelta left right + · simp only [hleft, Bool.false_eq_true, if_false] + exact defEqLazyDeltaStepWithRightDelta_preservesInferOnly hmethods + hcheapNoDelta left right + +theorem defEqLazyDeltaStepAfterDeltaClassification_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hnoDelta : ∀ source, + ((whnfNoDelta source).run methods).PreservesInferOnly) + (hcheapNoDelta : ∀ source, + ((whnfNoDeltaForDefEq source).run methods).PreservesInferOnly) + (left right : KExpr .anon) + (leftHead rightHead : Option (KId .anon)) + (leftDelta rightDelta : Bool) : + ((defEqLazyDeltaStepAfterDeltaClassification left right leftHead rightHead + leftDelta rightDelta).run methods).PreservesInferOnly := by + unfold defEqLazyDeltaStepAfterDeltaClassification + by_cases hleftOnly : leftDelta && !rightDelta + · simp only [hleftOnly, if_true] + refine bind_preservesInferOnly + (tryUnfoldProjApp_preservesInferOnly hnoDelta right) ?_ + intro result + cases result with + | some reduced => + exact TcM.PreservesInferOnly.pure + (BoundedStep.next (left, reduced)) + | none => + exact defEqLazyDeltaStepAfterProjectionMiss_preservesInferOnly hmethods + hcheapNoDelta left right leftHead rightHead leftDelta rightDelta + · simp only [hleftOnly, Bool.false_eq_true, if_false] + by_cases hrightOnly : rightDelta && !leftDelta + · simp only [hrightOnly, if_true] + refine bind_preservesInferOnly + (tryUnfoldProjApp_preservesInferOnly hnoDelta left) ?_ + intro result + cases result with + | some reduced => + exact TcM.PreservesInferOnly.pure + (BoundedStep.next (reduced, right)) + | none => + exact + defEqLazyDeltaStepAfterProjectionMiss_preservesInferOnly hmethods + hcheapNoDelta left right leftHead rightHead leftDelta rightDelta + · simp only [hrightOnly, Bool.false_eq_true, if_false, pure_bind] + exact defEqLazyDeltaStepAfterProjectionMiss_preservesInferOnly hmethods + hcheapNoDelta left right leftHead rightHead leftDelta rightDelta + +theorem defEqLazyDeltaStepAfterAcceleratorMiss_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hnoDelta : ∀ source, + ((whnfNoDelta source).run methods).PreservesInferOnly) + (hcheapNoDelta : ∀ source, + ((whnfNoDeltaForDefEq source).run methods).PreservesInferOnly) + (left right : KExpr .anon) : + ((defEqLazyDeltaStepAfterAcceleratorMiss left right).run + methods).PreservesInferOnly := by + unfold defEqLazyDeltaStepAfterAcceleratorMiss + refine bind_preservesInferOnly + (classifyDeltaHead_preservesInferOnly left) ?_ + intro leftDelta + refine bind_preservesInferOnly + (classifyDeltaHead_preservesInferOnly right) ?_ + intro rightDelta + by_cases hnone : !leftDelta && !rightDelta + · simp only [hnone, if_true] + exact TcM.PreservesInferOnly.pure + (BoundedStep.done (LazyDeltaLoopResult.stopped left right)) + · simp only [hnone, Bool.false_eq_true, if_false, pure_bind] + exact defEqLazyDeltaStepAfterDeltaClassification_preservesInferOnly + hmethods hnoDelta hcheapNoDelta left right (headConstId left) + (headConstId right) leftDelta rightDelta + +theorem defEqLazyDeltaStepAfterNatMiss_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hnoDelta : ∀ source, + ((whnfNoDelta source).run methods).PreservesInferOnly) + (hcheapNoDelta : ∀ source, + ((whnfNoDeltaForDefEq source).run methods).PreservesInferOnly) + (left right : KExpr .anon) : + ((defEqLazyDeltaStepAfterNatMiss left right).run + methods).PreservesInferOnly := by + unfold defEqLazyDeltaStepAfterNatMiss + refine bind_preservesInferOnly + (tryReduceNative_preservesInferOnly hmethods left) ?_ + intro leftNative + cases leftNative with + | some reduced => + refine bind_preservesInferOnly + (isDefEqCall_preservesInferOnly hmethods reduced right) ?_ + intro answer + exact TcM.PreservesInferOnly.pure + (BoundedStep.done (LazyDeltaLoopResult.answer answer)) + | none => + simp only [pure_bind] + refine bind_preservesInferOnly + (tryReduceNative_preservesInferOnly hmethods right) ?_ + intro rightNative + cases rightNative with + | some reduced => + refine bind_preservesInferOnly + (isDefEqCall_preservesInferOnly hmethods left reduced) ?_ + intro answer + exact TcM.PreservesInferOnly.pure + (BoundedStep.done (LazyDeltaLoopResult.answer answer)) + | none => + refine bind_preservesInferOnly + (tryReduceDecidable_preservesInferOnly hmethods left) ?_ + intro leftDecidable + cases leftDecidable with + | some reduced => + refine bind_preservesInferOnly + (isDefEqCall_preservesInferOnly hmethods reduced right) ?_ + intro answer + exact TcM.PreservesInferOnly.pure + (BoundedStep.done (LazyDeltaLoopResult.answer answer)) + | none => + refine bind_preservesInferOnly + (tryReduceDecidable_preservesInferOnly hmethods right) ?_ + intro rightDecidable + cases rightDecidable with + | some reduced => + refine bind_preservesInferOnly + (isDefEqCall_preservesInferOnly hmethods left reduced) ?_ + intro answer + exact TcM.PreservesInferOnly.pure + (BoundedStep.done (LazyDeltaLoopResult.answer answer)) + | none => + exact + defEqLazyDeltaStepAfterAcceleratorMiss_preservesInferOnly + hmethods hnoDelta hcheapNoDelta left right + +theorem defEqLazyDeltaStepAfterOffsetMiss_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hnoDelta : ∀ source, + ((whnfNoDelta source).run methods).PreservesInferOnly) + (hcheapNoDelta : ∀ source, + ((whnfNoDeltaForDefEq source).run methods).PreservesInferOnly) + (left right : KExpr .anon) : + ((defEqLazyDeltaStepAfterOffsetMiss (left, right)).run + methods).PreservesInferOnly := by + unfold defEqLazyDeltaStepAfterOffsetMiss + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind TcM.PreservesInferOnly.get + intro state + by_cases hnat : (!left.hasFVars && !right.hasFVars) || state.eagerReduce + · simp only [hnat, if_true] + apply TcM.PreservesInferOnly.bind + (tryReduceNat_preservesInferOnly hmethods left) + intro leftNat + cases leftNat with + | some reduced => + apply TcM.PreservesInferOnly.bind + (isDefEqCall_preservesInferOnly hmethods reduced right) + intro answer + exact TcM.PreservesInferOnly.pure + (BoundedStep.done (LazyDeltaLoopResult.answer answer)) + | none => + apply TcM.PreservesInferOnly.bind + (tryReduceNat_preservesInferOnly hmethods right) + intro rightNat + cases rightNat with + | some reduced => + apply TcM.PreservesInferOnly.bind + (isDefEqCall_preservesInferOnly hmethods left reduced) + intro answer + exact TcM.PreservesInferOnly.pure + (BoundedStep.done (LazyDeltaLoopResult.answer answer)) + | none => + exact defEqLazyDeltaStepAfterNatMiss_preservesInferOnly hmethods + hnoDelta hcheapNoDelta left right + · simp only [hnat, Bool.false_eq_true, if_false, pure_bind] + exact defEqLazyDeltaStepAfterNatMiss_preservesInferOnly hmethods hnoDelta + hcheapNoDelta left right + +theorem defEqLazyDeltaStep_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hnoDelta : ∀ source, + ((whnfNoDelta source).run methods).PreservesInferOnly) + (hcheapNoDelta : ∀ source, + ((whnfNoDeltaForDefEq source).run methods).PreservesInferOnly) + (state : KExpr .anon × KExpr .anon) : + ((defEqLazyDeltaStep state).run methods).PreservesInferOnly := by + rcases state with ⟨left, right⟩ + unfold defEqLazyDeltaStep + refine bind_preservesInferOnly + (tryDefEqOffset_preservesInferOnly hmethods left right) ?_ + intro result + cases result with + | some answer => + exact TcM.PreservesInferOnly.pure + (BoundedStep.done (LazyDeltaLoopResult.answer answer)) + | none => + exact defEqLazyDeltaStepAfterOffsetMiss_preservesInferOnly hmethods + hnoDelta hcheapNoDelta left right + +theorem runDefEqLazyDelta_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hnoDelta : ∀ source, + ((whnfNoDelta source).run methods).PreservesInferOnly) + (hcheapNoDelta : ∀ source, + ((whnfNoDeltaForDefEq source).run methods).PreservesInferOnly) + (left right : KExpr .anon) : + ((runDefEqLazyDelta left right).run methods).PreservesInferOnly := by + unfold runDefEqLazyDelta + exact runBounded_preservesInferOnly + (defEqLazyDeltaStep_preservesInferOnly hmethods hnoDelta hcheapNoDelta) _ + (left, right) + +theorem isDefEqAfterLazyDeltaStopped_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hwhnf : ∀ source, + ((whnf source).run methods).PreservesInferOnly) + (hcore : ∀ source, + ((whnfCore source).run methods).PreservesInferOnly) + (hnoDelta : ∀ source, + ((whnfNoDelta source).run methods).PreservesInferOnly) + (left right : KExpr .anon) : + ((isDefEqAfterLazyDeltaStopped left right).run + methods).PreservesInferOnly := by + unfold isDefEqAfterLazyDeltaStopped + refine bind_preservesInferOnly + (tryStructuralCongruence_preservesInferOnly hmethods hcore hnoDelta left + right) ?_ + intro structural + cases structural with + | true => exact TcM.PreservesInferOnly.pure true + | false => + simp only [Bool.false_eq_true, if_false, pure_bind] + refine bind_preservesInferOnly (hcore left) ?_ + intro leftCore + refine bind_preservesInferOnly (hcore right) ?_ + intro rightCore + by_cases hchanged : + (leftCore.addr != left.addr) || (rightCore.addr != right.addr) + · simp only [hchanged, if_true] + refine bind_preservesInferOnly + (isDefEqCall_preservesInferOnly hmethods leftCore rightCore) ?_ + intro answer + exact TcM.PreservesInferOnly.pure answer + · simp only [hchanged, Bool.false_eq_true, if_false] + by_cases haddress : leftCore.addr == rightCore.addr + · simp only [haddress, if_true] + exact TcM.PreservesInferOnly.pure true + · simp only [haddress, Bool.false_eq_true, if_false] + refine bind_preservesInferOnly + (quickDefEq_preservesInferOnly hmethods leftCore rightCore) ?_ + intro quick + cases quick with + | true => exact TcM.PreservesInferOnly.pure true + | false => + simp only [Bool.false_eq_true, if_false] + refine bind_preservesInferOnly + (tryDefEqApp_preservesInferOnly hmethods leftCore rightCore) ?_ + intro application + cases application with + | true => exact TcM.PreservesInferOnly.pure true + | false => + simp only [Bool.false_eq_true, if_false] + exact isDefEqWhnf_preservesInferOnly hmethods hwhnf hnoDelta + leftCore rightCore + +theorem isDefEqInnerAfterProofIrrelevance_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hwhnf : ∀ source, + ((whnf source).run methods).PreservesInferOnly) + (hcore : ∀ source, + ((whnfCore source).run methods).PreservesInferOnly) + (hnoDelta : ∀ source, + ((whnfNoDelta source).run methods).PreservesInferOnly) + (hcheapNoDelta : ∀ source, + ((whnfNoDeltaForDefEq source).run methods).PreservesInferOnly) + (left right : KExpr .anon) : + ((isDefEqInnerAfterProofIrrelevance left right).run + methods).PreservesInferOnly := by + unfold isDefEqInnerAfterProofIrrelevance + refine bind_preservesInferOnly + (runDefEqLazyDelta_preservesInferOnly hmethods hnoDelta hcheapNoDelta left + right) ?_ + intro result + cases result with + | answer answer => exact TcM.PreservesInferOnly.pure answer + | stopped stoppedLeft stoppedRight => + exact isDefEqAfterLazyDeltaStopped_preservesInferOnly hmethods hwhnf + hcore hnoDelta stoppedLeft stoppedRight + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/DefEqNatPolicy.lean b/Ix/Tc/Verify/Check/DefEqNatPolicy.lean new file mode 100644 index 000000000..ce7741290 --- /dev/null +++ b/Ix/Tc/Verify/Check/DefEqNatPolicy.lean @@ -0,0 +1,193 @@ +import Ix.Tc.Verify.Check.DefEqBasicPolicy + +/-! +# Operational policy for DefEq Nat and String bridges + +These proofs cover literal/constructor peeling, generalized Nat-offset +decomposition and reconstruction, and String-literal expansion. Every +successful recursive comparison is routed through the framed predecessor +method table; all misses and allocation errors preserve the same policy. +-/ + +namespace Ix.Tc + +namespace RecM + +attribute [local irreducible] strLitToConstructor + +theorem natOffsetDecompose_preservesInferOnly + {methods : Methods .anon} (source : KExpr .anon) : + ((natOffsetDecompose source).run methods).PreservesInferOnly := by + unfold natOffsetDecompose + refine bind_preservesInferOnly (prims_preservesInferOnly methods) ?_ + intro primitives + split + · exact TcM.PreservesInferOnly.pure _ + · simp only [pure_bind] + refine bind_preservesInferOnly + (natOffset_preservesInferOnly source 0) ?_ + intro result + cases result with + | none => exact TcM.PreservesInferOnly.pure none + | some offsetResult => + rcases offsetResult with ⟨base, offset⟩ + simp only + split + · exact TcM.PreservesInferOnly.pure none + · refine bind_preservesInferOnly (prims_preservesInferOnly methods) ?_ + intro currentPrimitives + split <;> exact TcM.PreservesInferOnly.pure _ + +theorem natOffsetRebuild_preservesInferOnly + {methods : Methods .anon} (base : Option (KExpr .anon)) (offset : Nat) : + ((natOffsetRebuild base offset).run methods).PreservesInferOnly := by + unfold natOffsetRebuild + cases base with + | none => exact TcM.PreservesInferOnly.pure _ + | some source => + cases hzero : (offset == 0) with + | true => + simp only [if_true] + exact TcM.PreservesInferOnly.pure source + | false => + simp only [Bool.false_eq_true, if_false, pure_bind] + exact mkNatAdd_preservesInferOnly source (natExprFromValue offset) + +theorem isDefEqNatAfterLiteral_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (left right : KExpr .anon) : + ((isDefEqNatAfterLiteral left right).run + methods).PreservesInferOnly := by + unfold isDefEqNatAfterLiteral + refine bind_preservesInferOnly (isNatZero_preservesInferOnly left) ?_ + intro leftZero + refine bind_preservesInferOnly (isNatZero_preservesInferOnly right) ?_ + intro rightZero + cases hzero : (leftZero && rightZero) with + | true => + simp only [if_true] + exact TcM.PreservesInferOnly.pure true + | false => + simp only [Bool.false_eq_true, if_false, pure_bind] + refine bind_preservesInferOnly (natSuccOf_preservesInferOnly left) ?_ + intro leftPredecessor + refine bind_preservesInferOnly (natSuccOf_preservesInferOnly right) ?_ + intro rightPredecessor + cases leftPredecessor with + | none => exact TcM.PreservesInferOnly.pure false + | some leftPred => + cases rightPredecessor with + | none => exact TcM.PreservesInferOnly.pure false + | some rightPred => + exact isDefEqCall_preservesInferOnly hmethods leftPred rightPred + +theorem isDefEqNat_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (left right : KExpr .anon) : + ((isDefEqNat left right).run methods).PreservesInferOnly := by + unfold isDefEqNat + cases left <;> cases right <;> + first + | exact TcM.PreservesInferOnly.pure _ + | exact isDefEqNatAfterLiteral_preservesInferOnly hmethods _ _ + +theorem tryDefEqOffsetAfterCandidates_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (left right : KExpr .anon) : + ((tryDefEqOffsetAfterCandidates left right).run + methods).PreservesInferOnly := by + unfold tryDefEqOffsetAfterCandidates + refine bind_preservesInferOnly + (natOffsetDecompose_preservesInferOnly left) ?_ + intro leftResult + cases leftResult with + | none => exact TcM.PreservesInferOnly.pure none + | some leftParts => + rcases leftParts with ⟨leftBase, leftOffset⟩ + simp only + refine bind_preservesInferOnly + (natOffsetDecompose_preservesInferOnly right) ?_ + intro rightResult + cases rightResult with + | none => exact TcM.PreservesInferOnly.pure none + | some rightParts => + rcases rightParts with ⟨rightBase, rightOffset⟩ + simp only + cases hshared : (min leftOffset rightOffset == 0) with + | true => + simp only [if_true] + exact TcM.PreservesInferOnly.pure none + | false => + simp only [Bool.false_eq_true, if_false, pure_bind] + refine bind_preservesInferOnly + (natOffsetRebuild_preservesInferOnly leftBase + (leftOffset - min leftOffset rightOffset)) ?_ + intro leftRemainder + refine bind_preservesInferOnly + (natOffsetRebuild_preservesInferOnly rightBase + (rightOffset - min leftOffset rightOffset)) ?_ + intro rightRemainder + refine bind_preservesInferOnly + (isDefEqCall_preservesInferOnly hmethods leftRemainder + rightRemainder) ?_ + intro answer + exact TcM.PreservesInferOnly.pure (some answer) + +theorem tryDefEqOffsetAfterZeroMiss_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (left right : KExpr .anon) : + ((tryDefEqOffsetAfterZeroMiss left right).run + methods).PreservesInferOnly := by + unfold tryDefEqOffsetAfterZeroMiss + refine bind_preservesInferOnly (prims_preservesInferOnly methods) ?_ + intro primitives + split + · exact TcM.PreservesInferOnly.pure none + · simp only [pure_bind] + exact tryDefEqOffsetAfterCandidates_preservesInferOnly hmethods left right + +theorem tryDefEqOffsetAfterLiteral_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (left right : KExpr .anon) : + ((tryDefEqOffsetAfterLiteral left right).run + methods).PreservesInferOnly := by + unfold tryDefEqOffsetAfterLiteral + refine bind_preservesInferOnly (isNatZero_preservesInferOnly left) ?_ + intro leftZero + refine bind_preservesInferOnly (isNatZero_preservesInferOnly right) ?_ + intro rightZero + cases hzero : (leftZero && rightZero) with + | true => + simp only [if_true] + exact TcM.PreservesInferOnly.pure (some true) + | false => + simp only [Bool.false_eq_true, if_false, pure_bind] + exact tryDefEqOffsetAfterZeroMiss_preservesInferOnly hmethods left right + +theorem tryDefEqOffset_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (left right : KExpr .anon) : + ((tryDefEqOffset left right).run methods).PreservesInferOnly := by + unfold tryDefEqOffset + cases left <;> cases right <;> simp only [pure_bind] + all_goals + first + | exact TcM.PreservesInferOnly.pure _ + | exact tryDefEqOffsetAfterLiteral_preservesInferOnly hmethods _ _ + +theorem tryStringLitExpansion_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (literal other : KExpr .anon) : + ((tryStringLitExpansion literal other).run + methods).PreservesInferOnly := by + cases literal <;> simp only [tryStringLitExpansion] + case str value blob info => + refine bind_preservesInferOnly (methods := methods) + (strLitToConstructor_preservesInferOnly (methods := methods) value) ?_ + intro expanded + exact isDefEqCall_preservesInferOnly hmethods expanded other + all_goals exact TcM.PreservesInferOnly.pure false + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/DefEqPipelinePolicy.lean b/Ix/Tc/Verify/Check/DefEqPipelinePolicy.lean new file mode 100644 index 000000000..ff1d54d36 --- /dev/null +++ b/Ix/Tc/Verify/Check/DefEqPipelinePolicy.lean @@ -0,0 +1,242 @@ +import Ix.Tc.Verify.Check.DefEqLazyDeltaPolicy + +/-! +# Operational policy for the DefEq comparison pipeline + +This module composes the proved primitive, normalization, proposition, and +lazy-delta policies across the exact production `isDefEqInner` tier order. +It stops at the cache/depth shell owned by `isDefEq` itself. +-/ + +namespace Ix.Tc + +namespace RecM + +theorem isDefEqInnerAfterNoDeltaPass_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hwhnf : ∀ source, + ((whnf source).run methods).PreservesInferOnly) + (hcore : ∀ source, + ((whnfCore source).run methods).PreservesInferOnly) + (hnoDelta : ∀ source, + ((whnfNoDelta source).run methods).PreservesInferOnly) + (hcheapNoDelta : ∀ source, + ((whnfNoDeltaForDefEq source).run methods).PreservesInferOnly) + (left right : KExpr .anon) : + ((isDefEqInnerAfterNoDeltaPass left right).run + methods).PreservesInferOnly := by + unfold isDefEqInnerAfterNoDeltaPass + refine bind_preservesInferOnly + (tryProofIrrel_preservesInferOnly hmethods hwhnf left right) ?_ + intro proofIrrelevant + cases proofIrrelevant with + | true => exact TcM.PreservesInferOnly.pure true + | false => + simp only [Bool.false_eq_true, if_false, pure_bind] + exact isDefEqInnerAfterProofIrrelevance_preservesInferOnly hmethods + hwhnf hcore hnoDelta hcheapNoDelta left right + +theorem isDefEqInnerAfterCorePass_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hwhnf : ∀ source, + ((whnf source).run methods).PreservesInferOnly) + (hcore : ∀ source, + ((whnfCore source).run methods).PreservesInferOnly) + (hnoDelta : ∀ source, + ((whnfNoDelta source).run methods).PreservesInferOnly) + (hcheapNoDelta : ∀ source, + ((whnfNoDeltaForDefEq source).run methods).PreservesInferOnly) + (left right : KExpr .anon) : + ((isDefEqInnerAfterCorePass left right).run + methods).PreservesInferOnly := by + unfold isDefEqInnerAfterCorePass + refine bind_preservesInferOnly (hcheapNoDelta left) ?_ + intro normalizedLeft + refine bind_preservesInferOnly (hcheapNoDelta right) ?_ + intro normalizedRight + by_cases haddress : normalizedLeft.addr == normalizedRight.addr + · simp only [haddress, if_true] + exact TcM.PreservesInferOnly.pure true + · simp only [haddress, Bool.false_eq_true, if_false, pure_bind] + refine bind_preservesInferOnly + (quickDefEq_preservesInferOnly hmethods normalizedLeft normalizedRight) ?_ + intro quick + cases quick with + | true => exact TcM.PreservesInferOnly.pure true + | false => + simp only [Bool.false_eq_true, if_false] + exact isDefEqInnerAfterNoDeltaPass_preservesInferOnly hmethods hwhnf + hcore hnoDelta hcheapNoDelta normalizedLeft normalizedRight + +theorem isDefEqInnerAfterStringExpansion_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hwhnf : ∀ source, + ((whnf source).run methods).PreservesInferOnly) + (hcore : ∀ source, + ((whnfCore source).run methods).PreservesInferOnly) + (hnoDelta : ∀ source, + ((whnfNoDelta source).run methods).PreservesInferOnly) + (hcheapCore : ∀ source, + ((whnfCoreForDefEq source).run methods).PreservesInferOnly) + (hcheapNoDelta : ∀ source, + ((whnfNoDeltaForDefEq source).run methods).PreservesInferOnly) + (left right : KExpr .anon) : + ((isDefEqInnerAfterStringExpansion left right).run + methods).PreservesInferOnly := by + unfold isDefEqInnerAfterStringExpansion + refine bind_preservesInferOnly (hcheapCore left) ?_ + intro coreLeft + refine bind_preservesInferOnly (hcheapCore right) ?_ + intro coreRight + by_cases haddress : coreLeft.addr == coreRight.addr + · simp only [haddress, if_true] + exact TcM.PreservesInferOnly.pure true + · simp only [haddress, Bool.false_eq_true, if_false, pure_bind] + refine bind_preservesInferOnly + (quickDefEq_preservesInferOnly hmethods coreLeft coreRight) ?_ + intro quick + cases quick with + | true => exact TcM.PreservesInferOnly.pure true + | false => + simp only [Bool.false_eq_true, if_false] + exact isDefEqInnerAfterCorePass_preservesInferOnly hmethods hwhnf + hcore hnoDelta hcheapNoDelta left right + +theorem isDefEqInnerAfterBoolTrue_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hwhnf : ∀ source, + ((whnf source).run methods).PreservesInferOnly) + (hcore : ∀ source, + ((whnfCore source).run methods).PreservesInferOnly) + (hnoDelta : ∀ source, + ((whnfNoDelta source).run methods).PreservesInferOnly) + (hcheapCore : ∀ source, + ((whnfCoreForDefEq source).run methods).PreservesInferOnly) + (hcheapNoDelta : ∀ source, + ((whnfNoDeltaForDefEq source).run methods).PreservesInferOnly) + (left right : KExpr .anon) : + ((isDefEqInnerAfterBoolTrue left right).run + methods).PreservesInferOnly := by + unfold isDefEqInnerAfterBoolTrue + by_cases hstring : hasStringLiteralPair left right + · simp only [hstring, if_true] + refine bind_preservesInferOnly + (tryStringLitExpansion_preservesInferOnly hmethods left right) ?_ + intro forward + cases forward with + | true => exact TcM.PreservesInferOnly.pure true + | false => + simp only [Bool.false_eq_true, if_false, pure_bind] + refine bind_preservesInferOnly + (tryStringLitExpansion_preservesInferOnly hmethods right left) ?_ + intro backward + cases backward with + | true => exact TcM.PreservesInferOnly.pure true + | false => + simp only [Bool.false_eq_true, if_false] + exact isDefEqInnerAfterStringExpansion_preservesInferOnly + hmethods hwhnf hcore hnoDelta hcheapCore hcheapNoDelta left right + · simp only [hstring, Bool.false_eq_true, if_false] + exact isDefEqInnerAfterStringExpansion_preservesInferOnly hmethods hwhnf + hcore hnoDelta hcheapCore hcheapNoDelta left right + +theorem isDefEqInnerAfterFirstBoolGuardMiss_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hwhnf : ∀ source, + ((whnf source).run methods).PreservesInferOnly) + (hcore : ∀ source, + ((whnfCore source).run methods).PreservesInferOnly) + (hnoDelta : ∀ source, + ((whnfNoDelta source).run methods).PreservesInferOnly) + (hcheapCore : ∀ source, + ((whnfCoreForDefEq source).run methods).PreservesInferOnly) + (hcheapNoDelta : ∀ source, + ((whnfNoDeltaForDefEq source).run methods).PreservesInferOnly) + (left right : KExpr .anon) : + ((isDefEqInnerAfterFirstBoolGuardMiss left right).run + methods).PreservesInferOnly := by + unfold isDefEqInnerAfterFirstBoolGuardMiss + refine bind_preservesInferOnly (isBoolTrue_preservesInferOnly left) ?_ + intro leftIsTrue + refine bind_preservesInferOnly + (boolTrueReductionAllowed_preservesInferOnly right) ?_ + intro rightAllowed + by_cases hguard : leftIsTrue && rightAllowed + · simp only [hguard, if_true] + refine bind_preservesInferOnly + (whnfIsBoolTrue_preservesInferOnly hwhnf right) ?_ + intro normalizedTrue + cases normalizedTrue with + | true => exact TcM.PreservesInferOnly.pure true + | false => + simp only [Bool.false_eq_true, if_false, pure_bind] + exact isDefEqInnerAfterBoolTrue_preservesInferOnly hmethods hwhnf + hcore hnoDelta hcheapCore hcheapNoDelta left right + · simp only [hguard, Bool.false_eq_true, if_false] + exact isDefEqInnerAfterBoolTrue_preservesInferOnly hmethods hwhnf hcore + hnoDelta hcheapCore hcheapNoDelta left right + +theorem isDefEqInnerAfterQuick_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hwhnf : ∀ source, + ((whnf source).run methods).PreservesInferOnly) + (hcore : ∀ source, + ((whnfCore source).run methods).PreservesInferOnly) + (hnoDelta : ∀ source, + ((whnfNoDelta source).run methods).PreservesInferOnly) + (hcheapCore : ∀ source, + ((whnfCoreForDefEq source).run methods).PreservesInferOnly) + (hcheapNoDelta : ∀ source, + ((whnfNoDeltaForDefEq source).run methods).PreservesInferOnly) + (left right : KExpr .anon) : + ((isDefEqInnerAfterQuick left right).run + methods).PreservesInferOnly := by + unfold isDefEqInnerAfterQuick + refine bind_preservesInferOnly (isBoolTrue_preservesInferOnly right) ?_ + intro rightIsTrue + refine bind_preservesInferOnly + (boolTrueReductionAllowed_preservesInferOnly left) ?_ + intro leftAllowed + by_cases hguard : rightIsTrue && leftAllowed + · simp only [hguard, if_true] + refine bind_preservesInferOnly + (whnfIsBoolTrue_preservesInferOnly hwhnf left) ?_ + intro normalizedTrue + cases normalizedTrue with + | true => exact TcM.PreservesInferOnly.pure true + | false => + simp only [Bool.false_eq_true, if_false, pure_bind] + exact isDefEqInnerAfterBoolTrue_preservesInferOnly hmethods hwhnf + hcore hnoDelta hcheapCore hcheapNoDelta left right + · simp only [hguard, Bool.false_eq_true, if_false] + exact isDefEqInnerAfterFirstBoolGuardMiss_preservesInferOnly hmethods + hwhnf hcore hnoDelta hcheapCore hcheapNoDelta left right + +theorem isDefEqInner_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hwhnf : ∀ source, + ((whnf source).run methods).PreservesInferOnly) + (hcore : ∀ source, + ((whnfCore source).run methods).PreservesInferOnly) + (hnoDelta : ∀ source, + ((whnfNoDelta source).run methods).PreservesInferOnly) + (hcheapCore : ∀ source, + ((whnfCoreForDefEq source).run methods).PreservesInferOnly) + (hcheapNoDelta : ∀ source, + ((whnfNoDeltaForDefEq source).run methods).PreservesInferOnly) + (left right : KExpr .anon) : + ((isDefEqInner left right).run methods).PreservesInferOnly := by + unfold isDefEqInner + refine bind_preservesInferOnly + (quickDefEq_preservesInferOnly hmethods left right) ?_ + intro quick + cases quick with + | true => exact TcM.PreservesInferOnly.pure true + | false => + simp only [Bool.false_eq_true, if_false, pure_bind] + exact isDefEqInnerAfterQuick_preservesInferOnly hmethods hwhnf hcore + hnoDelta hcheapCore hcheapNoDelta left right + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/DefEqProjectionDeltaPolicy.lean b/Ix/Tc/Verify/Check/DefEqProjectionDeltaPolicy.lean new file mode 100644 index 000000000..e4240fddf --- /dev/null +++ b/Ix/Tc/Verify/Check/DefEqProjectionDeltaPolicy.lean @@ -0,0 +1,437 @@ +import Ix.Tc.Verify.Check.DefEqFinalWhnfPolicy + +/-! +# Operational policy for projection-directed DefEq delta reduction + +This module verifies the compact lazy-delta loop used by projection +congruence, together with its app-spine comparator. Delta lookups, WHNF +callbacks, projection reduction, bounded iteration, and recursive equality +all preserve the inference-policy bit on success and error. +-/ + +namespace Ix.Tc + +namespace RecM + +theorem tryUnfoldProjApp_preservesInferOnly + {methods : Methods .anon} + (hnoDelta : ∀ source, + ((whnfNoDelta source).run methods).PreservesInferOnly) + (source : KExpr .anon) : + ((tryUnfoldProjApp source).run methods).PreservesInferOnly := by + rcases hspine : source.collectSpine with ⟨head, arguments⟩ + unfold tryUnfoldProjApp + simp only [hspine] + cases head with + | prj projectionId field value info => + simp only [pure_bind] + refine bind_preservesInferOnly (hnoDelta source) ?_ + intro reduced + split <;> exact TcM.PreservesInferOnly.pure _ + | var | fvar | sort | const | app | lam | all | letE | nat | str => + exact TcM.PreservesInferOnly.pure none + +theorem finishLazyDeltaReductionStep_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (left right : KExpr .anon) : + ((finishLazyDeltaReductionStep left right).run + methods).PreservesInferOnly := by + unfold finishLazyDeltaReductionStep + refine bind_preservesInferOnly + (quickDefEq_preservesInferOnly hmethods left right) ?_ + intro equal + split <;> exact TcM.PreservesInferOnly.pure _ + +theorem lazyDeltaReductionStepWithLeftDelta_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hcore : ∀ source, + ((whnfCore source).run methods).PreservesInferOnly) + (left right : KExpr .anon) : + ((lazyDeltaReductionStepWithLeftDelta left right).run + methods).PreservesInferOnly := by + unfold lazyDeltaReductionStepWithLeftDelta + refine bind_preservesInferOnly + (deltaUnfoldOne_preservesInferOnly left) ?_ + intro unfoldedResult + cases unfoldedResult with + | none => exact TcM.PreservesInferOnly.pure (LazyDeltaStep.unknown, left, right) + | some unfolded => + refine bind_preservesInferOnly (hcore unfolded) ?_ + intro reduced + exact finishLazyDeltaReductionStep_preservesInferOnly hmethods reduced + right + +theorem lazyDeltaReductionStepWithRightDelta_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hcore : ∀ source, + ((whnfCore source).run methods).PreservesInferOnly) + (left right : KExpr .anon) : + ((lazyDeltaReductionStepWithRightDelta left right).run + methods).PreservesInferOnly := by + unfold lazyDeltaReductionStepWithRightDelta + refine bind_preservesInferOnly + (deltaUnfoldOne_preservesInferOnly right) ?_ + intro unfoldedResult + cases unfoldedResult with + | none => exact TcM.PreservesInferOnly.pure (LazyDeltaStep.unknown, left, right) + | some unfolded => + refine bind_preservesInferOnly (hcore unfolded) ?_ + intro reduced + exact finishLazyDeltaReductionStep_preservesInferOnly hmethods left + reduced + +theorem lazyDeltaReductionStepAfterSameHeadMiss_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hcore : ∀ source, + ((whnfCore source).run methods).PreservesInferOnly) + (left right : KExpr .anon) : + ((lazyDeltaReductionStepAfterSameHeadMiss left right).run + methods).PreservesInferOnly := by + unfold lazyDeltaReductionStepAfterSameHeadMiss + refine bind_preservesInferOnly + (deltaUnfoldOne_preservesInferOnly left) ?_ + intro leftUnfolded + refine bind_preservesInferOnly + (deltaUnfoldOne_preservesInferOnly right) ?_ + intro rightUnfolded + cases leftUnfolded with + | none => + cases rightUnfolded with + | none => exact TcM.PreservesInferOnly.pure (LazyDeltaStep.unknown, left, right) + | some rightBody => + refine bind_preservesInferOnly (hcore rightBody) ?_ + intro rightReduced + exact finishLazyDeltaReductionStep_preservesInferOnly hmethods left + rightReduced + | some leftBody => + cases rightUnfolded with + | none => + refine bind_preservesInferOnly (hcore leftBody) ?_ + intro leftReduced + exact finishLazyDeltaReductionStep_preservesInferOnly hmethods + leftReduced right + | some rightBody => + refine bind_preservesInferOnly (hcore leftBody) ?_ + intro leftReduced + refine bind_preservesInferOnly (hcore rightBody) ?_ + intro rightReduced + exact finishLazyDeltaReductionStep_preservesInferOnly hmethods + leftReduced rightReduced + +theorem lazyDeltaReductionStepWithEqualRank_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hcore : ∀ source, + ((whnfCore source).run methods).PreservesInferOnly) + (left right : KExpr .anon) (leftId rightId : KId .anon) : + ((lazyDeltaReductionStepWithEqualRank left right leftId rightId).run + methods).PreservesInferOnly := by + unfold lazyDeltaReductionStepWithEqualRank + refine bind_preservesInferOnly (isRegular_preservesInferOnly leftId) ?_ + intro regular + by_cases hguard : leftId.addr == rightId.addr && regular + · simp only [hguard, if_true] + refine bind_preservesInferOnly + (trySameHeadSpine_preservesInferOnly hmethods left right) ?_ + intro result + cases result with + | none => + exact lazyDeltaReductionStepAfterSameHeadMiss_preservesInferOnly + hmethods hcore left right + | some answer => + cases answer with + | true => + exact TcM.PreservesInferOnly.pure + (LazyDeltaStep.equal, left, right) + | false => + exact lazyDeltaReductionStepAfterSameHeadMiss_preservesInferOnly + hmethods hcore left right + · simp only [hguard, Bool.false_eq_true, if_false, pure_bind] + exact lazyDeltaReductionStepAfterSameHeadMiss_preservesInferOnly hmethods + hcore left right + +theorem lazyDeltaReductionStepWithBothDelta_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hcore : ∀ source, + ((whnfCore source).run methods).PreservesInferOnly) + (left right : KExpr .anon) + (leftHead rightHead : Option (KId .anon)) : + ((lazyDeltaReductionStepWithBothDelta left right leftHead rightHead).run + methods).PreservesInferOnly := by + unfold lazyDeltaReductionStepWithBothDelta + refine bind_preservesInferOnly + (defRankId_preservesInferOnly leftHead.get!) ?_ + intro leftRank + refine bind_preservesInferOnly + (defRankId_preservesInferOnly rightHead.get!) ?_ + intro rightRank + simp only + split + · exact lazyDeltaReductionStepWithLeftDelta_preservesInferOnly hmethods + hcore left right + · split + · exact lazyDeltaReductionStepWithRightDelta_preservesInferOnly hmethods + hcore left right + · exact lazyDeltaReductionStepWithEqualRank_preservesInferOnly hmethods + hcore left right leftHead.get! rightHead.get! + +theorem lazyDeltaReductionStepAfterActive_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hcore : ∀ source, + ((whnfCore source).run methods).PreservesInferOnly) + (hnoDelta : ∀ source, + ((whnfNoDelta source).run methods).PreservesInferOnly) + (left right : KExpr .anon) + (leftHead rightHead : Option (KId .anon)) + (leftDelta rightDelta : Bool) : + ((lazyDeltaReductionStepAfterActive left right leftHead rightHead leftDelta + rightDelta).run methods).PreservesInferOnly := by + unfold lazyDeltaReductionStepAfterActive + by_cases hleftOnly : leftDelta && !rightDelta + · simp only [hleftOnly, if_true] + refine bind_preservesInferOnly + (tryUnfoldProjApp_preservesInferOnly hnoDelta right) ?_ + intro projectionResult + cases projectionResult with + | some reduced => + exact finishLazyDeltaReductionStep_preservesInferOnly hmethods left + reduced + | none => + exact lazyDeltaReductionStepWithLeftDelta_preservesInferOnly hmethods + hcore left right + · simp only [hleftOnly, Bool.false_eq_true, if_false] + by_cases hrightOnly : !leftDelta && rightDelta + · simp only [hrightOnly, if_true] + refine bind_preservesInferOnly + (tryUnfoldProjApp_preservesInferOnly hnoDelta left) ?_ + intro projectionResult + cases projectionResult with + | some reduced => + exact finishLazyDeltaReductionStep_preservesInferOnly hmethods + reduced right + | none => + exact lazyDeltaReductionStepWithRightDelta_preservesInferOnly + hmethods hcore left right + · simp only [hrightOnly, Bool.false_eq_true, if_false] + exact lazyDeltaReductionStepWithBothDelta_preservesInferOnly hmethods + hcore left right leftHead rightHead + +theorem lazyDeltaReductionStepAfterClassification_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hcore : ∀ source, + ((whnfCore source).run methods).PreservesInferOnly) + (hnoDelta : ∀ source, + ((whnfNoDelta source).run methods).PreservesInferOnly) + (left right : KExpr .anon) + (leftHead rightHead : Option (KId .anon)) + (leftDelta rightDelta : Bool) : + ((lazyDeltaReductionStepAfterClassification left right leftHead rightHead + leftDelta rightDelta).run methods).PreservesInferOnly := by + unfold lazyDeltaReductionStepAfterClassification + split + · exact TcM.PreservesInferOnly.pure + (LazyDeltaStep.unknown, left, right) + · simp only [pure_bind] + exact lazyDeltaReductionStepAfterActive_preservesInferOnly hmethods hcore + hnoDelta left right leftHead rightHead leftDelta rightDelta + +theorem lazyDeltaReductionStep_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hcore : ∀ source, + ((whnfCore source).run methods).PreservesInferOnly) + (hnoDelta : ∀ source, + ((whnfNoDelta source).run methods).PreservesInferOnly) + (left right : KExpr .anon) : + ((lazyDeltaReductionStep left right).run + methods).PreservesInferOnly := by + unfold lazyDeltaReductionStep + refine bind_preservesInferOnly + (classifyDeltaHead_preservesInferOnly left) ?_ + intro leftDelta + refine bind_preservesInferOnly + (classifyDeltaHead_preservesInferOnly right) ?_ + intro rightDelta + exact lazyDeltaReductionStepAfterClassification_preservesInferOnly hmethods + hcore hnoDelta left right (headConstId left) (headConstId right) leftDelta + rightDelta + +theorem lazyDeltaProjReductionStep_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hcore : ∀ source, + ((whnfCore source).run methods).PreservesInferOnly) + (hnoDelta : ∀ source, + ((whnfNoDelta source).run methods).PreservesInferOnly) + (structureId : KId .anon) (field : UInt64) + (state : KExpr .anon × KExpr .anon) : + (((fun current : KExpr .anon × KExpr .anon => do + let (left, right) := current + let (outcome, left, right) ← lazyDeltaReductionStep left right + match outcome with + | .equal => return BoundedStep.done true + | .continue' => return BoundedStep.next (left, right) + | .unknown => + let leftProjection ← tryProjReduce structureId field left + let rightProjection ← tryProjReduce structureId field right + match leftProjection, rightProjection with + | some leftReduced, some rightReduced => + return BoundedStep.done (← isDefEqCall leftReduced rightReduced) + | _, _ => return BoundedStep.done (← isDefEqCall left right)) state).run + methods).PreservesInferOnly := by + rcases state with ⟨left, right⟩ + refine bind_preservesInferOnly + (lazyDeltaReductionStep_preservesInferOnly hmethods hcore hnoDelta left + right) ?_ + intro result + rcases result with ⟨outcome, leftReduced, rightReduced⟩ + cases outcome with + | equal => exact TcM.PreservesInferOnly.pure (BoundedStep.done true) + | continue' => + exact TcM.PreservesInferOnly.pure + (BoundedStep.next (leftReduced, rightReduced)) + | unknown => + refine bind_preservesInferOnly + (tryProjReduce_preservesInferOnly hmethods structureId field + leftReduced) ?_ + intro leftProjection + refine bind_preservesInferOnly + (tryProjReduce_preservesInferOnly hmethods structureId field + rightReduced) ?_ + intro rightProjection + cases leftProjection with + | none => + refine bind_preservesInferOnly + (isDefEqCall_preservesInferOnly hmethods leftReduced + rightReduced) ?_ + intro answer + exact TcM.PreservesInferOnly.pure (BoundedStep.done answer) + | some leftProjection => + cases rightProjection with + | none => + refine bind_preservesInferOnly + (isDefEqCall_preservesInferOnly hmethods leftReduced + rightReduced) ?_ + intro answer + exact TcM.PreservesInferOnly.pure (BoundedStep.done answer) + | some rightProjection => + refine bind_preservesInferOnly + (isDefEqCall_preservesInferOnly hmethods leftProjection + rightProjection) ?_ + intro answer + exact TcM.PreservesInferOnly.pure (BoundedStep.done answer) + +theorem lazyDeltaProjReduction_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hcore : ∀ source, + ((whnfCore source).run methods).PreservesInferOnly) + (hnoDelta : ∀ source, + ((whnfNoDelta source).run methods).PreservesInferOnly) + (structureId : KId .anon) (field : UInt64) + (left right : KExpr .anon) : + ((lazyDeltaProjReduction structureId field left right).run + methods).PreservesInferOnly := by + unfold lazyDeltaProjReduction + simp only + apply runBounded_preservesInferOnly + intro state + rcases state with ⟨currentLeft, currentRight⟩ + refine bind_preservesInferOnly + (lazyDeltaReductionStep_preservesInferOnly hmethods hcore hnoDelta + currentLeft currentRight) ?_ + intro result + rcases result with ⟨outcome, reducedLeft, reducedRight⟩ + cases outcome with + | equal => exact TcM.PreservesInferOnly.pure (BoundedStep.done true) + | continue' => + exact TcM.PreservesInferOnly.pure + (BoundedStep.next (reducedLeft, reducedRight)) + | unknown => + refine bind_preservesInferOnly + (tryProjReduce_preservesInferOnly hmethods structureId field + reducedLeft) ?_ + intro leftProjection + refine bind_preservesInferOnly + (tryProjReduce_preservesInferOnly hmethods structureId field + reducedRight) ?_ + intro rightProjection + cases leftProjection with + | none => + refine bind_preservesInferOnly + (isDefEqCall_preservesInferOnly hmethods reducedLeft + reducedRight) ?_ + intro answer + exact TcM.PreservesInferOnly.pure (BoundedStep.done answer) + | some leftProjection => + cases rightProjection with + | none => + refine bind_preservesInferOnly + (isDefEqCall_preservesInferOnly hmethods reducedLeft + reducedRight) ?_ + intro answer + exact TcM.PreservesInferOnly.pure (BoundedStep.done answer) + | some rightProjection => + refine bind_preservesInferOnly + (isDefEqCall_preservesInferOnly hmethods leftProjection + rightProjection) ?_ + intro answer + exact TcM.PreservesInferOnly.pure (BoundedStep.done answer) + +theorem tryStructuralCongruence_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hcore : ∀ source, + ((whnfCore source).run methods).PreservesInferOnly) + (hnoDelta : ∀ source, + ((whnfNoDelta source).run methods).PreservesInferOnly) + (left right : KExpr .anon) : + ((tryStructuralCongruence left right).run + methods).PreservesInferOnly := by + cases left with + | prj structureId field value info => + cases right with + | prj rightId rightField rightValue rightInfo => + simp only [tryStructuralCongruence] + split + · exact TcM.PreservesInferOnly.pure false + · simp only [pure_bind] + exact lazyDeltaProjReduction_preservesInferOnly hmethods hcore + hnoDelta structureId field value rightValue + | var | fvar | sort | const | app | lam | all | letE | nat | str => + exact TcM.PreservesInferOnly.pure false + | var | fvar | sort | const | app | lam | all | letE | nat | str => + cases right <;> intro before <;> rfl + +theorem tryDefEqApp_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (left right : KExpr .anon) : + ((tryDefEqApp left right).run methods).PreservesInferOnly := by + cases left with + | app leftFunction leftArgument leftInfo => + cases right with + | app rightFunction rightArgument rightInfo => + rcases hleft : + (leftFunction.app leftArgument leftInfo).collectSpine with + ⟨leftHead, leftArguments⟩ + rcases hright : + (rightFunction.app rightArgument rightInfo).collectSpine with + ⟨rightHead, rightArguments⟩ + simp only [tryDefEqApp, hleft, hright, Bool.not_true, + Bool.false_or, Bool.false_eq_true, if_false, pure_bind] + split + · exact TcM.PreservesInferOnly.pure false + · refine bind_preservesInferOnly + (isDefEqCall_preservesInferOnly hmethods leftHead rightHead) ?_ + intro headsEqual + cases headsEqual with + | false => exact TcM.PreservesInferOnly.pure false + | true => + simp only [Bool.not_true, Bool.false_eq_true, if_false] + exact allDefEqSpineArgs_preservesInferOnly hmethods + (leftArguments.zip rightArguments) + | var | fvar | sort | const | lam | all | letE | prj | nat | str => + simp only [tryDefEqApp] + exact TcM.PreservesInferOnly.pure false + | var | fvar | sort | const | lam | all | letE | prj | nat | str => + cases right <;> simp only [tryDefEqApp] <;> + exact TcM.PreservesInferOnly.pure false + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/DefEqPropositionPolicy.lean b/Ix/Tc/Verify/Check/DefEqPropositionPolicy.lean new file mode 100644 index 000000000..48e2e88d5 --- /dev/null +++ b/Ix/Tc/Verify/Check/DefEqPropositionPolicy.lean @@ -0,0 +1,168 @@ +import Ix.Tc.Verify.Check.DefEqNatPolicy + +/-! +# Operational policy for DefEq proposition and unit classifiers + +Proof irrelevance and the final unit-like fallback both perform infer-only +queries under caught-error semantics. This module proves that their cache +shells, lazy declaration lookups, WHNF calls, and recursive equality edges +restore the caller's exact inference policy. +-/ + +namespace Ix.Tc + +namespace RecM + +theorem classifyPropTypeUncached_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hwhnf : ∀ source, + ((whnf source).run methods).PreservesInferOnly) + (type : KExpr .anon) : + ((classifyPropTypeUncached type).run + methods).PreservesInferOnly := by + unfold classifyPropTypeUncached + refine bind_preservesInferOnly + (tryQuestion_preservesInferOnly + (inferOnlyCall_preservesInferOnly hmethods type)) ?_ + intro inferred + cases inferred with + | none => exact TcM.PreservesInferOnly.pure false + | some sort => + simp only + refine bind_preservesInferOnly + (tryQuestion_preservesInferOnly (hwhnf sort)) ?_ + intro normalized + cases normalized with + | some expression => + cases expression <;> exact TcM.PreservesInferOnly.pure _ + | none => exact TcM.PreservesInferOnly.pure false + +theorem isPropType_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hwhnf : ∀ source, + ((whnf source).run methods).PreservesInferOnly) + (type : KExpr .anon) : + ((isPropType type).run methods).PreservesInferOnly := by + unfold isPropType + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.ctxAddrForLbr type.lbr) ?_ + intro contextAddress + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind TcM.PreservesInferOnly.get + intro state + split + · exact TcM.PreservesInferOnly.pure _ + · simp only [pure_bind] + apply TcM.PreservesInferOnly.bind + (classifyPropTypeUncached_preservesInferOnly hmethods hwhnf type) + intro result + intro before + rfl + +theorem tryProofIrrel_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hwhnf : ∀ source, + ((whnf source).run methods).PreservesInferOnly) + (left right : KExpr .anon) : + ((tryProofIrrel left right).run methods).PreservesInferOnly := by + unfold tryProofIrrel + refine bind_preservesInferOnly + (tryQuestion_preservesInferOnly + (inferOnlyCall_preservesInferOnly hmethods left)) ?_ + intro leftTypeResult + cases leftTypeResult with + | none => exact TcM.PreservesInferOnly.pure false + | some leftType => + simp only + refine bind_preservesInferOnly + (isPropType_preservesInferOnly hmethods hwhnf leftType) ?_ + intro isProposition + cases isProposition with + | false => exact TcM.PreservesInferOnly.pure false + | true => + simp only [Bool.not_true, Bool.false_eq_true, if_false, pure_bind] + refine bind_preservesInferOnly + (tryQuestion_preservesInferOnly + (inferOnlyCall_preservesInferOnly hmethods right)) ?_ + intro rightTypeResult + cases rightTypeResult with + | none => exact TcM.PreservesInferOnly.pure false + | some rightType => + exact isDefEqCall_preservesInferOnly hmethods leftType rightType + +theorem isUnitLikeInductive_preservesInferOnly + {methods : Methods .anon} (inductiveId : KId .anon) : + ((isUnitLikeInductive inductiveId).run + methods).PreservesInferOnly := by + unfold isUnitLikeInductive + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.tryGetConst inductiveId) ?_ + intro declaration + cases declaration with + | none => exact TcM.PreservesInferOnly.pure false + | some declaration => + cases declaration with + | indc name levelParams levels params indices isUnsafe block memberIdx + type constructors leanAll => + simp only + split + · exact TcM.PreservesInferOnly.pure false + · refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.tryGetConst constructors[0]!) ?_ + intro constructorDeclaration + cases constructorDeclaration with + | none => exact TcM.PreservesInferOnly.pure false + | some constructorDeclaration => + cases constructorDeclaration <;> + exact TcM.PreservesInferOnly.pure _ + | defn | recr | axio | quot | ctor => + exact TcM.PreservesInferOnly.pure false + +theorem tryDefEqUnit_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hwhnf : ∀ source, + ((whnf source).run methods).PreservesInferOnly) + (left right : KExpr .anon) : + ((tryDefEqUnit left right).run methods).PreservesInferOnly := by + unfold tryDefEqUnit + refine bind_preservesInferOnly + (tryQuestion_preservesInferOnly + (inferOnlyCall_preservesInferOnly hmethods left)) ?_ + intro leftTypeResult + cases leftTypeResult with + | none => exact TcM.PreservesInferOnly.pure false + | some leftType => + simp only + refine bind_preservesInferOnly + (tryQuestion_preservesInferOnly (hwhnf leftType)) ?_ + intro normalizedTypeResult + cases normalizedTypeResult with + | none => exact TcM.PreservesInferOnly.pure false + | some normalizedType => + simp only + rcases hspine : normalizedType.collectSpine with ⟨head, arguments⟩ + cases head with + | const inductiveId universes info => + refine bind_preservesInferOnly + (isUnitLikeInductive_preservesInferOnly inductiveId) ?_ + intro isUnitLike + cases isUnitLike with + | false => exact TcM.PreservesInferOnly.pure false + | true => + simp only [Bool.not_true, Bool.false_eq_true, if_false, + pure_bind] + refine bind_preservesInferOnly + (tryQuestion_preservesInferOnly + (inferOnlyCall_preservesInferOnly hmethods right)) ?_ + intro rightTypeResult + cases rightTypeResult with + | none => exact TcM.PreservesInferOnly.pure false + | some rightType => + exact isDefEqCall_preservesInferOnly hmethods + normalizedType rightType + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + exact TcM.PreservesInferOnly.pure false + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/FullInference.lean b/Ix/Tc/Verify/Check/FullInference.lean new file mode 100644 index 000000000..66d134bb5 --- /dev/null +++ b/Ix/Tc/Verify/Check/FullInference.lean @@ -0,0 +1,96 @@ +import Ix.Tc.Verify.Check.PreTranslationCompatibility +import Ix.Tc.Verify.Infer.CacheSoundness + +/-! +# Full inference from untyped checker ingress + +The ordinary K2 contract starts from `TrKExprS`, which already contains the +typing facts checked by full inference. K3 instead starts from +`PreTrKExprS` and must return the missing typed translation together with the +usual inference result. + +This file records that stronger postcondition and discharges the production +full-cache-hit branch. A cache hit is not circular: cache provenance supplies +an earlier typed translation, and `PreTrKExprS.upgradeOfTyped` reconciles it +with the exact translation chosen by the current raw ingress. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +/-- Successful full inference both validates the source translation and +returns a Theory type for that exact translated source. -/ +def FullInferPost (trProj : RawProjRel) (world : VerifyWorld) + (support : RunSupport) (uvars : Nat) (Delta : KVLCtx) + (source : KExpr .anon) (sourceV : VExpr) + (result : KExpr .anon) : Prop := + support result ∧ + TrKExprS world.venv uvars world.nameOf trProj Delta source sourceV ∧ + InferPost trProj world uvars Delta sourceV result + +namespace FullInferPost + +/-- Strengthen the ordinary K2 inference post once the current source has +independently been upgraded to a typed structural translation. -/ +theorem of_typed + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {source result : KExpr .anon} + {sourceV : VExpr} + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta source + sourceV) + (hpost : support result ∧ + InferPost trProj world uvars Delta sourceV result) : + FullInferPost trProj world support uvars Delta source sourceV result := + ⟨hpost.1, hsource, hpost.2⟩ + +end FullInferPost + +namespace RecM + +/-- A validated full-cache hit upgrades the current untyped structural +translation and returns the same strong postcondition required of a fresh +full inference run. -/ +theorem inferWith_fullHit_pre_acceptance + {inferRec : KExpr .anon → RecM .anon (KExpr .anon)} + {methods : Methods .anon} {layer : WhnfLayer} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {model : KernelSuffixModel trProj world} + {Delta : KVLCtx} {source cached : KExpr .anon} + {sourceV : VExpr} {key : Address × Address} + {s s' : TcState .anon} + (theory : WhnfTheory trProj world model.keys.uvars) + (hkey : TcM.inferKey source s = .ok key s') + (hhit : s'.env.inferCache[key]? = some cached) + (hI : WhnfStateInv layer (kernelCacheSemantics model.keys trProj) + trProj world support model.keys.uvars Delta s) + (hsourceSupport : support source) + (hsource : PreTrKExprS world.venv model.keys.uvars world.nameOf trProj + Delta source sourceV) : + (inferWith inferRec source).run methods s = .ok cached s' ∧ + WhnfStateInv layer (kernelCacheSemantics model.keys trProj) + trProj world support model.keys.uvars Delta s' ∧ + FullInferPost trProj world support model.keys.uvars Delta + source sourceV cached := by + have hkeyPost := + (TcM.inferKey_model_matches_wf (layer := layer) + (support := support) model (Delta := Delta) (source := source) + (s := s)) hI + rw [hkey] at hkeyPost + have hprovenance := hkeyPost.1.1.caches.hit (.infer hhit) + have hmeaning := hprovenance.kernelInferMeaningOfMatches + .infer hsourceSupport hkeyPost.2.1 + obtain ⟨typedV, htyped, hcachedPost⟩ := hmeaning + have hDelta := hI.2.1.wf + have hsourceTyped : TrKExprS world.venv model.keys.uvars world.nameOf + trProj Delta source sourceV := + hsource.upgradeOfTyped world.venvWF theory.literalWF + theory.projections (KVLCtx.IsDefEq.refl world.venvWF hDelta) htyped + exact ⟨inferWith_fullHit hkey hhit, hkeyPost.1, + hprovenance.supported.2, hsourceTyped, + InferMeaning.post theory hDelta hsourceTyped + ⟨typedV, htyped, hcachedPost⟩⟩ + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/FullInferenceApplications.lean b/Ix/Tc/Verify/Check/FullInferenceApplications.lean new file mode 100644 index 000000000..ec85c364c --- /dev/null +++ b/Ix/Tc/Verify/Check/FullInferenceApplications.lean @@ -0,0 +1,460 @@ +import Ix.Tc.Verify.Check.FullInferenceLeaves +import Ix.Tc.Verify.Check.InferencePolicy + +/-! +# Full inference for applications + +K2 proves application inference from an already typed `TrKExprS` source. +That premise is circular at checker ingress: the application constructor of +`TrKExprS` already says that the function and argument have compatible +types. + +This file proves the corresponding K3 branch from `PreTrKExprS`. Its +callback context deliberately records the additional operational fact needed +by full checking: recursive inference, Pi exposure, and DefEq all restore +`inferOnly = false`, including on partial errors. The later concrete-knot +proof must construct this context; an arbitrary `Methods.WFAt` table cannot, +because its semantic contract does not constrain that policy bit. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +/-- Strong recursive services used while reconstructing a typed translation +from successful full inference. These are properties of one concrete +smaller method table, rather than consequences of the ordinary K2 method +contract. -/ +structure FullInferenceStepContext + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) + (methods : Methods .anon) : Prop where + infer : ∀ {Delta : KVLCtx} {s : TcState .anon} + {source : KExpr .anon} {sourceV : VExpr}, + s.inferOnly = false → + support source → + PreTrKExprS world.venv uvars world.nameOf trProj Delta source sourceV → + TcM.WF + (WhnfStateInv .noAccel semantics trProj world support uvars Delta) s + (methods.infer source) + (fun result after => + after.inferOnly = false ∧ + FullInferPost trProj world support uvars Delta + source sourceV result) + (fun _ after => after.inferOnly = false) + ensureForall : ∀ {Delta : KVLCtx} {s : TcState .anon} + {source : KExpr .anon} {sourceV : VExpr}, + s.inferOnly = false → + support source → + TrKExpr world.venv uvars world.nameOf trProj Delta source sourceV → + TcM.WF + (WhnfStateInv .noAccel semantics trProj world support uvars Delta) s + ((RecM.ensureForallDirect source).run methods) + (fun result after => + after.inferOnly = false ∧ + ForallView trProj world support uvars Delta sourceV + result.1 result.2) + (fun _ after => after.inferOnly = false) + ensureSort : ∀ {Delta : KVLCtx} {s : TcState .anon} + {source : KExpr .anon} {sourceV : VExpr}, + s.inferOnly = false → + support source → + TrKExpr world.venv uvars world.nameOf trProj Delta source sourceV → + TcM.WF + (WhnfStateInv .noAccel semantics trProj world support uvars Delta) s + ((RecM.ensureSortDirect source).run methods) + (fun result after => + after.inferOnly = false ∧ + SortView world support uvars Delta sourceV result) + (fun _ after => after.inferOnly = false) + isDefEq : ∀ {Delta : KVLCtx} {s : TcState .anon} + {left right : KExpr .anon} {leftV rightV : VExpr}, + s.inferOnly = false → + support left → support right → + TrKExprS world.venv uvars world.nameOf trProj Delta left leftV → + TrKExprS world.venv uvars world.nameOf trProj Delta right rightV → + TcM.WF + (WhnfStateInv .noAccel semantics trProj world support uvars Delta) s + (methods.isDefEq left right) + (fun answer after => + after.inferOnly = false ∧ + (answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV)) + (fun _ after => after.inferOnly = false) + +namespace FullInferenceStepContext + +/-- Assemble the strong K3 callback record from independent semantic proofs +and the outcome-sensitive operational policy frame. The separation matters: +ordinary K2 soundness does not mention `inferOnly`, while the policy audit +does not claim typing. -/ +theorem of_semantic_and_policy + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {methods : Methods .anon} + (hmethods : Methods.WFAt .noAccel semantics trProj world support uvars + methods) + (hpolicy : methods.PreservesInferOnly) + (hwhnfPolicy : ∀ source, + ((RecM.whnf source).run methods).PreservesInferOnly) + (hinfer : ∀ {Delta : KVLCtx} {s : TcState .anon} + {source : KExpr .anon} {sourceV : VExpr}, + s.inferOnly = false → + support source → + PreTrKExprS world.venv uvars world.nameOf trProj Delta source sourceV → + TcM.WF + (WhnfStateInv .noAccel semantics trProj world support uvars Delta) s + (methods.infer source) + (fun result _ => + FullInferPost trProj world support uvars Delta + source sourceV result)) + (hforall : ∀ {Delta : KVLCtx} {s : TcState .anon} + {source : KExpr .anon} {sourceV : VExpr}, + support source → + TrKExpr world.venv uvars world.nameOf trProj Delta source sourceV → + TcM.WF + (WhnfStateInv .noAccel semantics trProj world support uvars Delta) s + ((RecM.ensureForallDirect source).run methods) + (fun result _ => + ForallView trProj world support uvars Delta sourceV + result.1 result.2)) + (hsort : ∀ {Delta : KVLCtx} {s : TcState .anon} + {source : KExpr .anon} {sourceV : VExpr}, + support source → + TrKExpr world.venv uvars world.nameOf trProj Delta source sourceV → + TcM.WF + (WhnfStateInv .noAccel semantics trProj world support uvars Delta) s + ((RecM.ensureSortDirect source).run methods) + (fun result _ => SortView world support uvars Delta sourceV result)) : + FullInferenceStepContext semantics trProj world support uvars methods := by + refine { infer := ?_, ensureForall := ?_, ensureSort := ?_, isDefEq := ?_ } + · intro Delta s source sourceV hbefore hsourceSupport hsource + apply TcM.WF.mono + (TcM.PreservesInferOnly.strengthenWFValue + (hinfer hbefore hsourceSupport hsource) (hpolicy.infer source) hbefore) + · intro _ _ post + exact post + · intro _ _ post + exact post.1 + · intro Delta s source sourceV hbefore hsourceSupport hsource + apply TcM.WF.mono + (TcM.PreservesInferOnly.strengthenWFValue + (hforall hsourceSupport hsource) + (RecM.ensureForallDirect_preservesInferOnly hwhnfPolicy) hbefore) + · intro _ _ post + exact post + · intro _ _ post + exact post.1 + · intro Delta s source sourceV hbefore hsourceSupport hsource + apply TcM.WF.mono + (TcM.PreservesInferOnly.strengthenWFValue + (hsort hsourceSupport hsource) + (RecM.ensureSortDirect_preservesInferOnly hwhnfPolicy) hbefore) + · intro _ _ post + exact post + · intro _ _ post + exact post.1 + · intro Delta s left right leftV rightV hbefore hleftSupport + hrightSupport hleft hright + exact hpolicy.isDefEq_full_wf hmethods hbefore hleftSupport + hrightSupport hleft hright + +end FullInferenceStepContext + +namespace TcM + +/-- The eager-reduction classifier is state-pure and therefore cannot change +the full-inference policy bit on either outcome. -/ +private theorem isEagerReduce_full_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {s : TcState .anon} + (source : KExpr .anon) (hpolicy : s.inferOnly = false) : + TcM.WF + (WhnfStateInv .noAccel semantics trProj world support uvars Delta) s + (TcM.isEagerReduce source) + (fun _ after => after = s ∧ after.inferOnly = false) + (fun _ after => after.inferOnly = false) := by + intro hI + rcases hspine : source.collectSpine with ⟨head, args⟩ + cases hsize : args.size != 2 <;> + cases head <;> + simp [TcM.isEagerReduce, hspine, hsize, hI, hpolicy] + change WhnfStateInv .noAccel semantics trProj world support uvars Delta s ∧ + s = s ∧ s.inferOnly = false + exact ⟨hI, rfl, hpolicy⟩ + +end TcM + +namespace RecM + +/-- Toggling the eager-reduction marker leaves the full-inference policy bit +unchanged. -/ +private theorem setEagerReduce_full_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {s : TcState .anon} + (value : Bool) (hpolicy : s.inferOnly = false) : + TcM.WF + (WhnfStateInv .noAccel semantics trProj world support uvars Delta) s + (modify fun state => { state with eagerReduce := value }) + (fun _ after => after.inferOnly = false) + (fun _ after => after.inferOnly = false) := by + exact TcM.WF.modifyGet + (fun hI => hI.of_semantic_fields_eq rfl rfl rfl rfl rfl rfl rfl rfl) + (fun _ => hpolicy) + +/-- The production mismatch path reads the context depth, throws, and never +reaches its following substitution. Stating this before running the reader +avoids losing the error-state policy fact while simplifying nested +`ReaderT` binds. -/ +private theorem throwApplicationMismatch_full_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {methods : Methods .anon} {s : TcState .anon} + {aTy dom : KExpr .anon} {rest : RecM .anon α} + {Q : α → TcState .anon → Prop} + (hmethods : Methods.WFAt .noAccel semantics trProj world support uvars + methods) + (hpolicy : s.inferOnly = false) : + TcM.WF + (WhnfStateInv .noAccel semantics trProj world support uvars Delta) s + ((do + let read ← (get : RecM .anon (TcState .anon)) + throw (TcError.appTypeMismatch aTy dom read.ctx.size) + rest).run methods) + Q (fun _ after => after.inferOnly = false) := by + have hrec : RecM.WF .noAccel semantics trProj world support uvars Delta s + (do + let read ← (get : RecM .anon (TcState .anon)) + throw (TcError.appTypeMismatch aTy dom read.ctx.size) + rest) + Q (fun _ after => after.inferOnly = false) := by + apply RecM.WF.bind + (Q₁ := fun read state => + read = state ∧ state.inferOnly = false) + (RecM.WF.get fun _ => ⟨rfl, hpolicy⟩) + intro _ state hread + apply RecM.WF.bind + (Q₁ := fun _ _ => False) + (RecM.WF.throw fun _ => hread.2) + intro _ _ impossible + exact impossible.elim + exact hrec methods hmethods + +/-- Semantic reconstruction for a fully checked application. In contrast +to K2's application lemma, argument compatibility is obtained from the +actual recursive inference and true DefEq result, not from the source +translation premise. -/ +private theorem fullApplicationResult + {trProj : RawProjRel} {world : VerifyWorld} + {uvars : Nat} {Delta : KVLCtx} + (theory : WhnfTheory trProj world uvars) + (hDelta : KVLCtx.WF world.venv uvars Delta) + {f a cod : KExpr .anon} {info : ExprInfo .anon} + {fV aV fTyV aTyV aTyCoreV domV codV : VExpr} + (hfunTr : TrKExprS world.venv uvars world.nameOf trProj Delta f fV) + (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)) + (haTy : world.venv.HasType uvars Delta.toCtx aV aTyV) + (haTyEq : world.venv.IsDefEqU uvars Delta.toCtx aTyCoreV aTyV) + (haccepted : world.venv.IsDefEqU uvars Delta.toCtx aTyCoreV domV) + (hcodTr : TrKExprS world.venv uvars world.nameOf trProj + ((none, .vlam domV) :: Delta) cod codV) + (hbounds : WalkerRequest.Bounds (.subst cod a 0)) : + TrKExprS world.venv uvars world.nameOf trProj Delta + (.app f a info) (.app fV aV) ∧ + InferPost trProj world uvars Delta (.app fV aV) + (KExpr.substSpec cod a 0) := by + have hfunAtForall : world.venv.HasType uvars Delta.toCtx fV + (.forallE domV codV) := + hfTy.defeqU_r world.venvWF hDelta hview + have hargAtDom : world.venv.HasType uvars Delta.toCtx aV domV := + haTy.defeqU_r world.venvWF hDelta <| + haTyEq.symm.trans world.venvWF hDelta haccepted + have hsource : TrKExprS world.venv uvars world.nameOf trProj Delta + (.app f a info) (.app fV aV) := + .app hfunAtForall hargAtDom hfunTr hargTr + 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 + exact ⟨hsource, codV.inst aV, + hresultTr.trKExpr world.venvWF.ordered theory.literalWF + theory.projections.wf hDelta, + Lean4Lean.VEnv.HasType.app hfunAtForall hargAtDom⟩ + +/-- Execute the final dependent-codomain substitution after a successful +full application check. `runIntern` cannot throw and its exact frame proves +that `inferOnly` remains false. -/ +private theorem finishFullApplication_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) + {f a cod : KExpr .anon} + {info : ExprInfo .anon} + {fV aV fTyV aTyV aTyCoreV domV codV : VExpr} + (hpolicy : s.inferOnly = false) + (hfunTr : TrKExprS world.venv uvars world.nameOf trProj Delta f fV) + (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)) + (haTy : world.venv.HasType uvars Delta.toCtx aV aTyV) + (haTyEq : world.venv.IsDefEqU uvars Delta.toCtx aTyCoreV aTyV) + (haccepted : world.venv.IsDefEqU uvars Delta.toCtx aTyCoreV domV) + (hcodTr : TrKExprS world.venv uvars world.nameOf trProj + ((none, .vlam domV) :: Delta) cod codV) + (hmem : WalkerRequest.subst cod a 0 ∈ requests) : + TcM.WF + (WhnfStateInv .noAccel semantics trProj world support uvars Delta) s + (TcM.runIntern (subst cod a 0)) + (fun result after => + after.inferOnly = false ∧ + FullInferPost trProj world support uvars Delta + (.app f a info) (.app fV aV) result) + (fun _ after => after.inferOnly = false) := by + intro hI + obtain ⟨after, hrunSubst, hIafter, hframe⟩ := + hrun.subst_whnf_eval hmem hI + rw [hrunSubst] + have hpolicyAfter : after.inferOnly = false := by + have hsame : after.inferOnly = s.inferOnly := by + simpa [InternUpdateFrame] using congrArg TcState.inferOnly hframe + exact hsame.trans hpolicy + have hsemantic := fullApplicationResult (info := info) theory + hIafter.2.1.wf + hfunTr hargTr hfTy hview haTy haTyEq haccepted hcodTr + (hrun.requestBounds hmem) + have hresultSupport : support (KExpr.substSpec cod a 0) := + hrun.coverage.subst hmem _ (KExpr.SubstReach.spec a cod 0) + simp only + exact ⟨hIafter, hpolicyAfter, hresultSupport, hsemantic.1, hsemantic.2⟩ + +/-- The full-mode application branch, starting from an untyped structural +translation. This theorem is deliberately indexed by one concrete smaller +method table and its stronger K3 callback context. -/ +theorem inferUncached_app_full_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} + {methods : Methods .anon} {s : TcState .anon} + {f a : KExpr .anon} {info : ExprInfo .anon} + {sourceV : VExpr} + (theory : WhnfTheory trProj world uvars) + (callbacks : FullInferenceStepContext semantics trProj world support + uvars methods) + (hmethods : Methods.WFAt .noAccel semantics trProj world support uvars + methods) + (hcensus : ApplicationInferCensus support requests) + (hsourceSupport : support (.app f a info)) + (hsource : PreTrKExprS world.venv uvars world.nameOf trProj Delta + (.app f a info) sourceV) + (hpolicy : s.inferOnly = false) : + TcM.WF + (WhnfStateInv .noAccel semantics trProj world support uvars Delta) s + ((inferUncached inferCall false (.app f a info)).run methods) + (fun result after => + after.inferOnly = false ∧ + FullInferPost trProj world support uvars Delta + (.app f a info) sourceV result) + (fun _ after => after.inferOnly = false) := by + cases hsource with + | app hfunPre hargPre => + rename_i fV aV + obtain ⟨hfunSupport, hargSupport, hsubst⟩ := + hcensus hsourceSupport + unfold inferUncached + simp only [Bool.not_false, if_true, ReaderT.run_bind, + ReaderT.run_monadLift, pure_bind] + apply TcM.WF.bind + (callbacks.infer hpolicy hfunSupport hfunPre) + intro fTy afterFun hfunPost + rcases hfunPost with + ⟨hpolicyFun, hfTySupport, hfunTr, fTyV, hfTyTr, hfTy⟩ + apply TcM.WF.bind + (callbacks.ensureForall hpolicyFun hfTySupport hfTyTr) + intro exposed afterForall hforallPost + rcases exposed with ⟨dom, cod⟩ + rcases hforallPost with + ⟨hpolicyForall, domV, codV, hdomSupport, hcodSupport, _, _, + hdomTr, hcodTr, hview⟩ + apply TcM.WF.bind + (callbacks.infer hpolicyForall hargSupport hargPre) + intro aTy afterArg hargPost + rcases hargPost with + ⟨hpolicyArg, haTySupport, hargTr, aTyV, haTyTr, haTy⟩ + obtain ⟨aTyCoreV, haTyCoreTr, haTyEq⟩ := haTyTr + apply TcM.WF.bind + (TcM.isEagerReduce_full_wf a hpolicyArg) + intro eager afterEager heager + rcases heager with ⟨rfl, hpolicyEager⟩ + cases eager with + | false => + simp only [Bool.false_eq_true, if_false] + apply TcM.WF.bind + (callbacks.isDefEq hpolicyEager haTySupport hdomSupport + haTyCoreTr hdomTr) + intro equal afterEq hequal + rcases hequal with ⟨hpolicyEq, heq⟩ + cases equal with + | false => + simp only [Bool.not_false, if_true] + exact throwApplicationMismatch_full_wf + (α := KExpr .anon) (aTy := aTy) (dom := dom) + (rest := liftM (TcM.runIntern (subst cod a 0))) + (Q := fun result after => + after.inferOnly = false ∧ + FullInferPost trProj world support uvars Delta + (.app f a info) (.app fV aV) result) + hmethods hpolicyEq + | true => + simp only [Bool.not_true, Bool.false_eq_true, if_false] + exact finishFullApplication_wf hrun theory hpolicyEq hfunTr + hargTr hfTy hview haTy haTyEq (heq rfl) hcodTr + (hsubst hcodSupport) + | true => + simp only [if_true, ReaderT.run_bind] + apply TcM.WF.bind + (setEagerReduce_full_wf true hpolicyEager) + intro _ afterSet hpolicySet + apply TcM.WF.bind + (callbacks.isDefEq hpolicySet haTySupport hdomSupport + haTyCoreTr hdomTr) + intro equal afterEq hequal + rcases hequal with ⟨hpolicyEq, heq⟩ + apply TcM.WF.bind + (setEagerReduce_full_wf false hpolicyEq) + intro _ afterReset hpolicyReset + cases equal with + | false => + simp only [Bool.not_false, if_true, ReaderT.run_bind, + ReaderT.run_monadLift] + exact throwApplicationMismatch_full_wf + (α := KExpr .anon) (aTy := aTy) (dom := dom) + (rest := liftM (TcM.runIntern (subst cod a 0))) + (Q := fun result after => + after.inferOnly = false ∧ + FullInferPost trProj world support uvars Delta + (.app f a info) (.app fV aV) result) + hmethods hpolicyReset + | true => + simp only [Bool.not_true, Bool.false_eq_true, if_false] + exact finishFullApplication_wf hrun theory hpolicyReset + hfunTr hargTr hfTy hview haTy haTyEq (heq rfl) hcodTr + (hsubst hcodSupport) + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/FullInferenceBinders.lean b/Ix/Tc/Verify/Check/FullInferenceBinders.lean new file mode 100644 index 000000000..fcb7b9a07 --- /dev/null +++ b/Ix/Tc/Verify/Check/FullInferenceBinders.lean @@ -0,0 +1,657 @@ +import Ix.Tc.Verify.Check.BinderRoundTrip +import Ix.Tc.Verify.Check.FullInferenceApplications +import Ix.Tc.Verify.Infer.ForallTypes +import Ix.Tc.Verify.Infer.LambdaTypes +import Ix.Tc.Verify.Infer.LetTypes + +/-! +# Full inference for binding forms + +K2's lambda and forall proofs assume the complete source translation is +already typed. These K3 branches instead start from `PreTrKExprS`, validate +the domain, infer the freshly opened body, and close its newly established +typed translation back to the original de Bruijn syntax. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +namespace RecM + +/-- Full-inference lambda tail after the source binder has been opened. -/ +private theorem inferLambdaFullTail_wf + {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} + {bi : Mode.anon.F Lean.BinderInfo} + {ty body bodyOpen : KExpr .anon} {info : ExprInfo .anon} + {tyV bodyV : VExpr} + (theory : WhnfTheory trProj world uvars) + (callbacks : FullInferenceStepContext semantics trProj world support + uvars methods) + (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) + (hbodyPre : PreTrKExprS world.venv uvars world.nameOf trProj + ((none, .vlam tyV) :: Delta) body bodyV) + (hbinder : BinderOpeningResources support name body) + (hbodyEq : bodyOpen = KExpr.instantiateRevSpec body + #[.mkFVar fv name] 0) + (hfresh : fv ∉ Delta.fvars) + (hbodySupport : support bodyOpen) + (hbodyOpenPre : PreTrKExprS world.venv uvars world.nameOf trProj + ((some (fv, Delta.fvars), .vlam tyV) :: Delta) bodyOpen bodyV) + (hpolicy : s.inferOnly = false) : + TcM.WF + (WhnfStateInv .noAccel semantics trProj world support uvars + ((some (fv, Delta.fvars), .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)).run methods) + (fun result after => + after.inferOnly = false ∧ + FullInferPost trProj world support uvars Delta + (.lam name bi ty body info) (.lam tyV bodyV) result) + (fun _ after => after.inferOnly = false) := by + simp only [ReaderT.run_bind, inferCall, ReaderT.run_monadLift] + apply TcM.WF.bind + (TcM.WF.withInv <| callbacks.infer hpolicy hbodySupport hbodyOpenPre) + intro bodyTy afterBody hbodyPost + rcases hbodyPost with + ⟨hIBody, hpolicyBody, hbodyTySupport, hbodyOpenTr, + bodyTyV, hbodyTyTr, hbodyTy⟩ + have hbodyAbsent : body.FVarAbsent fv := + hbodyPre.fvarAbsent (by simpa using hfresh) + have hbodyTr : TrKExprS world.venv uvars world.nameOf trProj + ((none, .vlam tyV) :: Delta) body bodyV := + hbodyOpenTr.closeOpenedFVarZero hbodyEq hbodyAbsent + (hbinder.instRevBounds fv) (habstract.bounds hbodySupport fv) + obtain ⟨bodyTyCoreV, hbodyTyCoreTr, hbodyTyEq⟩ := hbodyTyTr + have hcheapMeaning := KExpr.cheapBetaReduceResult_meaning theory + hIBody.2.1.wf hbodyTyCoreTr (hcheap.bounds hbodyTySupport) + apply TcM.WF.bind + (TcM.WF.mono + (TcM.WF.withInv <| TcM.PreservesInferOnly.strengthenWFValue + (hcheap.whnf_wf hcollision hbodyTySupport) + (TcM.PreservesInferOnly.runIntern _) hpolicyBody) + (fun _ _ post => post) (fun _ _ post => post.1)) + intro reduced afterCheap hcheapPost + rcases hcheapPost with + ⟨hICheap, hpolicyCheap, rfl, hreducedSupport, _⟩ + have hreducedQ := WhnfMeaning.resultQuot theory hICheap.2.1.wf + (⟨bodyTyCoreV, hbodyTyCoreTr, hbodyTyEq⟩ : + TrKExpr world.venv uvars world.nameOf trProj + ((some (fv, Delta.fvars), .vlam tyV) :: Delta) bodyTy bodyTyV) + hcheapMeaning + obtain ⟨reducedV, hreducedTr, hreducedEq⟩ := hreducedQ + apply TcM.WF.bind + (TcM.WF.mono + (TcM.WF.withInv <| TcM.PreservesInferOnly.strengthenWFValue + (habstract.close_whnf_wf hcollision hreducedSupport hreducedTr) + (TcM.PreservesInferOnly.runIntern _) hpolicyCheap) + (fun _ _ post => post) (fun _ _ post => post.1)) + intro abstracted afterAbstract habstractPost + rcases habstractPost with + ⟨hIAbstract, hpolicyAbstract, rfl, habstractedSupport, _, + habstractedTr⟩ + have hresultSupport := hresults habstractedSupport + apply TcM.WF.mono + (TcM.WF.mono + (TcM.WF.withInv <| TcM.PreservesInferOnly.strengthenWFValue + (TcM.intern_whnf_wf hcollision hresultSupport) + (TcM.PreservesInferOnly.runIntern _) hpolicyAbstract) + (fun _ _ post => post) (fun _ _ post => post.1)) + · intro result final hresult + rcases hresult with ⟨hIFinal, hpolicyFinal, 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 + have hsourceTr : TrKExprS world.venv uvars world.nameOf trProj Delta + (.lam name bi ty body info) (.lam tyV bodyV) := + .lam ⟨u, htySort⟩ htyTr hbodyTr + exact ⟨hpolicyFinal, hresultSupport, hsourceTr, + .forallE tyV bodyTyV, hresultTr, + Lean4Lean.VEnv.HasType.lam htySort hbodyTy'⟩ + · intro _ _ herror + exact herror + +/-- Full-mode lambda inference reconstructs the typed binder translation +from its pre-translation and recursively checked domain/body. -/ +theorem inferUncached_lam_full_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} + {methods : Methods .anon} {s : TcState .anon} + {name : Mode.anon.F Name} {bi : Mode.anon.F Lean.BinderInfo} + {ty body : KExpr .anon} {info : ExprInfo .anon} {sourceV : VExpr} + (theory : WhnfTheory trProj world uvars) + (callbacks : FullInferenceStepContext semantics trProj world support + uvars methods) + (hcheap : CheapBetaResources support) + (habstract : SingletonAbstractionResources support) + (hresults : LambdaResultSupport support ty) + (htySupport : support ty) + (hbinder : BinderOpeningResources support name body) + (hsource : PreTrKExprS world.venv uvars world.nameOf trProj Delta + (.lam name bi ty body info) sourceV) + (hpolicy : s.inferOnly = false) : + TcM.WF + (WhnfStateInv .noAccel semantics trProj world support uvars Delta) s + ((inferUncached inferCall false (.lam name bi ty body info)).run + methods) + (fun result after => + after.inferOnly = false ∧ + FullInferPost trProj world support uvars Delta + (.lam name bi ty body info) sourceV result) + (fun _ after => after.inferOnly = false) := by + cases hsource with + | lam htyPre hbodyPre => + rename_i tyV bodyV + unfold inferUncached + simp only [Bool.not_false, if_true, ReaderT.run_bind, + ReaderT.run_monadLift, inferCall, pure_bind] + apply TcM.WF.bind + (TcM.WF.withInv <| callbacks.infer hpolicy htySupport htyPre) + intro tyTy afterTy htyPost + rcases htyPost with + ⟨hITy, hpolicyTy, htyTySupport, htyTr, + tyTyV, htyTyTr, htyTy⟩ + apply TcM.WF.bind + (TcM.WF.withInv <| + callbacks.ensureSort hpolicyTy htyTySupport htyTyTr) + intro u afterSort hsortPost + rcases hsortPost with ⟨hISort, hpolicySort, hu⟩ + have htySort : world.venv.HasType uvars Delta.toCtx tyV + (.sort u.toVLevel) := + htyTy.defeqU_r world.venvWF hISort.2.1.wf.toCtx hu.inputEq + have htyType : world.venv.IsType uvars Delta.toCtx tyV := + ⟨u.toVLevel, htySort⟩ + apply withLctxScope_openBinder_pre_wf + (layer := .noAccel) (semantics := semantics) (trProj := trProj) + (world := world) (support := support) (uvars := uvars) + (Delta := Delta) (methods := methods) (s := afterSort) + (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 after => + after.inferOnly = false ∧ + FullInferPost trProj world support uvars Delta + (.lam name bi ty body info) (.lam tyV bodyV) result) + (Qouter := fun result after => + after.inferOnly = false ∧ + FullInferPost trProj world support uvars Delta + (.lam name bi ty body info) (.lam tyV bodyV) result) + (Einner := fun _ after => after.inferOnly = false) + (Eouter := fun _ after => after.inferOnly = false) + htyTr htyType hbodyPre hrun.collisionFree hbinder hpolicySort + · intro bodyOpen fv after hfv hbodyEq hbodySupport hfresh + hbodyOpenPre hpolicyOpen + subst fv + exact inferLambdaFullTail_wf + (semantics := semantics) (trProj := trProj) (world := world) + (support := support) (uvars := uvars) (Delta := Delta) + (methods := methods) (s := after) (name := name) + (bi := bi) (ty := ty) (body := body) (info := info) + (tyV := tyV) (bodyV := bodyV) theory callbacks hcheap + habstract hresults hrun.collisionFree htyType htyTr hbodyPre + hbinder hbodyEq hfresh hbodySupport hbodyOpenPre hpolicyOpen + · intro result after hresult + simpa using hresult + · intro err after herror + simpa using herror + · intro err + exact hpolicySort + +/-- Full-inference forall tail after opening its body. -/ +private theorem inferForallFullTail_wf + {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} + {bi : Mode.anon.F Lean.BinderInfo} + {ty body bodyOpen : KExpr .anon} {info : ExprInfo .anon} + {tyV bodyV input1 : VExpr} {u1 : KUniv .anon} + (theory : WhnfTheory trProj world uvars) + (callbacks : FullInferenceStepContext semantics trProj world support + uvars methods) + (habstract : SingletonAbstractionResources support) + (hresults : ForallResultSupport support) + (hcollision : support.CollisionFree) + (htyType : world.venv.IsType uvars Delta.toCtx tyV) + (htySort : world.venv.HasType uvars Delta.toCtx tyV + (.sort u1.toVLevel)) + (htyTr : TrKExprS world.venv uvars world.nameOf trProj Delta ty tyV) + (hu1 : SortView world support uvars Delta input1 u1) + (hbodyPre : PreTrKExprS world.venv uvars world.nameOf trProj + ((none, .vlam tyV) :: Delta) body bodyV) + (hbinder : BinderOpeningResources support name body) + (hbodyEq : bodyOpen = KExpr.instantiateRevSpec body + #[.mkFVar fv name] 0) + (hfresh : fv ∉ Delta.fvars) + (hbodySupport : support bodyOpen) + (hbodyOpenPre : PreTrKExprS world.venv uvars world.nameOf trProj + ((some (fv, Delta.fvars), .vlam tyV) :: Delta) bodyOpen bodyV) + (hpolicy : s.inferOnly = false) : + TcM.WF + (WhnfStateInv .noAccel semantics trProj world support uvars + ((some (fv, Delta.fvars), .vlam tyV) :: Delta)) s + ((do + let bodyTy ← inferCall bodyOpen + let u2 ← ensureSortDirect bodyTy + TcM.intern (.mkSort (.mkIMax u1 u2))).run methods) + (fun result after => + after.inferOnly = false ∧ + FullInferPost trProj world support uvars Delta + (.all name bi ty body info) (.forallE tyV bodyV) result) + (fun _ after => after.inferOnly = false) := by + simp only [ReaderT.run_bind, inferCall, ReaderT.run_monadLift] + apply TcM.WF.bind + (TcM.WF.withInv <| callbacks.infer hpolicy hbodySupport hbodyOpenPre) + intro bodyTy afterBody hbodyPost + rcases hbodyPost with + ⟨hIBody, hpolicyBody, hbodyTySupport, hbodyOpenTr, + bodyTyV, hbodyTyTr, hbodyTy⟩ + have hbodyAbsent : body.FVarAbsent fv := + hbodyPre.fvarAbsent (by simpa using hfresh) + have hbodyTr : TrKExprS world.venv uvars world.nameOf trProj + ((none, .vlam tyV) :: Delta) body bodyV := + hbodyOpenTr.closeOpenedFVarZero hbodyEq hbodyAbsent + (hbinder.instRevBounds fv) (habstract.bounds hbodySupport fv) + apply TcM.WF.bind + (TcM.WF.withInv <| + callbacks.ensureSort hpolicyBody hbodyTySupport hbodyTyTr) + intro u2 afterSort hu2Post + rcases hu2Post with ⟨hISort, hpolicySort, hu2⟩ + have hresultSupport := hresults hu1.rootSupport hu2.rootSupport + apply TcM.WF.mono + (TcM.WF.mono + (TcM.WF.withInv <| TcM.PreservesInferOnly.strengthenWFValue + (TcM.intern_whnf_wf hcollision hresultSupport) + (TcM.PreservesInferOnly.runIntern _) hpolicySort) + (fun _ _ post => post) (fun _ _ post => post.1)) + · intro result final hresult + rcases hresult with ⟨hIFinal, hpolicyFinal, rfl, _⟩ + have hDelta : KVLCtx.WF world.venv uvars Delta := 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 hbodyType : world.venv.IsType uvars + (tyV :: Delta.toCtx) bodyV := ⟨u2.toVLevel, hbodySort⟩ + have hsourceTr : TrKExprS world.venv uvars world.nameOf trProj Delta + (.all name bi ty body info) (.forallE tyV bodyV) := + .all htyType hbodyType htyTr hbodyTr + have hresultTr : TrKExpr world.venv uvars world.nameOf trProj Delta + (KExpr.mkSort (KUniv.mkIMax u1 u2)) + (.sort (KUniv.mkIMax u1 u2).toVLevel) := + (TrKExprS.sort + (KUniv.toVLevel_mkIMax_wf hu1.levelWF hu2.levelWF)).trKExpr + world.venvWF.ordered theory.literalWF theory.projections.wf hDelta + 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 ⟨hpolicyFinal, hresultSupport, hsourceTr, + .sort (KUniv.mkIMax u1 u2).toVLevel, hresultTr, + hforall.defeqU_r world.venvWF hDelta hsortEq⟩ + · intro _ _ herror + exact herror + +/-- Full-mode forall inference validates both domain and body as types and +returns the exact production `imax` sort. -/ +theorem inferUncached_all_full_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} + {methods : Methods .anon} {s : TcState .anon} + {name : Mode.anon.F Name} {bi : Mode.anon.F Lean.BinderInfo} + {ty body : KExpr .anon} {info : ExprInfo .anon} {sourceV : VExpr} + (theory : WhnfTheory trProj world uvars) + (callbacks : FullInferenceStepContext semantics trProj world support + uvars methods) + (habstract : SingletonAbstractionResources support) + (hresults : ForallResultSupport support) + (htySupport : support ty) + (hbinder : BinderOpeningResources support name body) + (hsource : PreTrKExprS world.venv uvars world.nameOf trProj Delta + (.all name bi ty body info) sourceV) + (hpolicy : s.inferOnly = false) : + TcM.WF + (WhnfStateInv .noAccel semantics trProj world support uvars Delta) s + ((inferUncached inferCall false (.all name bi ty body info)).run + methods) + (fun result after => + after.inferOnly = false ∧ + FullInferPost trProj world support uvars Delta + (.all name bi ty body info) sourceV result) + (fun _ after => after.inferOnly = false) := by + cases hsource with + | all htyPre hbodyPre => + rename_i tyV bodyV + unfold inferUncached + simp only [ReaderT.run_bind, ReaderT.run_monadLift, inferCall] + apply TcM.WF.bind + (TcM.WF.withInv <| callbacks.infer hpolicy htySupport htyPre) + intro tyTy afterTy htyPost + rcases htyPost with + ⟨hITy, hpolicyTy, htyTySupport, htyTr, + tyTyV, htyTyTr, htyTy⟩ + apply TcM.WF.bind + (TcM.WF.withInv <| + callbacks.ensureSort hpolicyTy htyTySupport htyTyTr) + intro u1 afterSort hu1Post + rcases hu1Post with ⟨hISort, hpolicySort, 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 + have htyType : world.venv.IsType uvars Delta.toCtx tyV := + ⟨u1.toVLevel, htySort⟩ + apply withLctxScope_openBinder_pre_wf + (layer := .noAccel) (semantics := semantics) (trProj := trProj) + (world := world) (support := support) (uvars := uvars) + (Delta := Delta) (methods := methods) (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 after => + after.inferOnly = false ∧ + FullInferPost trProj world support uvars Delta + (.all name bi ty body info) (.forallE tyV bodyV) result) + (Qouter := fun result after => + after.inferOnly = false ∧ + FullInferPost trProj world support uvars Delta + (.all name bi ty body info) (.forallE tyV bodyV) result) + (Einner := fun _ after => after.inferOnly = false) + (Eouter := fun _ after => after.inferOnly = false) + htyTr htyType hbodyPre hrun.collisionFree hbinder hpolicySort + · intro bodyOpen fv after hfv hbodyEq hbodySupport hfresh + hbodyOpenPre hpolicyOpen + subst fv + exact inferForallFullTail_wf + (semantics := semantics) (trProj := trProj) (world := world) + (support := support) (uvars := uvars) (Delta := Delta) + (methods := methods) (s := after) (name := name) (bi := bi) + (ty := ty) (body := body) (info := info) + (tyV := tyV) (bodyV := bodyV) theory callbacks habstract + hresults hrun.collisionFree htyType htySort htyTr hu1 hbodyPre + hbinder hbodyEq hfresh hbodySupport hbodyOpenPre hpolicyOpen + · intro result after hresult + simpa using hresult + · intro err after herror + simpa using herror + · intro err + exact hpolicySort + +/-- Full-inference let tail after opening its body with a tagged let fvar. -/ +private theorem inferLetFullTail_wf + {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} + {type value body bodyOpen : KExpr .anon} + {nondep : Bool} {info : ExprInfo .anon} + {typeV valueV bodyV : VExpr} + (theory : WhnfTheory trProj world uvars) + (callbacks : FullInferenceStepContext semantics trProj world support + uvars methods) + (habstract : SingletonAbstractionResources support) + (hsubst : SubstitutionResources support) + (hcheap : CheapBetaResources support) + (hcollision : support.CollisionFree) + (htypeTr : TrKExprS world.venv uvars world.nameOf trProj Delta + type typeV) + (hvalueSupport : support value) + (hvalueTr : TrKExprS world.venv uvars world.nameOf trProj Delta + value valueV) + (hvalueType : world.venv.HasType uvars Delta.toCtx valueV typeV) + (hbodyPre : PreTrKExprS world.venv uvars world.nameOf trProj + ((none, .vlet typeV valueV) :: Delta) body bodyV) + (hbinder : BinderOpeningResources support name body) + (hbodyEq : bodyOpen = KExpr.instantiateRevSpec body + #[.mkFVar fv name] 0) + (hfresh : fv ∉ Delta.fvars) + (hbodySupport : support bodyOpen) + (hbodyOpenPre : PreTrKExprS world.venv uvars world.nameOf trProj + ((some (fv, Delta.fvars), .vlet typeV valueV) :: Delta) + bodyOpen bodyV) + (hpolicy : s.inferOnly = false) : + TcM.WF + (WhnfStateInv .noAccel semantics trProj world support uvars + ((some (fv, Delta.fvars), .vlet typeV valueV) :: Delta)) s + ((do + let bodyTy ← inferCall bodyOpen + let abstracted ← TcM.runIntern (abstractFVars bodyTy #[fv]) + let result ← TcM.runIntern (subst abstracted value 0) + TcM.runIntern (cheapBetaReduce result)).run methods) + (fun result after => + after.inferOnly = false ∧ + FullInferPost trProj world support uvars Delta + (.letE name type value body nondep info) bodyV result) + (fun _ after => after.inferOnly = false) := by + simp only [ReaderT.run_bind, inferCall, ReaderT.run_monadLift] + apply TcM.WF.bind + (TcM.WF.withInv <| callbacks.infer hpolicy hbodySupport hbodyOpenPre) + intro bodyTy afterBody hbodyPost + rcases hbodyPost with + ⟨hIBody, hpolicyBody, hbodyTySupport, hbodyOpenTr, + bodyTyV, hbodyTyTr, hbodyTy⟩ + have hbodyAbsent : body.FVarAbsent fv := + hbodyPre.fvarAbsent (by simpa using hfresh) + have hbodyTr : TrKExprS world.venv uvars world.nameOf trProj + ((none, .vlet typeV valueV) :: Delta) body bodyV := + hbodyOpenTr.closeOpenedFVarZero hbodyEq hbodyAbsent + (hbinder.instRevBounds fv) (habstract.bounds hbodySupport fv) + obtain ⟨bodyTyCoreV, hbodyTyCoreTr, hbodyTyEq⟩ := hbodyTyTr + apply TcM.WF.bind + (TcM.WF.mono + (TcM.WF.withInv <| TcM.PreservesInferOnly.strengthenWFValue + (habstract.close_whnf_wf hcollision hbodyTySupport hbodyTyCoreTr) + (TcM.PreservesInferOnly.runIntern _) hpolicyBody) + (fun _ _ post => post) (fun _ _ post => post.1)) + intro abstracted afterAbstract habstractPost + rcases habstractPost with + ⟨hIAbstract, hpolicyAbstract, rfl, habstractedSupport, _, + habstractedTr⟩ + have hsubstBounds := hsubst.bounds (depth := 0) + habstractedSupport hvalueSupport + obtain ⟨_, hvalueCon, _, _, hsubstBig⟩ := hsubstBounds + have hsubstTr : TrKExprS world.venv uvars world.nameOf trProj Delta + (KExpr.substSpec + (KExpr.abstractFVarsResult bodyTy #[fv]) value 0) bodyTyCoreV := + TrKExprS.inst_let_lbr world.venvWF.ordered + theory.projections.weakN hvalueCon habstractedTr hvalueTr (by + simpa using hsubstBig) + apply TcM.WF.bind + (TcM.WF.mono + (TcM.WF.withInv <| TcM.PreservesInferOnly.strengthenWFValue + (hsubst.whnf_wf hcollision habstractedSupport hvalueSupport) + (TcM.PreservesInferOnly.runIntern _) hpolicyAbstract) + (fun _ _ post => post) (fun _ _ post => post.1)) + intro substituted afterSubst hsubstPost + rcases hsubstPost with + ⟨hISubst, hpolicySubst, rfl, hsubstitutedSupport, _⟩ + have hsubstitutedQ : TrKExpr world.venv uvars world.nameOf trProj Delta + (KExpr.substSpec + (KExpr.abstractFVarsResult bodyTy #[fv]) value 0) bodyTyV := + ⟨bodyTyCoreV, hsubstTr, hbodyTyEq⟩ + have hcheapMeaning := KExpr.cheapBetaReduceResult_meaning theory + hISubst.2.1.wf.1 hsubstTr (hcheap.bounds hsubstitutedSupport) + apply TcM.WF.mono + (TcM.WF.mono + (TcM.WF.withInv <| TcM.PreservesInferOnly.strengthenWFValue + (hcheap.whnf_wf hcollision hsubstitutedSupport) + (TcM.PreservesInferOnly.runIntern _) hpolicySubst) + (fun _ _ post => post) (fun _ _ post => post.1)) + · intro result final hresult + rcases hresult with + ⟨hIFinal, hpolicyFinal, 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 + have hsourceTr : TrKExprS world.venv uvars world.nameOf trProj Delta + (.letE name type value body nondep info) bodyV := + .letE hvalueType htypeTr hvalueTr hbodyTr + exact ⟨hpolicyFinal, hresultSupport, hsourceTr, + bodyTyV, hresultQ, hbodyTy'⟩ + · intro _ _ herror + exact herror + +/-- Full-mode let inference validates its annotation and value before +running the production abstraction/substitution/cheap-beta tail. -/ +theorem inferUncached_let_full_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {methods : Methods .anon} {s : TcState .anon} + {name : Mode.anon.F Name} + {type value body : KExpr .anon} {nondep : Bool} + {info : ExprInfo .anon} {sourceV : VExpr} + (theory : WhnfTheory trProj world uvars) + (callbacks : FullInferenceStepContext semantics trProj world support + uvars methods) + (habstract : SingletonAbstractionResources support) + (hsubst : SubstitutionResources support) + (hcheap : CheapBetaResources support) + (htypeSupport : support type) + (hvalueSupport : support value) + (hbinder : BinderOpeningResources support name body) + (hcollision : support.CollisionFree) + (hsource : PreTrKExprS world.venv uvars world.nameOf trProj Delta + (.letE name type value body nondep info) sourceV) + (hpolicy : s.inferOnly = false) : + TcM.WF + (WhnfStateInv .noAccel semantics trProj world support uvars Delta) s + ((inferUncached inferCall false + (.letE name type value body nondep info)).run methods) + (fun result after => + after.inferOnly = false ∧ + FullInferPost trProj world support uvars Delta + (.letE name type value body nondep info) sourceV result) + (fun _ after => after.inferOnly = false) := by + cases hsource with + | letE htypePre hvaluePre hbodyPre => + rename_i typeV valueV + unfold inferUncached + simp only [Bool.not_false, if_true, ReaderT.run_bind, + ReaderT.run_monadLift, inferCall, isDefEqCall, pure_bind] + apply TcM.WF.bind + (TcM.WF.withInv <| callbacks.infer hpolicy htypeSupport htypePre) + intro typeTy afterType htypePost + rcases htypePost with + ⟨hIType, hpolicyType, htypeTySupport, htypeTr, + typeTyV, htypeTyTr, htypeTy⟩ + apply TcM.WF.bind + (TcM.WF.withInv <| + callbacks.ensureSort hpolicyType htypeTySupport htypeTyTr) + intro _ afterSort hsortPost + rcases hsortPost with ⟨hISort, hpolicySort, _⟩ + apply TcM.WF.bind + (TcM.WF.withInv <| + callbacks.infer hpolicySort hvalueSupport hvaluePre) + intro valueTy afterValue hvaluePost + rcases hvaluePost with + ⟨hIValue, hpolicyValue, hvalueTySupport, hvalueTr, + valueTyV, hvalueTyTr, hvalueTy⟩ + obtain ⟨valueTyCoreV, hvalueTyCoreTr, hvalueTyEq⟩ := hvalueTyTr + apply TcM.WF.bind + (TcM.WF.withInv <| callbacks.isDefEq hpolicyValue + hvalueTySupport htypeSupport hvalueTyCoreTr htypeTr) + intro equal afterEq hequal + rcases hequal with ⟨hIEq, hpolicyEq, heq⟩ + cases equal with + | false => + simp only [Bool.not_false, if_true] + exact TcM.WF.throw fun _ => hpolicyEq + | true => + simp only [Bool.not_true, Bool.false_eq_true, if_false] + have hvalueType : world.venv.HasType uvars Delta.toCtx + valueV typeV := + hvalueTy.defeqU_r world.venvWF hIEq.2.1.wf.toCtx <| + hvalueTyEq.symm.trans world.venvWF hIEq.2.1.wf.toCtx + (heq rfl) + apply withLctxScope_openLet_pre_wf + (layer := .noAccel) (semantics := semantics) (trProj := trProj) + (world := world) (support := support) (uvars := uvars) + (Delta := Delta) (methods := methods) (s := afterEq) + (k := fun bodyOpen fv => do + let bodyTy ← inferCall bodyOpen + let abstracted ← TcM.runIntern (abstractFVars bodyTy #[fv]) + let result ← TcM.runIntern (subst abstracted value 0) + TcM.runIntern (cheapBetaReduce result)) + (Qinner := fun result after => + after.inferOnly = false ∧ + FullInferPost trProj world support uvars Delta + (.letE name type value body nondep info) sourceV result) + (Qouter := fun result after => + after.inferOnly = false ∧ + FullInferPost trProj world support uvars Delta + (.letE name type value body nondep info) sourceV result) + (Einner := fun _ after => after.inferOnly = false) + (Eouter := fun _ after => after.inferOnly = false) + htypeTr hvalueTr hvalueType hbodyPre hcollision hbinder hpolicyEq + · intro bodyOpen fv after hfv hbodyEq hbodySupport hfresh + hbodyOpenPre hpolicyOpen + subst fv + exact inferLetFullTail_wf + (semantics := semantics) (trProj := trProj) (world := world) + (support := support) (uvars := uvars) (Delta := Delta) + (methods := methods) (s := after) (name := name) + (type := type) (value := value) (body := body) + (nondep := nondep) (info := info) + (typeV := typeV) (valueV := valueV) (bodyV := sourceV) + theory callbacks habstract hsubst hcheap hcollision htypeTr + hvalueSupport hvalueTr hvalueType hbodyPre hbinder hbodyEq + hfresh hbodySupport hbodyOpenPre hpolicyOpen + · intro result after hresult + simpa using hresult + · intro err after herror + simpa using herror + · intro err + exact hpolicyEq + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/FullInferenceCache.lean b/Ix/Tc/Verify/Check/FullInferenceCache.lean new file mode 100644 index 000000000..0acc5938b --- /dev/null +++ b/Ix/Tc/Verify/Check/FullInferenceCache.lean @@ -0,0 +1,198 @@ +import Ix.Tc.Verify.Check.FullInferenceDispatcher +import Ix.Tc.Verify.Infer.CacheSoundness + +/-! +# Full-inference cache shell + +The K3 uncached dispatcher establishes a typed source translation from +`PreTrKExprS`. This module closes the production `inferWith` cache shell +around that result. Full-cache hits are reconciled with the current raw +translation; misses construct ordinary collision-robust K2 provenance before +writing the validated cache partition. +-/ + +namespace Ix.Tc + +namespace FullUncachedInference.Context + +/-- Every direct constant root of a new full-inference cache entry is +authorized by 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} {methods : Methods .anon} + (context : FullUncachedInference.Context initial program requests + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars methods) + {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.base.references hsourceSupport hsourceRef + · exact context.base.references hty hresult + +/-- Execute a full-mode cache miss and install its result only after the +typed source translation has supplied ordinary K2 inference provenance. +Both the uncached body and the cache write preserve full mode on errors. -/ +private theorem missTail_full_wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {model : KernelSuffixModel trProj world} {methods : Methods .anon} + (context : FullUncachedInference.Context initial program requests + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars methods) + {Delta : KVLCtx} {before s : TcState .anon} + {source : KExpr .anon} {sourceV : Lean4Lean.VExpr} + {key : Address × Address} + (hmatch : model.keys.Matches trProj world before Delta source key) + (hsourceSupport : support source) + (hsource : PreTrKExprS world.venv model.keys.uvars world.nameOf trProj + Delta source sourceV) + (hpolicy : s.inferOnly = false) : + TcM.WF + (WhnfStateInv .noAccel (kernelCacheSemantics model.keys trProj) + trProj world support model.keys.uvars Delta) s + ((do + let ty ← RecM.inferUncached RecM.inferCall false source + RecM.cacheInferResult false key ty + pure ty).run methods) + (fun result after => after.inferOnly = false ∧ + FullInferPost trProj world support model.keys.uvars Delta source + sourceV result) + (fun _ after => after.inferOnly = false) := by + simp only [ReaderT.run_bind] + apply TcM.WF.bind + (TcM.WF.withInv <| + RecM.inferUncached_full_wf context hsourceSupport hsource hpolicy) + intro ty afterBody hbody + rcases hbody with + ⟨hI, hpolicyBody, htySupport, hsourceTr, hpost⟩ + have hprovenance := model.inferProvenance + context.base.projection.run.collisionFree .infer hsourceSupport + htySupport hmatch (InferMeaning.of_post hsourceTr hpost) + (context.cacheReferences htySupport) + apply TcM.WF.bind + (TcM.WF.mono + (TcM.PreservesInferOnly.strengthenWFValue + ((RecM.cacheInferResult_full_wf hprovenance) + methods context.methodSemantics) + (RecM.cacheInferResult_preservesInferOnly false key ty methods) + hpolicyBody) + (fun _ _ post => post) (fun _ _ post => post.1)) + intro _ afterWrite hwrite + exact TcM.WF.pure fun _ => + ⟨hwrite.1, htySupport, hsourceTr, hpost⟩ + +end FullUncachedInference.Context + +namespace RecM + +/-- Complete production `inferWith` in full mode from untyped structural +ingress. A hit upgrades the current raw translation from cache provenance; +a miss runs the exhaustive K3 dispatcher and writes validated provenance. -/ +theorem inferWith_full_wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {model : KernelSuffixModel trProj world} {methods : Methods .anon} + (context : FullUncachedInference.Context initial program requests + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars methods) + {Delta : KVLCtx} {s : TcState .anon} + {source : KExpr .anon} {sourceV : Lean4Lean.VExpr} + (hsourceSupport : support source) + (hsource : PreTrKExprS world.venv model.keys.uvars world.nameOf trProj + Delta source sourceV) + (hpolicy : s.inferOnly = false) : + TcM.WF + (WhnfStateInv .noAccel (kernelCacheSemantics model.keys trProj) + trProj world support model.keys.uvars Delta) s + ((inferWith inferCall source).run methods) + (fun result after => after.inferOnly = false ∧ + FullInferPost trProj world support model.keys.uvars Delta source + sourceV result) + (fun _ after => after.inferOnly = false) := by + unfold inferWith + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.WF.bind + (Q₁ := fun observed after => + observed = s ∧ after = s ∧ after.inferOnly = false) + (TcM.WF.get fun _ => ⟨rfl, rfl, hpolicy⟩) + intro observed after hread + rcases hread with ⟨rfl, rfl, hpolicyRead⟩ + apply TcM.WF.bind + (TcM.WF.mono + (TcM.PreservesInferOnly.strengthenWFValue + (TcM.inferKey_model_matches_wf model) + (TcM.PreservesInferOnly.inferKey source) hpolicyRead) + (fun _ _ post => post) (fun _ _ post => post.1)) + intro key afterKey hkey + rcases hkey with ⟨hpolicyKey, hmatch, hframe⟩ + apply TcM.WF.bind + (Q₁ := fun current after => + current = afterKey ∧ after = afterKey ∧ after.inferOnly = false) + (TcM.WF.get fun _ => ⟨rfl, rfl, hpolicyKey⟩) + intro current afterRead hread + rcases hread with ⟨rfl, rfl, hpolicyAfterRead⟩ + let fullFound := afterRead.env.inferCache[key]? + cases hfullFound : fullFound with + | some cached => + have hhit : afterRead.env.inferCache[key]? = some cached := by + simpa [fullFound] using hfullFound + simp only [hhit] + exact TcM.WF.pure fun hI => by + have hprovenance := hI.1.caches.hit (.infer hhit) + have hmeaning := hprovenance.kernelInferMeaningOfMatches + .infer hsourceSupport hmatch + obtain ⟨typedV, htyped, hcachedPost⟩ := hmeaning + have hsourceTyped : TrKExprS world.venv model.keys.uvars + world.nameOf trProj Delta source sourceV := + hsource.upgradeOfTyped world.venvWF + context.base.projection.theory.literalWF + context.base.projection.theory.projections + (KVLCtx.IsDefEq.refl world.venvWF hI.2.1.wf) htyped + exact ⟨hpolicyAfterRead, hprovenance.supported.2, hsourceTyped, + InferMeaning.post context.base.projection.theory hI.2.1.wf + hsourceTyped ⟨typedV, htyped, hcachedPost⟩⟩ + | none => + have hfullMiss : afterRead.env.inferCache[key]? = none := by + simpa [fullFound] using hfullFound + simp only [hfullMiss, hpolicy, Bool.false_eq_true, if_false] + exact context.missTail_full_wf hmatch hsourceSupport hsource + hpolicyAfterRead + +/-- `RecM.infer` is definitionally the full cache shell above. -/ +theorem infer_full_wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {model : KernelSuffixModel trProj world} {methods : Methods .anon} + (context : FullUncachedInference.Context initial program requests + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars methods) + {Delta : KVLCtx} {s : TcState .anon} + {source : KExpr .anon} {sourceV : Lean4Lean.VExpr} + (hsourceSupport : support source) + (hsource : PreTrKExprS world.venv model.keys.uvars world.nameOf trProj + Delta source sourceV) + (hpolicy : s.inferOnly = false) : + TcM.WF + (WhnfStateInv .noAccel (kernelCacheSemantics model.keys trProj) + trProj world support model.keys.uvars Delta) s + ((infer source).run methods) + (fun result after => after.inferOnly = false ∧ + FullInferPost trProj world support model.keys.uvars Delta source + sourceV result) + (fun _ after => after.inferOnly = false) := by + simpa [infer] using + (inferWith_full_wf context hsourceSupport hsource hpolicy) + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/FullInferenceDispatcher.lean b/Ix/Tc/Verify/Check/FullInferenceDispatcher.lean new file mode 100644 index 000000000..6a9c5ad74 --- /dev/null +++ b/Ix/Tc/Verify/Check/FullInferenceDispatcher.lean @@ -0,0 +1,175 @@ +import Ix.Tc.Verify.Check.FullInferenceProjections +import Ix.Tc.Verify.Infer.Dispatcher + +/-! +# Exhaustive full-mode inference dispatcher + +This module assembles the constructor-local K3 proofs for +`inferUncached inferCall false`. Unlike the K2 dispatcher, its input is only +`PreTrKExprS`; successful execution establishes the missing typed source +translation as part of `FullInferPost`. + +The context keeps semantic closure and operational policy frames separate. +In particular, neither the ordinary method-table contract nor a successful +typing postcondition says what `inferOnly` contains after a partial error. +-/ + +namespace Ix.Tc + +namespace FullUncachedInference + +/-- Resources for one full-mode layer over a fixed smaller method table. +`uncachedPolicy` covers the leaf actions reused from K2, while +`projectionPolicy` exposes the corresponding frame for the projection helper +itself. Both are purely operational obligations to be discharged by the +concrete policy closure proof. -/ +structure Context + {alpha : Type} (initial : TcState .anon) (program : TcM .anon alpha) + (requests : List WalkerRequest) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) (methods : Methods .anon) : Type where + base : UncachedInference.Context initial program requests semantics trProj + world support uvars + methodSemantics : Methods.WFAt .noAccel semantics trProj world support + uvars methods + callbacks : FullInferenceStepContext semantics trProj world support uvars + methods + uncachedPolicy : ∀ inferOnly source, + ((RecM.inferUncached RecM.inferCall inferOnly source).run methods).PreservesInferOnly + projectionPolicy : ProjectionInference.PreservesInferOnlyAt methods + +end FullUncachedInference + +namespace RecM + +/-- Add the fixed full-mode policy fact to a semantic leaf proof. -/ +private theorem strengthenFullLeaf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {s : TcState .anon} {source : KExpr .anon} + {sourceV : Lean4Lean.VExpr} {methods : Methods .anon} + (hsemantic : TcM.WF + (WhnfStateInv .noAccel semantics trProj world support uvars Delta) s + ((inferUncached inferCall false source).run methods) + (fun result _ => + FullInferPost trProj world support uvars Delta source sourceV result)) + (hframe : + ((inferUncached inferCall false source).run methods).PreservesInferOnly) + (hpolicy : s.inferOnly = false) : + TcM.WF + (WhnfStateInv .noAccel semantics trProj world support uvars Delta) s + ((inferUncached inferCall false source).run methods) + (fun result after => after.inferOnly = false ∧ + FullInferPost trProj world support uvars Delta source sourceV result) + (fun _ after => after.inferOnly = false) := by + apply TcM.WF.mono + (TcM.PreservesInferOnly.strengthenWFValue hsemantic hframe hpolicy) + · intro _ _ post + exact post + · intro _ _ post + exact post.1 + +/-- Exhaustive K3 correctness of `inferUncached` in full mode. Every syntax +constructor is covered from untyped structural ingress, and both outcomes +retain `inferOnly = false`. -/ +theorem inferUncached_full_wf + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {methods : Methods .anon} + (context : FullUncachedInference.Context initial program requests + semantics trProj world support uvars methods) + {Delta : KVLCtx} {s : TcState .anon} + {source : KExpr .anon} {sourceV : Lean4Lean.VExpr} + (hsourceSupport : support source) + (hsource : PreTrKExprS world.venv uvars world.nameOf trProj Delta source + sourceV) + (hpolicy : s.inferOnly = false) : + TcM.WF + (WhnfStateInv .noAccel semantics trProj world support uvars Delta) s + ((inferUncached inferCall false source).run methods) + (fun result after => after.inferOnly = false ∧ + FullInferPost trProj world support uvars Delta source sourceV result) + (fun _ after => after.inferOnly = false) := by + cases source with + | var idx name info => + intro hI + obtain ⟨hrequest, hbound⟩ := + context.base.variables hI hsourceSupport + exact (strengthenFullLeaf + ((inferUncached_var_full_wf context.base.projection.run + context.base.projection.theory hsource hrequest hbound) + methods context.methodSemantics) + (context.uncachedPolicy false (.var idx name info)) hpolicy) hI + | fvar fv name info => + exact strengthenFullLeaf + ((inferUncached_fvar_full_wf context.base.projection.theory + (context.base.fvars Delta) hsource) + methods context.methodSemantics) + (context.uncachedPolicy false (.fvar fv name info)) hpolicy + | sort u info => + exact strengthenFullLeaf + ((inferUncached_sort_full_wf context.base.projection.theory + context.base.projection.run.collisionFree + (context.base.structural.sortResult hsourceSupport) hsource) + methods context.methodSemantics) + (context.uncachedPolicy false (.sort u info)) hpolicy + | const id levels info => + exact strengthenFullLeaf + ((inferUncached_const_full_wf context.base.projection.run + context.base.projection.theory (context.base.projection.fault Delta) + context.base.references context.base.constTypes + context.base.constants hsourceSupport hsource) + methods context.methodSemantics) + (context.uncachedPolicy false (.const id levels info)) hpolicy + | app f a info => + exact inferUncached_app_full_wf context.base.projection.run + context.base.projection.theory context.callbacks + context.methodSemantics context.base.applications hsourceSupport + hsource hpolicy + | lam name bi ty body info => + obtain ⟨hty, hbinder, hresult⟩ := + context.base.structural.lambda hsourceSupport + exact inferUncached_lam_full_wf context.base.projection.run + context.base.projection.theory context.callbacks + context.base.cheapBeta context.base.abstraction hresult hty hbinder + hsource hpolicy + | all name bi ty body info => + obtain ⟨hty, hbinder⟩ := + context.base.structural.forallE hsourceSupport + exact inferUncached_all_full_wf context.base.projection.run + context.base.projection.theory context.callbacks + context.base.abstraction context.base.forallResults hty hbinder + hsource hpolicy + | letE name ty val body nondep info => + obtain ⟨hty, hval, hbinder⟩ := + context.base.structural.letE hsourceSupport + exact inferUncached_let_full_wf context.base.projection.theory + context.callbacks context.base.abstraction + context.base.projection.substitution context.base.cheapBeta hty hval + hbinder context.base.projection.run.collisionFree hsource hpolicy + | prj structId field val info => + have hprojection : ProjectionInference.FullWFAt semantics trProj world + support uvars methods := + ProjectionInference.FullWFAt.of_semantic_and_policy + context.methodSemantics context.base.projection.wf + context.projectionPolicy + exact inferUncached_prj_full_wf context.callbacks + context.base.projectionValues hprojection hsourceSupport hsource + hpolicy + | nat n blob info => + exact strengthenFullLeaf + ((inferUncached_nat_full_wf context.base.literals + context.base.projection.theory hsource) + methods context.methodSemantics) + (context.uncachedPolicy false (.nat n blob info)) hpolicy + | str value blob info => + exact strengthenFullLeaf + ((inferUncached_str_full_wf context.base.literals + context.base.projection.theory hsource) + methods context.methodSemantics) + (context.uncachedPolicy false (.str value blob info)) hpolicy + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/FullInferenceKnot.lean b/Ix/Tc/Verify/Check/FullInferenceKnot.lean new file mode 100644 index 000000000..35b27b4e0 --- /dev/null +++ b/Ix/Tc/Verify/Check/FullInferenceKnot.lean @@ -0,0 +1,230 @@ +import Ix.Tc.Verify.Check.FullInferenceCache +import Ix.Tc.Verify.Check.RecursiveMethodPolicy +import Ix.Tc.Verify.RecursiveMethods.Closure + +/-! +# Full-inference closure of the production recursion knot + +K2 closes the ordinary six-field semantic contract from an already typed +source. K3 needs a stronger contract for the inference field: when the +caller is in full mode, successful inference must construct the typed source +translation from `PreTrKExprS`, and both success and partial errors must +restore full mode. + +This module ties that stronger contract through the same finite `methodsN` +approximations used by production. The induction remains well founded: +one outer `RecM.infer` layer uses only the semantic, operational, and strong +full-inference contracts of its strictly smaller callback table. +-/ + +namespace Ix.Tc + +namespace Methods + +/-- Strong K3 contract for the inference field of one fixed method table. +Unlike ordinary K2 inference, this starts from untyped structural ingress and +records the full-mode frame on both outcomes. -/ +def FullInferenceWFAt + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) + (methods : Methods .anon) : Prop := + ∀ {Delta : KVLCtx} {s : TcState .anon} + {source : KExpr .anon} {sourceV : Lean4Lean.VExpr}, + s.inferOnly = false → + support source → + PreTrKExprS world.venv uvars world.nameOf trProj Delta source sourceV → + TcM.WF + (WhnfStateInv .noAccel semantics trProj world support uvars Delta) s + (methods.infer source) + (fun result after => + after.inferOnly = false ∧ + FullInferPost trProj world support uvars Delta source sourceV + result) + (fun _ after => after.inferOnly = false) + +end Methods + +namespace RecursiveMethodClosureContext + +/-- Assemble every resource needed by one full-inference body over a fixed +smaller method table. Ordinary semantic closure, the independent policy +frame, and the stronger recursive-inference induction hypothesis remain +separate premises. -/ +def fullInferenceContext + {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 : Methods .anon) + (hmethods : Methods.WFAt .noAccel + (kernelCacheSemantics proposition.model.keys trProj) trProj world support + proposition.model.keys.uvars methods) + (hpolicy : methods.PreservesInferOnly) + (hfull : Methods.FullInferenceWFAt + (kernelCacheSemantics proposition.model.keys trProj) trProj world support + proposition.model.keys.uvars methods) : + FullUncachedInference.Context initial program requests + (kernelCacheSemantics proposition.model.keys trProj) trProj world support + proposition.model.keys.uvars methods := by + let hnextPolicy := Methods.next_preservesInferOnly methods hpolicy + refine { + base := context.inferDefEq.inference + methodSemantics := hmethods + callbacks := FullInferenceStepContext.of_semantic_and_policy + hmethods hpolicy hnextPolicy.whnf ?_ ?_ ?_ + uncachedPolicy := ?_ + projectionPolicy := ?_ } + · intro Delta s source sourceV hbefore hsourceSupport hsource + apply TcM.WF.mono (hfull hbefore hsourceSupport hsource) + · intro _ _ post + exact post.2 + · intro _ _ _ + trivial + · intro Delta s source sourceV hsourceSupport hsource + exact + (RecM.ensureForallDirect_wf + context.inferDefEq.inference.projection.whnf + context.inferDefEq.inference.projection.components + hsourceSupport hsource) methods hmethods + · intro Delta s source sourceV hsourceSupport hsource + exact + (RecM.ensureSortDirect_wf + context.inferDefEq.inference.projection.whnf + context.inferDefEq.inference.projection.sorts + hsourceSupport hsource) methods hmethods + · intro inferOnly source + exact RecM.inferUncached_preservesInferOnly_of_whnf methods hpolicy + hnextPolicy.whnf inferOnly source + · exact ProjectionInference.preservesInferOnlyAt methods hpolicy + hnextPolicy.whnf + +/-- One unfolded production inference layer satisfies K3 whenever its +strictly smaller callback table satisfies the three independent premises. -/ +theorem next_fullInferenceWFAt + {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 : Methods .anon) + (hmethods : Methods.WFAt .noAccel + (kernelCacheSemantics proposition.model.keys trProj) trProj world support + proposition.model.keys.uvars methods) + (hpolicy : methods.PreservesInferOnly) + (hfull : Methods.FullInferenceWFAt + (kernelCacheSemantics proposition.model.keys trProj) trProj world support + proposition.model.keys.uvars methods) : + Methods.FullInferenceWFAt + (kernelCacheSemantics proposition.model.keys trProj) trProj world support + proposition.model.keys.uvars (Methods.next methods) := by + intro Delta s source sourceV hbefore hsourceSupport hsource + simpa [Methods.next] using + (RecM.infer_full_wf + (context.fullInferenceContext methods hmethods hpolicy hfull) + hsourceSupport hsource hbefore) + +end RecursiveMethodClosureContext + +namespace Methods + +/-- The exhausted callback table satisfies the strong contract vacuously: +its inference field throws `maxRecFuel` without changing state. -/ +theorem methodsOut_fullInferenceWFAt + (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) : + FullInferenceWFAt semantics trProj world support uvars + (methodsOut : Methods .anon) := by + intro Delta s source sourceV hbefore _ _ + exact TcM.WF.throw (fun _ => hbefore) + +end Methods + +namespace RecursiveMethodClosureContext + +/-- Every finite callback table selected by production satisfies the strong +full-inference contract. -/ +theorem methodsN_fullInferenceWFAt + {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) (depth : Nat) : + Methods.FullInferenceWFAt + (kernelCacheSemantics proposition.model.keys trProj) trProj world support + proposition.model.keys.uvars + (Ix.Tc.methodsN (m := .anon) depth) := by + induction depth with + | zero => + exact Methods.methodsOut_fullInferenceWFAt + (kernelCacheSemantics proposition.model.keys trProj) trProj world + support proposition.model.keys.uvars + | succ depth ih => + intro Delta s source sourceV hbefore hsourceSupport hsource + change TcM.WF + (WhnfStateInv .noAccel + (kernelCacheSemantics proposition.model.keys trProj) trProj world + support proposition.model.keys.uvars Delta) s + ((Methods.next (Ix.Tc.methodsN depth)).infer source) + (fun result after => + after.inferOnly = false ∧ + FullInferPost trProj world support proposition.model.keys.uvars + Delta source sourceV result) + (fun _ after => after.inferOnly = false) + exact + (context.next_fullInferenceWFAt (Ix.Tc.methodsN depth) + (context.methodsN depth) + (Methods.methodsN_concrete_preservesInferOnly depth) ih) + hbefore hsourceSupport hsource + +/-- The public inference action executes one full body over the finite table +selected from the caller's current recursive fuel. -/ +theorem publicInfer_full_wf + {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) + {Delta : KVLCtx} {s : TcState .anon} + {source : KExpr .anon} {sourceV : Lean4Lean.VExpr} + (hbefore : s.inferOnly = false) + (hsourceSupport : support source) + (hsource : PreTrKExprS world.venv proposition.model.keys.uvars + world.nameOf trProj Delta source sourceV) : + TcM.WF + (WhnfStateInv .noAccel + (kernelCacheSemantics proposition.model.keys trProj) trProj world + support proposition.model.keys.uvars Delta) s + (TcM.infer source) + (fun result after => + after.inferOnly = false ∧ + FullInferPost trProj world support proposition.model.keys.uvars + Delta source sourceV result) + (fun _ after => after.inferOnly = false) := by + let methods := Ix.Tc.methodsN (m := .anon) s.recFuel.toNat + have hmethods : Methods.WFAt .noAccel + (kernelCacheSemantics proposition.model.keys trProj) trProj world support + proposition.model.keys.uvars methods := + context.methodsN s.recFuel.toNat + have hpolicy : methods.PreservesInferOnly := + Methods.methodsN_concrete_preservesInferOnly s.recFuel.toNat + have hfull : Methods.FullInferenceWFAt + (kernelCacheSemantics proposition.model.keys trProj) trProj world support + proposition.model.keys.uvars methods := + context.methodsN_fullInferenceWFAt s.recFuel.toNat + simpa [TcM.infer, TcM.runRec, methods] using + (RecM.infer_full_wf + (context.fullInferenceContext methods hmethods hpolicy hfull) + hsourceSupport hsource hbefore) + +end RecursiveMethodClosureContext + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/FullInferenceLeaves.lean b/Ix/Tc/Verify/Check/FullInferenceLeaves.lean new file mode 100644 index 000000000..768cd9174 --- /dev/null +++ b/Ix/Tc/Verify/Check/FullInferenceLeaves.lean @@ -0,0 +1,182 @@ +import Ix.Tc.Verify.Check.FullInference + +/-! +# Full inference for untyped leaf ingress + +The leaf constructors of `PreTrKExprS` already contain every premise of the +corresponding `TrKExprS` constructor. They therefore reuse the completed K2 +operational proofs directly and strengthen only the postcondition. The +application and binder constructors remain genuinely new K3 work because +their typed constructors contain the checks full inference must establish. +-/ + +namespace Ix.Tc + +namespace RecM + +theorem inferUncached_sort_full_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 : PreTrKExprS 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 result _ => FullInferPost trProj world support uvars Delta + (.sort u info) sourceV result) := by + cases hsource with + | sort hu => + let htyped : TrKExprS world.venv uvars world.nameOf trProj Delta + (.sort u info) (.sort u.toVLevel) := .sort hu + exact RecM.WF.mono + (inferUncached_sort_wf theory hcollision hresultSupport htyped) + (fun _ _ hpost => FullInferPost.of_typed htyped hpost) + (fun _ _ _ => trivial) + +theorem inferUncached_var_full_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 : PreTrKExprS 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 result _ => FullInferPost trProj world support uvars Delta + (.var idx name info) sourceV result) := by + cases hsource with + | var hfind => + let htyped : TrKExprS world.venv uvars world.nameOf trProj Delta + (.var idx name info) sourceV := .var hfind + exact RecM.WF.mono + (inferUncached_var_wf hrun theory htyped hmem hbig) + (fun _ _ hpost => FullInferPost.of_typed htyped hpost) + (fun _ _ _ => trivial) + +theorem inferUncached_fvar_full_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 : PreTrKExprS 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 result _ => FullInferPost trProj world support uvars Delta + (.fvar fv name info) sourceV result) := by + cases hsource with + | fvar hfind => + let htyped : TrKExprS world.venv uvars world.nameOf trProj Delta + (.fvar fv name info) sourceV := .fvar hfind + exact RecM.WF.mono (inferUncached_fvar_wf theory hsafe htyped) + (fun _ _ hpost => FullInferPost.of_typed htyped hpost) + (fun _ _ _ => trivial) + +theorem inferUncached_const_full_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} + {levels : 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 levels info)) + (hsource : PreTrKExprS world.venv uvars world.nameOf trProj Delta + (.const id levels info) sourceV) : + RecM.WF layer semantics trProj world support uvars Delta s + (inferUncached inferRec inferOnly (.const id levels info)) + (fun result _ => FullInferPost trProj world support uvars Delta + (.const id levels info) sourceV result) := by + cases hsource with + | const hname hlookup hlevels harity => + rename_i name ci + let htyped : TrKExprS world.venv uvars world.nameOf trProj Delta + (.const id levels info) + (.const name (levels.toList.map KUniv.toVLevel)) := + .const hname hlookup hlevels harity + exact RecM.WF.mono + (inferUncached_const_wf hrun theory hfault hreferences htypes + hcensus hsourceSupport htyped) + (fun _ _ hpost => FullInferPost.of_typed htyped hpost) + (fun _ _ _ => trivial) + +theorem inferUncached_nat_full_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 : PreTrKExprS 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 result _ => FullInferPost trProj world support uvars Delta + (.nat n blob info) sourceV result) := by + cases hsource with + | nat hcontains => + let htyped : TrKExprS world.venv uvars world.nameOf trProj Delta + (.nat n blob info) (.natLit n) := .nat hcontains + exact RecM.WF.mono (inferUncached_nat_wf context theory htyped) + (fun _ _ hpost => FullInferPost.of_typed htyped hpost) + (fun _ _ _ => trivial) + +theorem inferUncached_str_full_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 : PreTrKExprS 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 result _ => FullInferPost trProj world support uvars Delta + (.str value blob info) sourceV result) := by + cases hsource with + | str hcontains => + let htyped : TrKExprS world.venv uvars world.nameOf trProj Delta + (.str value blob info) (.trLiteral (.strVal value)) := + .str hcontains + exact RecM.WF.mono (inferUncached_str_wf context theory htyped) + (fun _ _ hpost => FullInferPost.of_typed htyped hpost) + (fun _ _ _ => trivial) + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/FullInferenceProjections.lean b/Ix/Tc/Verify/Check/FullInferenceProjections.lean new file mode 100644 index 000000000..6c0041ea3 --- /dev/null +++ b/Ix/Tc/Verify/Check/FullInferenceProjections.lean @@ -0,0 +1,127 @@ +import Ix.Tc.Verify.Check.FullInferenceBinders +import Ix.Tc.Verify.Infer.ProjectionTypes + +/-! +# Full inference for projections + +The K2 projection branch starts from a typed `TrKExprS` source. At checker +ingress K3 instead has only `PreTrKExprS`: it first establishes a typed +translation for the projected value, then delegates to the already verified +`inferProj` helper. + +The helper's semantic contract is intentionally separate from its operational +policy frame. A typing proof alone cannot show that a partial error preserved +`TcState.inferOnly`; `ProjectionInference.FullWFAt` combines those two facts +for one concrete smaller method table. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr) + +namespace ProjectionInference + +/-- Outcome-sensitive policy frame for every invocation of `inferProj` using +one fixed recursive method table. -/ +def PreservesInferOnlyAt (methods : Methods .anon) : Prop := + ∀ structId field val valTy, + ((RecM.inferProj structId field val valTy).run methods).PreservesInferOnly + +/-- Strong projection-helper contract needed by K3 full inference. It is +fixed to the smaller production method table and retains full mode on both +success and error. -/ +def FullWFAt (semantics : CacheSemantics) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) (uvars : Nat) + (methods : Methods .anon) : Prop := + ∀ {Delta : KVLCtx} {s : TcState .anon} + {structId : KId .anon} {field : UInt64} {val valTy : KExpr .anon} + {valV projectedV : VExpr} {structName : Lean.Name}, + s.inferOnly = false → + 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 → + TcM.WF + (WhnfStateInv .noAccel semantics trProj world support uvars Delta) s + ((RecM.inferProj structId field val valTy).run methods) + (fun result after => + after.inferOnly = false ∧ support result ∧ + InferPost trProj world uvars Delta projectedV result) + (fun _ after => after.inferOnly = false) + +/-- Combine K2 projection soundness with the independent full-mode frame. +This is the only adapter from the ordinary, method-parametric projection +contract to K3's fixed-table contract. -/ +theorem FullWFAt.of_semantic_and_policy + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {methods : Methods .anon} + (hmethods : Methods.WFAt .noAccel semantics trProj world support uvars + methods) + (hsemantic : WF semantics trProj world support uvars) + (hpolicy : PreservesInferOnlyAt methods) : + FullWFAt semantics trProj world support uvars methods := by + intro Delta s structId field val valTy valV projectedV structName + hbefore hname hval hproj hvalTySupport hvalTy + apply TcM.WF.mono + (TcM.PreservesInferOnly.strengthenWFValue + (hsemantic hname hval hproj hvalTySupport hvalTy methods hmethods) + (hpolicy structId field val valTy) hbefore) + · intro _ _ post + exact post + · intro _ _ post + exact post.1 + +end ProjectionInference + +namespace RecM + +/-- Full-mode projection inference upgrades the recursively inferred value +from pre-translation to typed translation before invoking `inferProj`. -/ +theorem inferUncached_prj_full_wf + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {uvars : Nat} + {Delta : KVLCtx} {methods : Methods .anon} {s : TcState .anon} + {structId : KId .anon} {field : UInt64} {val : KExpr .anon} + {info : ExprInfo .anon} {sourceV : VExpr} + (callbacks : FullInferenceStepContext semantics trProj world support + uvars methods) + (hinputs : ProjectionValueSupport support) + (hprojection : ProjectionInference.FullWFAt semantics trProj world + support uvars methods) + (hsourceSupport : support (.prj structId field val info)) + (hsource : PreTrKExprS world.venv uvars world.nameOf trProj Delta + (.prj structId field val info) sourceV) + (hpolicy : s.inferOnly = false) : + TcM.WF + (WhnfStateInv .noAccel semantics trProj world support uvars Delta) s + ((inferUncached inferCall false (.prj structId field val info)).run + methods) + (fun result after => + after.inferOnly = false ∧ + FullInferPost trProj world support uvars Delta + (.prj structId field val info) sourceV result) + (fun _ after => after.inferOnly = false) := by + cases hsource with + | prj hname hvalPre hproj => + rename_i valV projectedV + unfold inferUncached + simp only [ReaderT.run_bind, ReaderT.run_monadLift, inferCall] + apply TcM.WF.bind + (callbacks.infer hpolicy (hinputs hsourceSupport) hvalPre) + intro valTy afterValue hvaluePost + rcases hvaluePost with + ⟨hpolicyValue, hvalTySupport, hvalTr, valTyV, hvalTyTr, hvalType⟩ + apply TcM.WF.mono + (hprojection hpolicyValue hname hvalTr hproj hvalTySupport + ⟨valTyV, hvalTyTr, hvalType⟩) + · intro result _ hresult + exact ⟨hresult.1, hresult.2.1, + .prj hname hvalTr hproj, hresult.2.2⟩ + · intro _ _ herror + exact herror + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/InferencePolicy.lean b/Ix/Tc/Verify/Check/InferencePolicy.lean new file mode 100644 index 000000000..2345c64df --- /dev/null +++ b/Ix/Tc/Verify/Check/InferencePolicy.lean @@ -0,0 +1,681 @@ +import Ix.Tc.Verify.Knot +import Ix.Tc.Verify.Infer.Applications +import Ix.Tc.Verify.Whnf.StructEta.CallbackPrefix +import Ix.Tc.Verify.Whnf.StructEta.RecursionClassifier + +/-! +# Inference-policy frames + +Full inference is selected by the mutable `TcState.inferOnly` bit. The +ordinary K1/K2 semantic contracts intentionally ignore operational flags, so +they cannot by themselves justify that a recursive callback which starts in +full mode returns in full mode. + +This module gives that missing fact a small, outcome-sensitive vocabulary. +`TcM.PreservesInferOnly` constrains both successful and partial-error states. +The method-table record and finite-knot lemmas isolate the remaining proof: +show that one unfolded production layer preserves the flag whenever its +smaller callbacks do. No semantic typing claim is bundled into this +operational frame. +-/ + +namespace Ix.Tc + +/-- An action restores the caller's inference policy on both outcomes. -/ +def TcM.PreservesInferOnly (x : TcM .anon alpha) : Prop := + ∀ before, + match x before with + | .ok _ after => after.inferOnly = before.inferOnly + | .error _ after => after.inferOnly = before.inferOnly + +namespace TcM.PreservesInferOnly + +/-- Turn a policy-indexed Hoare frame into the global operational frame used +by the concrete method table. -/ +theorem ofWF {x : TcM .anon alpha} + (h : ∀ before, TcM.WF + (fun after => after.inferOnly = before.inferOnly) before x + (fun _ _ => True)) : x.PreservesInferOnly := by + intro before + have hpost := h before rfl + cases hrun : x before <;> rw [hrun] at hpost <;> exact hpost.1 + +theorem ok {x : TcM .anon alpha} (hx : x.PreservesInferOnly) + {before after : TcState .anon} {value : alpha} + (hrun : x before = .ok value after) : + after.inferOnly = before.inferOnly := by + simpa [hrun] using hx before + +theorem error {x : TcM .anon alpha} (hx : x.PreservesInferOnly) + {before after : TcState .anon} {err : TcError .anon} + (hrun : x before = .error err after) : + after.inferOnly = before.inferOnly := by + simpa [hrun] using hx before + +theorem pure (value : alpha) : + (pure value : TcM .anon alpha).PreservesInferOnly := by + intro before + rfl + +theorem throw (err : TcError .anon) : + (throw err : TcM .anon alpha).PreservesInferOnly := by + intro before + rfl + +theorem get : + (get : TcM .anon (TcState .anon)).PreservesInferOnly := by + intro before + rfl + +theorem modifyGet + {f : TcState .anon → alpha × TcState .anon} + (hf : ∀ state, (f state).2.inferOnly = state.inferOnly) : + (modifyGet f : TcM .anon alpha).PreservesInferOnly := by + intro before + exact hf before + +theorem modify {f : TcState .anon → TcState .anon} + (hf : ∀ state, (f state).inferOnly = state.inferOnly) : + (modify f : TcM .anon PUnit).PreservesInferOnly := by + exact modifyGet fun state => hf state + +theorem bind {x : TcM .anon alpha} {f : alpha → TcM .anon beta} + (hx : x.PreservesInferOnly) + (hf : ∀ value, (f value).PreservesInferOnly) : + (x >>= f).PreservesInferOnly := by + intro before + show (match EStateM.bind x f before with + | .ok _ after => after.inferOnly = before.inferOnly + | .error _ after => after.inferOnly = before.inferOnly) + unfold EStateM.bind + cases hrun : x before with + | ok value middle => + have hfirst := hx.ok hrun + cases hnext : f value middle with + | ok result after => + simpa only [hnext] using (hf value).ok hnext |>.trans hfirst + | error err after => + simpa only [hnext] using (hf value).error hnext |>.trans hfirst + | error err after => + simpa only [hrun] using hx.error hrun + +theorem tryCatch {x : TcM .anon alpha} + {handler : TcError .anon → TcM .anon alpha} + (hx : x.PreservesInferOnly) + (hh : ∀ err, (handler err).PreservesInferOnly) : + (tryCatch x handler).PreservesInferOnly := by + intro before + show (match (EStateM.tryCatch x handler : TcM .anon alpha) before with + | .ok _ after => after.inferOnly = before.inferOnly + | .error _ after => after.inferOnly = before.inferOnly) + unfold EStateM.tryCatch + cases hrun : x before with + | ok value after => + simpa only [hrun] using hx.ok hrun + | error err middle => + have hfirst := hx.error hrun + have hrestore : EStateM.Backtrackable.restore middle + (EStateM.Backtrackable.save before) = middle := rfl + simp only [hrestore] + cases hhandler : handler err middle with + | ok value after => + simpa only [hhandler] using (hh err).ok hhandler |>.trans hfirst + | error nextErr after => + simpa only [hhandler] using (hh err).error hhandler |>.trans hfirst + +private theorem tryFinally_eq + (x : TcM .anon alpha) (finalizer : TcM .anon beta) + (before : TcState .anon) : + tryFinally x finalizer before = + match x before with + | .ok value middle => + match finalizer middle with + | .ok _ after => .ok value after + | .error err after => .error err after + | .error err middle => + match finalizer middle with + | .ok _ after => .error err after + | .error cleanupErr after => .error cleanupErr after := by + unfold tryFinally + change EStateM.map (fun value : alpha × beta => value.1) + (tryFinally' x (fun _ => finalizer)) before = _ + unfold EStateM.map MonadFinally.tryFinally' EStateM.instMonadFinally + cases hrun : x before <;> + simp only [hrun] <;> + cases hcleanup : finalizer _ <;> + rfl + +/-- `finally` composes two ordinary frames. In particular, this covers +local-context scopes whose cleanup truncates only `lctx`. -/ +theorem tryFinally {x : TcM .anon alpha} {finalizer : TcM .anon beta} + (hx : x.PreservesInferOnly) + (hfinalizer : finalizer.PreservesInferOnly) : + (tryFinally x finalizer).PreservesInferOnly := by + intro before + rw [tryFinally_eq] + cases hrun : x before with + | ok value middle => + have hfirst := hx.ok hrun + cases hfinal : finalizer middle with + | ok _ after => + simpa only [hfinal] using hfinalizer.ok hfinal |>.trans hfirst + | error err after => + simpa only [hfinal] using hfinalizer.error hfinal |>.trans hfirst + | error err middle => + have hfirst := hx.error hrun + cases hfinal : finalizer middle with + | ok _ after => + simpa only [hfinal] using hfinalizer.ok hfinal |>.trans hfirst + | error cleanupErr after => + simpa only [hfinal] using hfinalizer.error hfinal |>.trans hfirst + +/-- Intern-table computations update only `env.intern`. -/ +theorem runIntern (x : InternM .anon alpha) : + (TcM.runIntern x).PreservesInferOnly := by + intro before + cases hrun : x before.env.intern + rfl + +end TcM.PreservesInferOnly + +namespace TcM.LazyFaultPreserves + +/-- Lazy ingress changes only the environment and faulted-address set, so it +preserves any fixed value of the inference-policy bit independently of the +driver hook's success or failure. -/ +theorem inferOnly (policy : Bool) : + TcM.LazyFaultPreserves (fun state => state.inferOnly = policy) := by + intro state fault addr hlazy hpolicy + cases hrun : fault addr state.env <;> + simp [TcM.lazyIngressPost, hpolicy] + +end TcM.LazyFaultPreserves + +namespace TcM.PreservesInferOnly + +/-- The installed lazy hook cannot alter checker fields outside `env`. -/ +theorem lazyIngressAddr (addr : Address) : + (TcM.lazyIngressAddr (m := .anon) addr).PreservesInferOnly := by + apply ofWF + intro before + exact TcM.lazyIngressAddr_wf + (TcM.LazyFaultPreserves.inferOnly before.inferOnly) addr before + +/-- Optional constant lookup preserves the policy through eager hits, lazy +ingress, retry, post-fault misses, and hook errors. -/ +theorem tryGetConst (id : KId .anon) : + (TcM.tryGetConst id).PreservesInferOnly := by + apply ofWF + intro before + exact TcM.tryGetConst_wf + (TcM.LazyFaultPreserves.inferOnly before.inferOnly) id before + +/-- Required lookup only converts the final optional miss to an error. -/ +theorem getConst (id : KId .anon) : + (TcM.getConst id).PreservesInferOnly := by + unfold TcM.getConst + apply bind (tryGetConst id) + intro found + cases found with + | none => exact throw _ + | some concrete => exact pure concrete + +/-- Block lookup has the same operational lazy-ingress frame. -/ +theorem tryGetBlock (id : KId .anon) : + (TcM.tryGetBlock id).PreservesInferOnly := by + apply ofWF + intro before + exact TcM.tryGetBlock_wf + (TcM.LazyFaultPreserves.inferOnly before.inferOnly) id before + +/-- Fuel consumption and exhaustion do not change inference policy. -/ +theorem tick : (TcM.tick (m := .anon)).PreservesInferOnly := by + apply ofWF + intro before + apply TcM.WF.mono + (TcM.tick.wf (I := fun after => + after.inferOnly = before.inferOnly) (fun _ hpolicy => hpolicy)) + · intros; trivial + · intros; trivial + +/-- Environment-only mutation preserves inference policy. -/ +theorem modifyEnv (f : KEnv .anon → KEnv .anon) : + (TcM.modifyEnv f).PreservesInferOnly := by + exact modify (f := fun state => { state with env := f state.env }) + (fun _ => rfl) + +/-- Unique-ownership equivalence-manager mutation changes no policy field. -/ +theorem withEquiv (f : EquivManager → alpha × EquivManager) : + (TcM.withEquiv (m := .anon) f).PreservesInferOnly := by + unfold TcM.withEquiv + apply bind (modifyGet (fun _ => rfl)) + intro manager + cases hresult : f manager with + | mk value next => + apply bind (modify + (f := fun state => { state with equivManager := next }) + (fun _ => rfl)) + intro _ + exact pure value + +/-- Optional tracing reads state but has no checker-state effect. -/ +theorem stepTrace (tag : String) (payload : Unit → String) : + (TcM.stepTrace (m := .anon) tag payload).PreservesInferOnly := by + unfold TcM.stepTrace + apply bind get + intro state + split <;> exact pure _ + +/-- A statistics update preserves policy whenever its supplied record update +does. -/ +theorem bumpStats (f : TcState .anon → TcState .anon) + (hf : ∀ state, (f state).inferOnly = state.inferOnly) : + (TcM.bumpStats f).PreservesInferOnly := by + unfold TcM.bumpStats + apply bind get + intro state + split + · exact modify hf + · exact pure _ + +/-- Legacy variable lookup either throws, reads, or updates only the intern +table. -/ +theorem lookupVar (idx : UInt64) : + (TcM.lookupVar (m := .anon) idx).PreservesInferOnly := by + unfold TcM.lookupVar + apply bind get + intro state + simp only + split + · exact throw _ + · exact runIntern _ + +/-- Legacy let lookup is read-only apart from interning the lifted value. -/ +theorem lookupLetVal (idx : UInt64) : + (TcM.lookupLetVal (m := .anon) idx).PreservesInferOnly := by + unfold TcM.lookupLetVal + apply bind get + intro state + simp only + split + · exact pure _ + · split + · exact pure _ + · simp only [pure_bind] + apply bind (runIntern _) + intro result + exact pure (some result) + +/-- The let-variable classifier is state-pure. -/ +theorem isLetVar (idx : UInt64) : + (TcM.isLetVar (m := .anon) idx).PreservesInferOnly := by + unfold TcM.isLetVar + apply bind get + intro state + simp only + split <;> exact pure _ + +/-- The eager-reduction marker classifier is state-pure. -/ +theorem isEagerReduce (source : KExpr .anon) : + (TcM.isEagerReduce source).PreservesInferOnly := by + apply ofWF + intro before + apply TcM.WF.mono (TcM.isEagerReduce_wf source before) + · intros; trivial + · intros; trivial + +/-- Suffix-key memoization may update only `ctxAddrCache`, so inference-key +construction preserves the policy bit on every outcome. -/ +theorem ctxAddrForLbr (lbr : UInt64) : + (TcM.ctxAddrForLbr (m := .anon) lbr).PreservesInferOnly := by + intro before + have hrun := TcM.ctxAddrForLbr_wf + (I := fun after : TcState .anon => + after.inferOnly = before.inferOnly) + (fun {prior next : TcState .anon} hmiddle hframe => by + have hsame : next.inferOnly = prior.inferOnly := by + simpa [ContextKeyFrame] using congrArg TcState.inferOnly hframe + exact hsame.trans hmiddle) + lbr before rfl + cases hexec : TcM.ctxAddrForLbr lbr before with + | ok value after => + rw [hexec] at hrun + exact hrun.1 + | error err after => + rw [hexec] at hrun + exact hrun.1 + +/-- WHNF key construction only extends the suffix-key memo table. -/ +theorem whnfKey (source : KExpr .anon) : + (TcM.whnfKey source).PreservesInferOnly := by + unfold TcM.whnfKey + apply bind (ctxAddrForLbr source.lbr) + intro key + exact pure (source.addr, key) + +/-- DefEq context-key construction is the same suffix memo operation. -/ +theorem defEqCtxKey (left right : KExpr .anon) : + (TcM.defEqCtxKey left right).PreservesInferOnly := by + exact ctxAddrForLbr _ + +theorem inferKey (source : KExpr .anon) : + (TcM.inferKey source).PreservesInferOnly := by + unfold TcM.inferKey + apply bind (ctxAddrForLbr source.lbr) + intro _ + exact pure _ + +theorem freshFVarId : + (TcM.freshFVarId (m := .anon)).PreservesInferOnly := by + intro before + by_cases hroom : before.env.nextFVarId.toNat + 1 < UInt64.size + · rw [TcM.freshFVarId] + simp only [if_pos hroom] + · rw [TcM.freshFVarId] + simp only [if_neg hroom] + +/-- Binder opening changes the fvar counter, intern table, and local-context +stack, but never the inference policy. -/ +theorem openBinder + (name : Mode.anon.F Name) (bi : Mode.anon.F Lean.BinderInfo) + (type body : KExpr .anon) : + (TcM.openBinder name bi type body).PreservesInferOnly := by + unfold TcM.openBinder + apply bind freshFVarId + intro fv + apply bind (runIntern _) + intro fvExpr + apply bind (modify + (f := fun state => + { state with lctx := state.lctx.push fv (.cdecl name bi type) }) + fun _ => rfl) + intro _ + apply bind (runIntern (instantiateRev body #[fvExpr])) + intro bodyOpen + exact pure (bodyOpen, fv) + +/-- Let opening has the same policy frame as lambda/forall opening. -/ +theorem openLet + (name : Mode.anon.F Name) (type value body : KExpr .anon) : + (TcM.openLet name type value body).PreservesInferOnly := by + unfold TcM.openLet + apply bind freshFVarId + intro fv + apply bind (runIntern _) + intro fvExpr + apply bind (modify + (f := fun state => + { state with lctx := state.lctx.push fv (.ldecl name type value) }) + fun _ => rfl) + intro _ + apply bind (runIntern (instantiateRev body #[fvExpr])) + intro bodyOpen + exact pure (bodyOpen, fv) + +/-- The production infer-only scope may run an arbitrary callback after +forcing the bit to `true`; its finalizer restores the caller's exact bit on +both outcomes. -/ +theorem withInferOnly (x : TcM .anon alpha) : + (TcM.withInferOnly x).PreservesInferOnly := by + intro before + rw [TcM.withInferOnly_eq] + cases x {before with inferOnly := true} <;> rfl + +/-- Combine an existing semantic Hoare proof with an independent policy +frame. This is the adapter used by K3 callback contexts. -/ +theorem strengthenWF + {I : TcState .anon → Prop} {before : TcState .anon} + {x : TcM .anon alpha} {Q : alpha → TcState .anon → Prop} + {E : TcError .anon → TcState .anon → Prop} + (hsemantic : TcM.WF I before x Q E) + (hpolicy : x.PreservesInferOnly) : + TcM.WF I before x + (fun value after => Q value after ∧ + after.inferOnly = before.inferOnly) + (fun err after => E err after ∧ + after.inferOnly = before.inferOnly) := by + intro hI + have hpost := hsemantic hI + cases hrun : x before with + | ok value after => + rw [hrun] at hpost + exact ⟨hpost.1, hpost.2, hpolicy.ok hrun⟩ + | error err after => + rw [hrun] at hpost + exact ⟨hpost.1, hpost.2, hpolicy.error hrun⟩ + +/-- Specialize `strengthenWF` to a known policy value and put the policy fact +first, matching the callback records used by full inference. -/ +theorem strengthenWFValue + {I : TcState .anon → Prop} {before : TcState .anon} + {x : TcM .anon alpha} {Q : alpha → TcState .anon → Prop} + {E : TcError .anon → TcState .anon → Prop} {policy : Bool} + (hsemantic : TcM.WF I before x Q E) + (hframe : x.PreservesInferOnly) + (hbefore : before.inferOnly = policy) : + TcM.WF I before x + (fun value after => after.inferOnly = policy ∧ Q value after) + (fun err after => after.inferOnly = policy ∧ E err after) := by + exact TcM.WF.mono (strengthenWF hsemantic hframe) + (fun _ _ post => ⟨post.2.trans hbefore, post.1⟩) + (fun _ _ post => ⟨post.2.trans hbefore, post.1⟩) + +end TcM.PreservesInferOnly + +namespace RecM + +/-- Writing either inference-cache partition changes only `env`; the policy +selected at `inferWith` entry remains untouched. -/ +theorem cacheInferResult_preservesInferOnly + (inferOnly : Bool) (key : Address × Address) (ty : KExpr .anon) + (methods : Methods .anon) : + ((cacheInferResult inferOnly key ty).run methods).PreservesInferOnly := by + cases inferOnly <;> intro before <;> rfl + +/-- The cache-miss tail composes uncached inference with the policy-selected +cache write. -/ +private theorem inferMissTail_preservesInferOnly + (methods : Methods .anon) + (huncached : ∀ inferOnly source, + ((inferUncached inferCall inferOnly source).run methods).PreservesInferOnly) + (inferOnly : Bool) (source : KExpr .anon) + (key : Address × Address) : + ((do + let ty ← inferUncached inferCall inferOnly source + cacheInferResult inferOnly key ty + pure ty).run methods).PreservesInferOnly := by + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind (huncached inferOnly source) + intro ty + apply TcM.PreservesInferOnly.bind + (cacheInferResult_preservesInferOnly inferOnly key ty methods) + intro _ + exact TcM.PreservesInferOnly.pure ty + +/-- The production inference cache shell preserves the caller's exact policy +provided its uncached dispatcher does. Both full and infer-only cache hits, +both misses, key memoization, and the selected cache write are covered. -/ +theorem inferWith_preservesInferOnly + (methods : Methods .anon) + (huncached : ∀ inferOnly source, + ((inferUncached inferCall inferOnly source).run methods).PreservesInferOnly) + (source : KExpr .anon) : + ((inferWith inferCall source).run methods).PreservesInferOnly := by + unfold inferWith + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.PreservesInferOnly.bind TcM.PreservesInferOnly.get + intro before + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.inferKey source) + intro key + apply TcM.PreservesInferOnly.bind TcM.PreservesInferOnly.get + intro afterKey + split + · exact TcM.PreservesInferOnly.pure _ + · cases hpolicy : before.inferOnly with + | false => + simpa only [Bool.false_eq_true, if_false, pure_bind] using + inferMissTail_preservesInferOnly methods huncached false source key + | true => + simp only [if_true, pure_bind, ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind TcM.PreservesInferOnly.get + intro afterFullMiss + split + · exact TcM.PreservesInferOnly.pure _ + · exact inferMissTail_preservesInferOnly methods huncached true + source key + +/-- `RecM.infer` is the production cache shell with `inferCall`. -/ +theorem infer_preservesInferOnly + (methods : Methods .anon) + (huncached : ∀ inferOnly source, + ((inferUncached inferCall inferOnly source).run methods).PreservesInferOnly) + (source : KExpr .anon) : + ((infer source).run methods).PreservesInferOnly := by + simpa [infer] using inferWith_preservesInferOnly methods huncached source + +/-- Local-context cleanup changes only `lctx`; the body frame therefore +survives both normal return and exceptional cleanup. -/ +theorem withLctxScope_preservesInferOnly + {methods : Methods .anon} {x : RecM .anon alpha} + (hx : (x.run methods).PreservesInferOnly) : + ((withLctxScope x).run methods).PreservesInferOnly := by + unfold withLctxScope + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind TcM.PreservesInferOnly.get + intro savedState + change (tryFinally (x.run methods) + (modify (fun state : TcState .anon => + { state with lctx := state.lctx.truncate savedState.lctx.size }) : + TcM .anon PUnit)).PreservesInferOnly + apply TcM.PreservesInferOnly.tryFinally hx + exact TcM.PreservesInferOnly.modify fun _ => rfl + +/-- The WHNF fallback used by Pi exposure preserves the policy whenever the +concrete WHNF layer over the same smaller table does. -/ +theorem ensureForallWhnf_preservesInferOnly + {methods : Methods .anon} {input : KExpr .anon} + (hwhnf : ∀ source, + ((RecM.whnf source).run methods).PreservesInferOnly) : + ((ensureForallWhnf input).run methods).PreservesInferOnly := by + simp only [ensureForallWhnf, ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind (hwhnf input) + intro reduced + cases reduced <;> simp only <;> + first + | exact TcM.PreservesInferOnly.pure _ + | exact TcM.PreservesInferOnly.throw _ + +/-- The syntactic Pi fast path is state-pure; every other constructor uses +the framed WHNF fallback above. -/ +theorem ensureForallDirect_preservesInferOnly + {methods : Methods .anon} {input : KExpr .anon} + (hwhnf : ∀ source, + ((RecM.whnf source).run methods).PreservesInferOnly) : + ((ensureForallDirect input).run methods).PreservesInferOnly := by + cases input <;> simp only [ensureForallDirect, pure_bind] + all_goals + first + | exact TcM.PreservesInferOnly.pure _ + | exact ensureForallWhnf_preservesInferOnly hwhnf + +/-- Sort exposure has the same operational policy shape as Pi exposure. -/ +theorem ensureSortWhnf_preservesInferOnly + {methods : Methods .anon} {input : KExpr .anon} + (hwhnf : ∀ source, + ((RecM.whnf source).run methods).PreservesInferOnly) : + ((ensureSortWhnf input).run methods).PreservesInferOnly := by + simp only [ensureSortWhnf, ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind (hwhnf input) + intro reduced + cases reduced <;> simp only <;> + first + | exact TcM.PreservesInferOnly.pure _ + | exact TcM.PreservesInferOnly.throw _ + +/-- The syntactic sort fast path is state-pure; every other constructor uses +the framed WHNF fallback above. -/ +theorem ensureSortDirect_preservesInferOnly + {methods : Methods .anon} {input : KExpr .anon} + (hwhnf : ∀ source, + ((RecM.whnf source).run methods).PreservesInferOnly) : + ((ensureSortDirect input).run methods).PreservesInferOnly := by + cases input <;> simp only [ensureSortDirect, pure_bind] + all_goals + first + | exact TcM.PreservesInferOnly.pure _ + | exact ensureSortWhnf_preservesInferOnly hwhnf + +end RecM + +namespace Methods + +/-- Outcome-sensitive policy frames for all six recursive back-edges. -/ +structure PreservesInferOnly (methods : Methods .anon) : Prop where + whnf : ∀ source, (methods.whnf source).PreservesInferOnly + whnfCore : ∀ source, (methods.whnfCore source).PreservesInferOnly + whnfMode : ∀ source mode, + (methods.whnfMode source mode).PreservesInferOnly + whnfCoreFlags : ∀ source flags, + (methods.whnfCoreFlags source flags).PreservesInferOnly + infer : ∀ source, (methods.infer source).PreservesInferOnly + isDefEq : ∀ left right, + (methods.isDefEq left right).PreservesInferOnly + +/-- One-layer closure obligation for the operational policy frame. -/ +def InferOnlyClosed : Prop := + ∀ methods, methods.PreservesInferOnly → + (Methods.next methods).PreservesInferOnly + +/-- The exhausted table throws without changing state. -/ +theorem methodsOut_preservesInferOnly : + (methodsOut : Methods .anon).PreservesInferOnly := by + constructor <;> intros <;> exact TcM.PreservesInferOnly.throw _ + +/-- A proof for one unfolded layer closes every finite production +approximation selected by `TcM.runRec`. -/ +theorem methodsN_preservesInferOnly + (hclosed : InferOnlyClosed) (n : Nat) : + (methodsN (m := .anon) n).PreservesInferOnly := by + induction n with + | zero => exact methodsOut_preservesInferOnly + | succ n ih => + simpa [Methods.methodsN_succ, Nat.succ_eq_add_one] using + hclosed (methodsN n) ih + +/-- The ordinary K2 DefEq contract plus its independent operational frame is +exactly the strong DefEq callback required by K3 full inference. -/ +theorem PreservesInferOnly.isDefEq_full_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {s : TcState .anon} {left right : KExpr .anon} + {leftV rightV : Lean4Lean.VExpr} + (hsemantic : Methods.WFAt layer semantics trProj world support uvars + methods) + (hframe : methods.PreservesInferOnly) + (hbefore : s.inferOnly = false) + (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) : + TcM.WF + (WhnfStateInv layer semantics trProj world support uvars Delta) s + (methods.isDefEq left right) + (fun answer after => + after.inferOnly = false ∧ + (answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV)) + (fun _ after => after.inferOnly = false) := by + apply TcM.WF.mono + (TcM.PreservesInferOnly.strengthenWFValue + (hsemantic.isDefEq hleftSupport hrightSupport hleft hright) + (hframe.isDefEq left right) hbefore) + · intro _ _ post + exact post + · intro _ _ post + exact post.1 + +end Methods + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/MemberEvidence.lean b/Ix/Tc/Verify/Check/MemberEvidence.lean new file mode 100644 index 000000000..b3e45b2ab --- /dev/null +++ b/Ix/Tc/Verify/Check/MemberEvidence.lean @@ -0,0 +1,499 @@ +import Ix.Tc.Verify.Check.BoundedPipelines +import Ix.Tc.Verify.Check.SafetyFrame + +/-! +# Semantic evidence from standalone member checking + +This module follows the exact production `checkConstMember` control flow for +the standalone declaration fragment. Validation is framed through lazy +ingress, full inference constructs a typed translation from raw ingress, and +the definition branch consumes the actual public `RecM.isDefEq` result. + +The theorem and safety guards are not assigned semantic meaning here. Their +successful execution is nevertheless part of the trace from which the +typing evidence is extracted. +-/ + +namespace Ix.Tc + +namespace RecM + +/-- Expose one concrete `TcM` bind while decomposing a successful production +trace. -/ +private theorem runTcBind {a b : Type} + (x : TcM .anon a) (k : a → TcM .anon b) + (state : TcState .anon) : + (x >>= k) state = match x state with + | .ok value after => k value after + | .error err after => .error err after := by + show EStateM.bind x k state = _ + unfold EStateM.bind + cases x state <;> rfl + +/-- Reassemble the type pipeline from its two concrete successful calls. -/ +private theorem runInferEnsureSort + (source : KExpr .anon) (methods : Methods .anon) + {before afterInfer after : TcState .anon} + {inferred : KExpr .anon} {sort : KUniv .anon} + (hinfer : (infer source).run methods before = .ok inferred afterInfer) + (hsort : (ensureSortDirect inferred).run methods afterInfer = + .ok sort after) : + ((do + let inferred ← infer source + let _ ← ensureSortDirect inferred).run methods) before = + .ok () after := by + simp only [ReaderT.run_bind] + change EStateM.bind ((infer source).run methods) _ before = _ + unfold EStateM.bind + rw [hinfer] + change EStateM.map _ ((ensureSortDirect inferred).run methods) afterInfer = _ + unfold EStateM.map + rw [hsort] + +/-- Reassemble the value pipeline when the concrete DefEq call returned +`true`. -/ +private theorem runInferDefEqTrue + (value declaredType : KExpr .anon) (methods : Methods .anon) + {before afterInfer after : TcState .anon} + {inferredType : KExpr .anon} + (hinfer : (infer value).run methods before = .ok inferredType afterInfer) + (hdefeq : (isDefEq inferredType declaredType).run methods afterInfer = + .ok true after) : + ((do + let inferredType ← infer value + if !(← isDefEq inferredType declaredType) then + throw TcError.declTypeMismatch).run methods) before = .ok () after := by + simp only [ReaderT.run_bind] + change EStateM.bind ((infer value).run methods) _ before = _ + unfold EStateM.bind + rw [hinfer] + change EStateM.bind ((isDefEq inferredType declaredType).run methods) _ + afterInfer = _ + unfold EStateM.bind + rw [hdefeq] + rfl + +/-- A successful production axiom check supplies the exact type evidence +used by standalone acceptance. The validator may lazy-load declarations; +its semantic frame is automatically strengthened with the full-inference +policy bit. -/ +theorem checkConstMember_axiom_sound + {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {model : KernelSuffixModel trProj world} + {calls : Methods.CallDomain} {methods : Methods .anon} + (context : StandalonePipelineResources + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars calls methods) + (hmethods : Methods.WFAtOn .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars calls (Methods.next methods)) + (hmethodPolicy : (Methods.next methods).PreservesInferOnly) + {id : KId .anon} {name : Mode.anon.F Name} + {levelParams : Mode.anon.F (Array Name)} {isUnsafe : Bool} + {levels : UInt64} {type : KExpr .anon} + {typeV : Lean4Lean.VExpr} + (hresources : StandaloneValidationResources support + (.axio name levelParams isUnsafe levels type)) + (hsourceCall : context.typeSources type) + (hsource : PreTrKExprS world.venv levels.toNat world.nameOf trProj + [] type typeV) + (huvars : model.keys.uvars = levels.toNat) + {state after : TcState .anon} + (hpolicy : state.inferOnly = false) + (hI : WhnfStateInv .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars [] state) + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv .noAccel (kernelCacheSemantics model.keys trProj) + trProj world support model.keys.uvars [])) + (hrun : + (checkConstMember id (.axio name levelParams isUnsafe levels type)).run + methods state = .ok () after) : + WhnfStateInv .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars [] after ∧ + after.inferOnly = false ∧ + TrKExprS world.venv levels.toNat world.nameOf trProj [] type typeV ∧ + TypeCheckEvidence trProj world support levels.toNat [] typeV := by + have hframe := validateConstWellScoped_frame hresources methods + (hfault.withInferOnly false) state ⟨hI, hpolicy⟩ + unfold checkConstMember at hrun + simp only [Mode.F.hasDups, Bool.false_eq_true, if_false, + ReaderT.run_bind, pure_bind] at hrun + cases hvalidation : + (validateConstWellScoped + (.axio name levelParams isUnsafe levels type)).run methods state with + | error err failed => + rw [runTcBind, hvalidation] at hrun + contradiction + | ok validationValue afterValidation => + rw [runTcBind, hvalidation] at hrun + have hIValidation : WhnfStateInv .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars [] afterValidation := by + rw [hvalidation] at hframe + exact hframe.1.1 + have hpolicyValidation : afterValidation.inferOnly = false := by + rw [hvalidation] at hframe + exact hframe.1.2 + have hsource' : PreTrKExprS world.venv model.keys.uvars world.nameOf + trProj [] type typeV := by + simpa [huvars] using hsource + have hpipeline := checkTypePipeline_bounded_sound context hmethods + hmethodPolicy hsourceCall hsource' hpolicyValidation hIValidation hrun + simpa [huvars] using hpipeline + +/-- A successful production definition-family check supplies both the type +and value evidence used by standalone acceptance. Success rules out the +theorem guard, a false DefEq answer, and failures in either safety traversal; +the semantic result itself comes only from inference, sort exposure, and the +true DefEq result. -/ +theorem checkConstMember_defn_sound + {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {model : KernelSuffixModel trProj world} + {calls : Methods.CallDomain} {methods : Methods .anon} + (context : StandalonePipelineResources + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars calls methods) + (hmethods : Methods.WFAtOn .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars calls (Methods.next methods)) + (hmethodPolicy : (Methods.next methods).PreservesInferOnly) + {id : KId .anon} {name : Mode.anon.F Name} + {levelParams : Mode.anon.F (Array Name)} {kind : Ix.DefKind} + {safety : Ix.DefinitionSafety} {hints : Lean.ReducibilityHints} + {levels : UInt64} {type value : KExpr .anon} + {leanAll : Mode.anon.F (Array (KId .anon))} {block : KId .anon} + {typeV valueV : Lean4Lean.VExpr} + (hresources : StandaloneValidationResources support + (.defn name levelParams kind safety hints levels type value leanAll + block)) + (htypeCall : context.typeSources type) + (hvalueCall : context.valueSources value type) + (htype : PreTrKExprS world.venv levels.toNat world.nameOf trProj + [] type typeV) + (hvalue : PreTrKExprS world.venv levels.toNat world.nameOf trProj + [] value valueV) + (huvars : model.keys.uvars = levels.toNat) + {state after : TcState .anon} + (hpolicy : state.inferOnly = false) + (hI : WhnfStateInv .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars [] state) + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv .noAccel (kernelCacheSemantics model.keys trProj) + trProj world support model.keys.uvars [])) + (hrun : + (checkConstMember id + (.defn name levelParams kind safety hints levels type value leanAll + block)).run methods state = .ok () after) : + WhnfStateInv .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars [] after ∧ + TypeCheckEvidence trProj world support levels.toNat [] typeV ∧ + ValueCheckEvidence world levels.toNat [] valueV typeV := by + have hframe := validateConstWellScoped_frame hresources methods + (hfault.withInferOnly false) state ⟨hI, hpolicy⟩ + unfold checkConstMember at hrun + simp only [Mode.F.hasDups, Bool.false_eq_true, if_false, + ReaderT.run_bind, pure_bind] at hrun + cases hvalidation : + (validateConstWellScoped + (.defn name levelParams kind safety hints levels type value leanAll + block)).run methods state with + | error err failed => + simp only [runTcBind, hvalidation] at hrun + contradiction + | ok validationValue afterValidation => + simp only [runTcBind, hvalidation] at hrun + have hIValidation : WhnfStateInv .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars [] afterValidation := by + rw [hvalidation] at hframe + exact hframe.1.1 + have hpolicyValidation : afterValidation.inferOnly = false := by + rw [hvalidation] at hframe + exact hframe.1.2 + have htype' : PreTrKExprS world.venv model.keys.uvars world.nameOf + trProj [] type typeV := by + simpa [huvars] using htype + have hvalue' : PreTrKExprS world.venv model.keys.uvars world.nameOf + trProj [] value valueV := by + simpa [huvars] using hvalue + cases hinferType : (infer type).run methods afterValidation with + | error err failed => + simp only [hinferType] at hrun + contradiction + | ok inferred afterInferType => + simp only [hinferType] at hrun + cases hsort : (ensureSortDirect inferred).run methods afterInferType with + | error err failed => + simp only [hsort] at hrun + contradiction + | ok level afterType => + simp only [hsort] at hrun + have htypePipeline : + ((do + let inferred ← infer type + let _ ← ensureSortDirect inferred).run methods) + afterValidation = .ok () afterType := + runInferEnsureSort type methods hinferType hsort + have htypePost := checkTypePipeline_bounded_sound context + hmethods hmethodPolicy htypeCall htype' hpolicyValidation + hIValidation htypePipeline + have hIType := htypePost.1 + have hpolicyType := htypePost.2.1 + have htypeTr := htypePost.2.2.1 + have htypeEvidence := htypePost.2.2.2 + by_cases htheorem : kind == .thm && !univEq level .mkZero + · simp only [htheorem, if_true] at hrun + contradiction + · simp only [htheorem, Bool.false_eq_true, if_false, + ReaderT.run_bind] at hrun + cases hinferValue : (infer value).run methods afterType with + | error err failed => + simp only [runTcBind, hinferValue] at hrun + contradiction + | ok inferredType afterInferValue => + simp only [runTcBind, hinferValue] at hrun + cases hanswer : + (isDefEq inferredType type).run methods afterInferValue with + | error err failed => + simp only [hanswer] at hrun + contradiction + | ok answer afterDefEq => + simp only [hanswer] at hrun + cases answer with + | false => + simp only [Bool.not_false, if_true] at hrun + contradiction + | true => + have hvaluePipeline : + ((do + let inferredType ← infer value + if !(← isDefEq inferredType type) then + throw TcError.declTypeMismatch).run methods) + afterType = .ok () afterDefEq := + runInferDefEqTrue value type methods hinferValue + hanswer + have hvaluePost := + checkValuePipeline_bounded_sound context hmethods + hvalueCall hvalue' htypeTr hpolicyType hIType + hvaluePipeline + have hIDefEq := hvaluePost.1 + have hvalueEvidence := hvaluePost.2 + by_cases hsafety : safety != .unsaf + · simp only [Bool.not_true, Bool.false_eq_true, + if_false] at hrun + simp only [hsafety, if_true, + ReaderT.run_bind] at hrun + cases htypeSafety : + (checkNoUnsafeRefs type safety).run methods + afterDefEq with + | error err failed => + rw [runTcBind, htypeSafety] at hrun + contradiction + | ok typeSafetyValue afterTypeSafety => + rw [runTcBind, htypeSafety] at hrun + have htypePost := + checkNoUnsafeRefs_frame type safety methods + (WhnfStateInv .noAccel + (kernelCacheSemantics model.keys trProj) + trProj world support model.keys.uvars []) + hfault afterDefEq hIDefEq + rw [htypeSafety] at htypePost + cases hvalueSafety : + (checkNoUnsafeRefs value safety).run + methods afterTypeSafety with + | error err failed => + simp only [hvalueSafety] at hrun + contradiction + | ok valueSafetyValue afterValueSafety => + simp only [hvalueSafety] at hrun + cases hrun + have hvalueSafetyPost := + checkNoUnsafeRefs_frame value safety + methods + (WhnfStateInv .noAccel + (kernelCacheSemantics model.keys + trProj) trProj world support + model.keys.uvars []) + hfault afterTypeSafety htypePost.1 + rw [hvalueSafety] at hvalueSafetyPost + exact ⟨hvalueSafetyPost.1, + by simpa [huvars] using htypeEvidence, + by simpa [huvars] using hvalueEvidence⟩ + · simp only [Bool.not_true, Bool.false_eq_true, + if_false] at hrun + simp only [hsafety] at hrun + cases hrun + exact ⟨hIDefEq, + by simpa [huvars] using htypeEvidence, + by simpa [huvars] using hvalueEvidence⟩ + +/-- Exact standalone dispatcher: raw ingress selects the declaration shape, +validation resources supply finite support for its roots, and successful +`checkConstMember` execution constructs the corresponding acceptance +evidence without a prior typing premise. -/ +theorem checkConstMember_sound + {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {model : KernelSuffixModel trProj world} + {calls : Methods.CallDomain} {methods : Methods .anon} + (context : StandalonePipelineResources + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars calls methods) + (hmethods : Methods.WFAtOn .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars calls (Methods.next methods)) + (hmethodPolicy : (Methods.next methods).PreservesInferOnly) + {id : KId .anon} {concrete : KConst .anon} + {decl : Lean4Lean.VDecl} + (hingress : PreDeclRel world.venv world.nameOf trProj id concrete decl) + (hcovers : context.Covers concrete) + (hresources : StandaloneValidationResources support concrete) + (huvars : model.keys.uvars = concrete.lvls.toNat) + {state after : TcState .anon} + (hpolicy : state.inferOnly = false) + (hI : WhnfStateInv .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars [] state) + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv .noAccel (kernelCacheSemantics model.keys trProj) + trProj world support model.keys.uvars [])) + (hrun : (checkConstMember id concrete).run methods state = + .ok () after) : + WhnfStateInv .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars [] after ∧ + StandaloneCheckEvidence trProj world support decl := by + cases hingress with + | @«axiom» name levelParams isUnsafe levels type theoryName typeV _ htype => + cases hresources with + | «axiom» hcoverage hsize => + cases hcovers with + | «axiom» htypeCall => + have hresult := checkConstMember_axiom_sound context hmethods + hmethodPolicy (.axiom hcoverage hsize) htypeCall htype huvars + hpolicy hI hfault hrun + exact ⟨hresult.1, .axiom hresult.2.2.2⟩ + | @defn name levelParams kind safety hints levels type value leanAll block + theoryName typeV valueV decl _ htype hvalue hkind => + cases hresources with + | defn htypeCoverage htypeSize hvalueCoverage hvalueSize => + cases hcovers with + | defn htypeCall hvalueCall => + have hevidence := checkConstMember_defn_sound context hmethods + hmethodPolicy + (.defn htypeCoverage htypeSize hvalueCoverage hvalueSize) + htypeCall hvalueCall htype hvalue huvars hpolicy hI hfault hrun + cases hkind with + | defn => + exact ⟨hevidence.1, .defn hevidence.2.1 hevidence.2.2⟩ + | opaq => + exact ⟨hevidence.1, .opaque hevidence.2.1 hevidence.2.2⟩ + | thm => + exact ⟨hevidence.1, .opaque hevidence.2.1 hevidence.2.2⟩ + +/-- Success of a supported standalone member check contains a successful +execution of the exact production validator. This is the bridge that keeps +`PreDeclRel` out of the public checker precondition. -/ +theorem checkConstMember_validation_success + {support : RunSupport} {id : KId .anon} {concrete : KConst .anon} + (hresources : StandaloneValidationResources support concrete) + {methods : Methods .anon} {state after : TcState .anon} + (hrun : (checkConstMember id concrete).run methods state = + .ok () after) : + ∃ afterValidation, + (validateConstWellScoped concrete).run methods state = + .ok () afterValidation := by + cases hresources with + | @«axiom» name levelParams isUnsafe levels type hcoverage hsize => + unfold checkConstMember at hrun + simp only [Mode.F.hasDups, Bool.false_eq_true, if_false, + ReaderT.run_bind, pure_bind] at hrun + cases hvalidation : + (validateConstWellScoped + (.axio name levelParams isUnsafe levels type)).run methods state with + | error err failed => + rw [runTcBind, hvalidation] at hrun + contradiction + | ok validationValue afterValidation => + cases validationValue + exact ⟨afterValidation, rfl⟩ + | @defn name levelParams kind safety hints levels type value leanAll block + htypeCoverage htypeSize hvalueCoverage hvalueSize => + unfold checkConstMember at hrun + simp only [Mode.F.hasDups, Bool.false_eq_true, if_false, + ReaderT.run_bind, pure_bind] at hrun + cases hvalidation : + (validateConstWellScoped + (.defn name levelParams kind safety hints levels type value leanAll + block)).run methods state with + | error err failed => + rw [runTcBind, hvalidation] at hrun + contradiction + | ok validationValue afterValidation => + cases validationValue + exact ⟨afterValidation, rfl⟩ + +/-- End-to-end member-level K3 result from an untyped pending declaration. +Successful production validation constructs the pretranslation; successful +checking constructs semantic evidence; the pure acceptance layer then +promotes exactly the pending target in the ghost world. -/ +theorem checkConstMember_pending_sound + {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {model : KernelSuffixModel trProj world} + {calls : Methods.CallDomain} {methods : Methods .anon} + (context : StandalonePipelineResources + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars calls methods) + (hmethods : Methods.WFAtOn .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars calls (Methods.next methods)) + (hmethodPolicy : (Methods.next methods).PreservesInferOnly) + {id : KId .anon} {concrete : KConst .anon} + {decl : Lean4Lean.VDecl} + (hprojection : trProj.SubstCompatible) + (hliterals : ∀ literal, world.venv.ContainsLits literal) + (hpending : PendingDecl trProj world id decl) + (hcatalog : world.catalog id = some concrete) + (hresources : StandaloneValidationResources support concrete) + (hcovers : context.Covers concrete) + (hcollision : support.CollisionFree) + (huvars : model.keys.uvars = concrete.lvls.toNat) + {state after : TcState .anon} + (hpolicy : state.inferOnly = false) + (hI : WhnfStateInv .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars [] state) + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv .noAccel (kernelCacheSemantics model.keys trProj) + trProj world support model.keys.uvars [])) + (hrun : (checkConstMember id concrete).run methods state = + .ok () after) : + StandaloneCheckResult trProj world support id concrete decl ∧ + ∃ world', + Promotes world (fun target => target = id) world' ∧ + WhnfStateInv .noAccel + (kernelCacheSemantics model.keys trProj) trProj world' support + model.keys.uvars [] after ∧ + TrustedDecl trProj world' id decl := by + obtain ⟨afterValidation, hvalidation⟩ := + checkConstMember_validation_success hresources hrun + have hingress := hpending.toPre_of_validation hprojection hliterals hcatalog + hresources hcollision hvalidation + have hevidence := checkConstMember_sound context hmethods hmethodPolicy + hingress hcovers hresources huvars hpolicy hI hfault hrun + obtain ⟨world', hpromotes, hcore, htrusted⟩ := + PendingDecl.promoteOfAccepted hevidence.1.1.core hpending + hevidence.2.accepted + exact ⟨⟨hingress, hevidence.2⟩, world', hpromotes, + hevidence.1.rebaseWorld hpromotes.1 hcore, htrusted⟩ + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/NatAcceptance.lean b/Ix/Tc/Verify/Check/NatAcceptance.lean new file mode 100644 index 000000000..e91c5deb8 --- /dev/null +++ b/Ix/Tc/Verify/Check/NatAcceptance.lean @@ -0,0 +1,587 @@ +import Ix.Tc.Verify.NatFixture +import Ix.Tc.Verify.Check.PublicStandalone + +/-! +# Concrete standalone-check acceptance over the ambient Nat world + +This fixture connects the exact production `TcM.checkConst` execution to the +semantic pending-declaration boundary. A valid axiom succeeds and promotes +the ghost world; an intrinsically malformed axiom is then rejected with exact +public rollback. Both verdicts use the same concrete catalog entries and +checker states as their semantic witnesses. + +The valid path deliberately preloads one semantically justified inference +cache entry. This makes the production execution reducible in Lean without +evaluating the Blake3 FFI and keeps the witness about checker control flow, +cache use, reset, validation, acceptance, and rollback rather than about a +mock implementation. +-/ + +namespace Ix.Tc.AmbientNat + +def acceptanceEnv : KEnv .anon := + { loadedEnv with inferCache := + loadedEnv.inferCache.insert (natRef.addr, emptyCtxAddr) natType } + +def initialState : TcState .anon := + { state Primitives.ofAnonAddrs with + env := acceptanceEnv + fuelBudget := 0 + recFuel := 0 } + +def resetState : TcState .anon := + { initialState with + ctx := #[] + letVals := #[] + numLetBindings := 0 + ctxId := emptyCtxAddr + ctxIdStack := #[] + equivManager := {} + inferOnly := false + inNativeReduce := false + cheapRecursionDepth := 0 + eagerReduce := false + defEqDepth := 0 + defEqPeak := 0 + dispatchDepth := 0 + recFuel := initialState.fuelBudget + ctxAddrCache := {} + lctx := {} } + +/-- Finite syntax used by the concrete public-check lifecycle. It contains +the checked Nat reference, the cached inferred sort, and both universe +subterms needed to interpret that sort. -/ +def acceptanceSupport : RunSupport where + expr := fun source => source = natRef ∨ source = natType + exprFinite := + FiniteSupport.union (FiniteSupport.singleton natRef) + (FiniteSupport.singleton natType) + univ := fun level => level = zeroLevel ∨ level = oneLevel + univFinite := + FiniteSupport.union (FiniteSupport.singleton zeroLevel) + (FiniteSupport.singleton oneLevel) + +/-- Cache semantics used only to state the six-field contract for the exact +finite table selected by this fixture. -/ +def acceptanceKeys : WhnfContextKeys := WhnfContextKeys.closed 0 + +def acceptanceSemantics : CacheSemantics := + kernelCacheSemantics acceptanceKeys RawProjRel.none + +theorem selectedMethods : + methodsN initialState.recFuel.toNat = (methodsOut : Methods .anon) := by + rfl + +theorem selectedMethods_wf : + Methods.WFAt .noAccel acceptanceSemantics RawProjRel.none worldNat + acceptanceSupport 0 (methodsN initialState.recFuel.toNat) := by + rw [selectedMethods] + exact Methods.methodsOut_wfAt .noAccel acceptanceSemantics RawProjRel.none + worldNat acceptanceSupport 0 + +theorem acceptanceSupport_collisionFree : acceptanceSupport.CollisionFree := by + constructor + · intro left hleft right hright haddr + rcases hleft with rfl | rfl <;> rcases hright with rfl | rfl + · rfl + · exact False.elim (zeroAddress_ne_natAddress (by + simpa [natRef, natType, info] using haddr)) + · exact False.elim (zeroAddress_ne_natAddress (by + simpa [natRef, natType, info] using haddr.symm)) + · rfl + · intro left hleft right hright haddr + rcases hleft with rfl | rfl <;> rcases hright with rfl | rfl + · rfl + · exact False.elim (zeroAddress_ne_natAddress (by + simpa [zeroLevel, oneLevel] using haddr.symm)) + · exact False.elim (zeroAddress_ne_natAddress (by + simpa [zeroLevel, oneLevel] using haddr)) + · rfl + +theorem initial_reset : TcM.reset initialState = .ok () resetState := by + rfl + +theorem initialState_wf : + TcStateWF RawProjRel.none initialState worldNat := by + refine ⟨trustedCatalogRelNat, ?_, ?_⟩ + · intro id concrete hloaded + apply loadedAgrees + simpa [KEnv.get?, initialState, acceptanceEnv] using hloaded + · exact InternTable.WF.empty + +theorem resetState_wf : + TcStateWF RawProjRel.none resetState worldGood := by + refine ⟨trustedCatalogRelGood, ?_, ?_⟩ + · intro id concrete hloaded + apply loadedAgrees + simpa [KEnv.get?, resetState, initialState, acceptanceEnv] using hloaded + · exact InternTable.WF.empty + +theorem goodPromotion : + Promotes worldNat (fun target => target = goodId) worldGood := by + refine ⟨nat_le_good, ?_⟩ + intro target htarget + subst target + exact good_trusted + +theorem loadedEnv_good : loadedEnv.get? goodId = some goodConcrete := by + simp only [loadedEnv, KEnv.get?, KEnv.insert, + Std.HashMap.getElem?_insert] + split + · next h => exact False.elim (badId_ne_goodId (eq_of_beq h)) + · rfl + +theorem reset_loaded_good : + resetState.env.get? goodId = some goodConcrete := by + simpa [resetState, initialState, acceptanceEnv] using loadedEnv_good + +theorem reset_loaded_nat : + resetState.env.get? natId = some natConcrete := by + change loadedEnv.get? natId = some natConcrete + exact loadedEnv_nat + +theorem reset_try_get_good : + TcM.tryGetConst goodId resetState = + .ok (some goodConcrete) resetState := by + unfold TcM.tryGetConst + change EStateM.bind (get : TcM .anon (TcState .anon)) _ resetState = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) resetState = + .ok resetState resetState from rfl] + simp only + rw [reset_loaded_good] + rfl + +theorem reset_get_good : + TcM.getConst goodId resetState = .ok goodConcrete resetState := by + unfold TcM.getConst + change EStateM.bind (TcM.tryGetConst goodId) _ resetState = _ + unfold EStateM.bind + rw [reset_try_get_good] + rfl + +theorem reset_try_get_nat : + TcM.tryGetConst natId resetState = + .ok (some natConcrete) resetState := by + unfold TcM.tryGetConst + change EStateM.bind (get : TcM .anon (TcState .anon)) _ resetState = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) resetState = + .ok resetState resetState from rfl] + simp only + rw [reset_loaded_nat] + rfl + +theorem reset_get_nat : + TcM.getConst natId resetState = .ok natConcrete resetState := by + unfold TcM.getConst + change EStateM.bind (TcM.tryGetConst natId) _ resetState = _ + unfold EStateM.bind + rw [reset_try_get_nat] + rfl + +theorem reset_infer_key : + TcM.inferKey natRef resetState = + .ok (natRef.addr, emptyCtxAddr) resetState := by + simpa [TcM.inferKey_eq_whnfKey] using + (TcM.whnfKey_closed (s := resetState) (source := natRef) (by rfl)) + +theorem reset_infer_hit : + resetState.env.inferCache[(natRef.addr, emptyCtxAddr)]? = + some natType := by + simp [resetState, initialState, acceptanceEnv] + +theorem reset_infer : + (RecM.infer natRef).run methodsOut resetState = + .ok natType resetState := by + exact RecM.inferWith_fullHit reset_infer_key reset_infer_hit + +theorem oneLevel_wf : oneLevel.toVLevel.WF 0 := by + change True + trivial + +theorem natType_translation : + TrKExpr worldNat.venv 0 worldNat.nameOf RawProjRel.none [] natType + (.sort oneLevel.toVLevel) := by + refine ⟨.sort oneLevel.toVLevel, ?_, ?_⟩ + · simpa [natType] using + (TrKExprS.sort (env := worldNat.venv) (nameOf := worldNat.nameOf) + (trProj := RawProjRel.none) (Δ := []) oneLevel_wf) + · exact Lean4Lean.VEnv.IsDefEqU.refl + ⟨_, Lean4Lean.VEnv.HasType.sort oneLevel_wf⟩ + +theorem natReference_type : + worldNat.venv.HasType 0 [] (.const natName []) + (.sort oneLevel.toVLevel) := by + simpa [worldNat, natConstant, oneLevel, zeroLevel] using + (Lean4Lean.VEnv.HasType.const (env := natEnv) (U := 0) (Γ := []) + (ci := natConstant) (ls := []) natEnv_nat (by simp) rfl) + +theorem oneLevel_view : + SortView worldNat acceptanceSupport 0 [] (.sort oneLevel.toVLevel) oneLevel := by + refine ⟨?_, ?_, oneLevel_wf, ?_⟩ + · simp [oneLevel, zeroLevel, KUniv.size, UInt64.size] + · intro level hlevel + cases hlevel with + | refl => exact Or.inr rfl + | succ hchild => + cases hchild + exact Or.inl rfl + · exact Lean4Lean.VEnv.IsDefEqU.refl + ⟨_, Lean4Lean.VEnv.HasType.sort oneLevel_wf⟩ + +theorem goodTypeEvidence : + TypeCheckEvidence RawProjRel.none worldNat acceptanceSupport 0 [] + goodConstant.type := by + refine ⟨natType, .sort oneLevel.toVLevel, natType_translation, ?_, + oneLevel, oneLevel_view⟩ + simpa [goodConstant] using natReference_type + +theorem goodCheckEvidence : + StandaloneCheckEvidence RawProjRel.none worldNat acceptanceSupport goodDecl := by + exact .axiom goodTypeEvidence + +theorem goodIngress : + PreDeclRel worldNat.venv worldNat.nameOf RawProjRel.none goodId + goodConcrete goodDecl := by + unfold goodConcrete goodDecl goodConstant + apply PreDeclRel.axiom + · exact nameOf_good + · exact PreTrKExprS.const nameOf_nat natEnv_nat (by simp) rfl + +theorem goodCheckResult : + StandaloneCheckResult RawProjRel.none worldNat acceptanceSupport goodId + goodConcrete goodDecl := + ⟨goodIngress, goodCheckEvidence⟩ + +theorem reset_validation : + (RecM.validateConstWellScoped goodConcrete).run methodsOut resetState = + .ok () resetState := by + unfold goodConcrete RecM.validateConstWellScoped + rw [ReaderT.run_bind] + change EStateM.bind + ((RecM.validateExprWellScoped natRef 0 0).run methodsOut) _ + resetState = _ + have hvalidate : + (RecM.validateExprWellScoped natRef 0 0).run methodsOut resetState = + .ok () resetState := by + unfold RecM.validateExprWellScoped + rw [RecM.validateExprWellScoped.go.eq_def] + simp only [Std.HashSet.contains_empty, Bool.false_eq_true, if_false, + natRef] + rw [ReaderT.run_bind] + change EStateM.bind (TcM.getConst natId) _ resetState = _ + unfold EStateM.bind + rw [reset_get_nat] + simp [natConcrete] + change (pure () : RecM .anon Unit).run methodsOut resetState = _ + rfl + unfold EStateM.bind + rw [hvalidate] + rfl + +theorem natRef_validationCoverage : + natRef.ValidationCoverage acceptanceSupport := by + constructor + · intro candidate hcandidate + cases hcandidate + exact Or.inl rfl + · intro level hlevel + unfold natRef at hlevel + cases hlevel with + | const hmem _ => simp at hmem + +theorem goodValidationResources : + StandaloneValidationResources acceptanceSupport goodConcrete := by + exact .axiom natRef_validationCoverage (by + change 1 < UInt64.size + decide) + +theorem goodScope : StandaloneScope goodConcrete := + RecM.validateConstWellScoped_sound goodValidationResources + acceptanceSupport_collisionFree reset_validation + +theorem reset_member : + (RecM.checkConstMember goodId goodConcrete).run methodsOut resetState = + .ok () resetState := by + unfold RecM.checkConstMember + simp only [goodConcrete, Mode.F.hasDups, Bool.false_eq_true, if_false, + ReaderT.run_bind] + change EStateM.bind + ((RecM.validateConstWellScoped goodConcrete).run methodsOut) _ + resetState = _ + unfold EStateM.bind + rw [reset_validation] + change EStateM.bind ((RecM.infer natRef).run methodsOut) _ + resetState = _ + unfold EStateM.bind + rw [reset_infer] + simp [RecM.ensureSortDirect, natType] + +theorem initial_fresh_member : + (RecM.checkConstMemberFresh goodId).run methodsOut initialState = + .ok () resetState := by + unfold RecM.checkConstMemberFresh + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind TcM.reset _ initialState = _ + unfold EStateM.bind + rw [initial_reset] + change EStateM.bind (TcM.getConst goodId) _ resetState = _ + unfold EStateM.bind + rw [reset_get_good] + exact reset_member + +theorem initial_loaded_good : + initialState.env.get? goodId = some goodConcrete := by + simpa [initialState, acceptanceEnv] using loadedEnv_good + +theorem initial_try_get_good : + TcM.tryGetConst goodId initialState = .ok (some goodConcrete) initialState := by + unfold TcM.tryGetConst + change EStateM.bind (get : TcM .anon (TcState .anon)) _ initialState = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) initialState = + .ok initialState initialState from rfl] + simp only + rw [initial_loaded_good] + rfl + +theorem initial_get_good : + TcM.getConst goodId initialState = .ok goodConcrete initialState := by + unfold TcM.getConst + change EStateM.bind (TcM.tryGetConst goodId) _ initialState = _ + unfold EStateM.bind + rw [initial_try_get_good] + rfl + +theorem initial_route_good : + (RecM.coordinatedBlockFor goodConcrete).run methodsOut initialState = + .ok none initialState := by + rfl + +theorem initial_good_body : + (RecM.checkConst goodId).run methodsOut initialState = + .ok () resetState := by + unfold RecM.checkConst + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.getConst goodId) _ initialState = _ + unfold EStateM.bind + rw [initial_get_good] + change EStateM.bind + ((RecM.coordinatedBlockFor goodConcrete).run methodsOut) _ initialState = _ + unfold EStateM.bind + rw [initial_route_good] + exact initial_fresh_member + +theorem initial_good_public : + TcM.checkConst goodId initialState = .ok () resetState := by + apply TcM.isolateCheckErrors_ok + simpa [TcM.runRec, initialState] using initial_good_body + +theorem loadedEnv_bad : + loadedEnv.get? IllTypedPending.targetId = + some IllTypedPending.concrete := by + simp [loadedEnv, KEnv.get?, KEnv.insert] + +theorem reset_loaded_bad : + resetState.env.get? IllTypedPending.targetId = + some IllTypedPending.concrete := by + change loadedEnv.get? IllTypedPending.targetId = + some IllTypedPending.concrete + exact loadedEnv_bad + +theorem reset_try_get_bad : + TcM.tryGetConst IllTypedPending.targetId resetState = + .ok (some IllTypedPending.concrete) resetState := by + unfold TcM.tryGetConst + change EStateM.bind (get : TcM .anon (TcState .anon)) _ resetState = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) resetState = + .ok resetState resetState from rfl] + simp only + rw [reset_loaded_bad] + rfl + +theorem reset_get_bad : + TcM.getConst IllTypedPending.targetId resetState = + .ok IllTypedPending.concrete resetState := by + unfold TcM.getConst + change EStateM.bind (TcM.tryGetConst IllTypedPending.targetId) _ + resetState = _ + unfold EStateM.bind + rw [reset_try_get_bad] + rfl + +theorem reset_bad_validation : + (RecM.validateConstWellScoped IllTypedPending.concrete).run methodsOut + resetState = + .error (.univParamOutOfRange 0 0) resetState := by + unfold IllTypedPending.concrete RecM.validateConstWellScoped + rw [ReaderT.run_bind] + change EStateM.bind + ((RecM.validateExprWellScoped IllTypedPending.badType 0 0).run methodsOut) + _ resetState = _ + have hvalidate : + (RecM.validateExprWellScoped IllTypedPending.badType 0 0).run + methodsOut resetState = + .error (.univParamOutOfRange 0 0) resetState := by + unfold RecM.validateExprWellScoped + rw [RecM.validateExprWellScoped.go.eq_def] + simp only [Std.HashSet.contains_empty, Bool.false_eq_true, if_false, + IllTypedPending.badType] + rw [ReaderT.run_bind] + change EStateM.bind + ((RecM.validateUnivParamsSeen IllTypedPending.badLevel 0 ∅).run + methodsOut) _ resetState = _ + have huniv : + (RecM.validateUnivParamsSeen IllTypedPending.badLevel 0 ∅).run + methodsOut resetState = + .error (.univParamOutOfRange 0 0) resetState := by + unfold RecM.validateUnivParamsSeen + rw [RecM.validateUnivParamsSeen.go.eq_def] + simp [IllTypedPending.badLevel] + rfl + unfold EStateM.bind + rw [huniv] + unfold EStateM.bind + rw [hvalidate] + +theorem reset_bad_member : + (RecM.checkConstMember IllTypedPending.targetId + IllTypedPending.concrete).run methodsOut resetState = + .error (.univParamOutOfRange 0 0) resetState := by + unfold RecM.checkConstMember + simp only [IllTypedPending.concrete, Mode.F.hasDups, + Bool.false_eq_true, if_false, ReaderT.run_bind] + change EStateM.bind + ((RecM.validateConstWellScoped IllTypedPending.concrete).run methodsOut) _ + resetState = _ + unfold EStateM.bind + rw [reset_bad_validation] + +theorem reset_reset : TcM.reset resetState = .ok () resetState := by + rfl + +theorem reset_bad_fresh : + (RecM.checkConstMemberFresh IllTypedPending.targetId).run methodsOut + resetState = + .error (.univParamOutOfRange 0 0) resetState := by + unfold RecM.checkConstMemberFresh + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind TcM.reset _ resetState = _ + unfold EStateM.bind + rw [reset_reset] + change EStateM.bind (TcM.getConst IllTypedPending.targetId) _ + resetState = _ + unfold EStateM.bind + rw [reset_get_bad] + exact reset_bad_member + +theorem reset_bad_route : + (RecM.coordinatedBlockFor IllTypedPending.concrete).run methodsOut + resetState = .ok none resetState := by + rfl + +theorem reset_bad_body : + (RecM.checkConst IllTypedPending.targetId).run methodsOut resetState = + .error (.univParamOutOfRange 0 0) resetState := by + unfold RecM.checkConst + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.getConst IllTypedPending.targetId) _ + resetState = _ + unfold EStateM.bind + rw [reset_get_bad] + change EStateM.bind + ((RecM.coordinatedBlockFor IllTypedPending.concrete).run methodsOut) _ + resetState = _ + unfold EStateM.bind + rw [reset_bad_route] + exact reset_bad_fresh + +theorem reset_bad_public : + TcM.checkConst IllTypedPending.targetId resetState = + .error (.univParamOutOfRange 0 0) resetState := by + have hbody : TcM.runRec (RecM.checkConst IllTypedPending.targetId) + resetState = + .error (.univParamOutOfRange 0 0) resetState := by + simpa [TcM.runRec, resetState] using reset_bad_body + have hrestore : + resetState.restoreCheckCachesOnError resetState = resetState := by + simp [TcState.restoreCheckCachesOnError, + KEnv.restoreCheckCachesOnError, + KEnv.restoreBlockCheckResultsOnError, + resetState, initialState, acceptanceEnv, loadedEnv, KEnv.insert] + rw [Std.HashMap.fold_eq_foldl_toList] + rw [Std.HashMap.toList_empty] + rfl + simpa [TcM.checkConst, hrestore] using + (TcM.isolateCheckErrors_error hbody) + +theorem goodAccepted : StandaloneAccepted worldNat.venv goodDecl := + goodCheckResult.accepted + +/-- One theorem joins the semantic pending boundary, finite validator and +collision resources, exact production execution, ghost promotion, and an +intrinsically invalid follow-up rejection. The invalid run returns the same +state, so the theorem also exposes the public rollback result. -/ +structure PublicCheckLifecycle : Prop where + supportCollision : acceptanceSupport.CollisionFree + methodSelection : + methodsN initialState.recFuel.toNat = (methodsOut : Methods .anon) + methodContract : + Methods.WFAt .noAccel acceptanceSemantics RawProjRel.none worldNat + acceptanceSupport 0 (methodsN initialState.recFuel.toNat) + validationResources : + StandaloneValidationResources acceptanceSupport goodConcrete + initialWF : TcStateWF RawProjRel.none initialState worldNat + validPending : PendingDecl RawProjRel.none worldNat goodId goodDecl + validValidation : + (RecM.validateConstWellScoped goodConcrete).run methodsOut resetState = + .ok () resetState + semanticCacheEntry : + resetState.env.inferCache[(natRef.addr, emptyCtxAddr)]? = some natType + inferenceExecution : + (RecM.infer natRef).run methodsOut resetState = .ok natType resetState + validResult : StandaloneCheckResult RawProjRel.none worldNat acceptanceSupport + goodId goodConcrete goodDecl + validExecution : TcM.checkConst goodId initialState = .ok () resetState + promotion : Promotes worldNat (fun target => target = goodId) worldGood + promotedWF : TcStateWF RawProjRel.none resetState worldGood + trustedResult : TrustedDecl RawProjRel.none worldGood goodId goodDecl + invalidPending : PendingDecl RawProjRel.none worldGood + IllTypedPending.targetId IllTypedPending.theoryDecl + invalidSemantic : + ¬∃ env', Lean4Lean.VDecl.WF worldGood.venv + IllTypedPending.theoryDecl env' + invalidExecution : + TcM.checkConst IllTypedPending.targetId resetState = + .error (.univParamOutOfRange 0 0) resetState + +theorem publicCheckLifecycle : PublicCheckLifecycle where + supportCollision := acceptanceSupport_collisionFree + methodSelection := selectedMethods + methodContract := selectedMethods_wf + validationResources := goodValidationResources + initialWF := initialState_wf + validPending := goodPending + validValidation := reset_validation + semanticCacheEntry := reset_infer_hit + inferenceExecution := reset_infer + validResult := goodCheckResult + validExecution := initial_good_public + promotion := goodPromotion + promotedWF := resetState_wf + trustedResult := goodTrustedDecl + invalidPending := badPending + invalidSemantic := badDecl_not_wf + invalidExecution := reset_bad_public + +def goodSucceeded : Bool := + match TcM.checkConst goodId initialState with + | .ok () _ => true + | .error _ _ => false + +example : goodSucceeded = true := by + simp [goodSucceeded, initial_good_public] + +end Ix.Tc.AmbientNat diff --git a/Ix/Tc/Verify/Check/PositiveFuelSort.lean b/Ix/Tc/Verify/Check/PositiveFuelSort.lean new file mode 100644 index 000000000..62c8b1b4c --- /dev/null +++ b/Ix/Tc/Verify/Check/PositiveFuelSort.lean @@ -0,0 +1,320 @@ +import Ix.Tc.Verify.Check.BoundedPipelines +import Ix.Tc.Verify.RecursiveMethods.SortInference +import Ix.Tc.Verify.RecursiveMethods.ScopedSortInference +import Ix.Tc.Verify.ScopedSuffix.ClosedContext + +/-! +# Positive-fuel bounded checker witness + +This fixture instantiates the corrected C1A/K3 interfaces at recursion fuel +one. Its method-call domain contains exactly one closed sort inference; its +finite result footprint contains that source and its successor-sort result. +The joint suffix model remains an explicit semantic parameter, but the call +schedule, syntax, reduction of collision freedom to two exact digest +inequalities, strong inference upgrade, and checker pipeline resources are +all concrete. +-/ + +namespace Ix.Tc.PositiveFuelSort + +def sourceUniv : KUniv .anon := KUniv.mkZero +def resultUniv : KUniv .anon := KUniv.mkSucc sourceUniv +def source : KExpr .anon := KExpr.mkSort sourceUniv +def result : KExpr .anon := KExpr.mkSort resultUniv + +/-- The two concrete expressions and their two universe roots are the entire +finite result/collision footprint. -/ +def support : RunSupport where + expr := fun candidate => candidate = source ∨ candidate = result + exprFinite := + FiniteSupport.union (FiniteSupport.singleton source) + (FiniteSupport.singleton result) + univ := fun candidate => candidate = sourceUniv ∨ candidate = resultUniv + univFinite := + FiniteSupport.union (FiniteSupport.singleton sourceUniv) + (FiniteSupport.singleton resultUniv) + +/-- The only cryptographic premise in the concrete fixture: the two exact +expression digests and the two exact universe digests do not collide. It is +kept explicit because Lean's build-time evaluator cannot execute the Blake3 +FFI; production parity can discharge these two byte comparisons separately. -/ +structure AddressSeparation : Prop where + expr : source.addr ≠ result.addr + univ : sourceUniv.addr ≠ resultUniv.addr + +/-- The concrete footprint satisfies both address-collision obligations. +The two cross cases are discharged by the exact `AddressSeparation` premises +for the actual Blake3 smart constructors. -/ +theorem support_collisionFree + (separation : AddressSeparation) : support.CollisionFree := by + constructor + · intro left hleft right hright haddr + rcases hleft with rfl | rfl <;> rcases hright with rfl | rfl + · rfl + · exact False.elim (separation.expr haddr) + · exact False.elim (separation.expr haddr.symm) + · rfl + · intro left hleft right hright haddr + rcases hleft with rfl | rfl <;> rcases hright with rfl | rfl + · rfl + · exact False.elim (separation.univ haddr) + · exact False.elim (separation.univ haddr.symm) + · rfl + +theorem source_supported : support source := Or.inl rfl + +theorem result_supported : support result := Or.inr rfl + +/-- Every expression in this deliberately small result footprint is a +syntactic sort, so `ensureSortDirect` never invokes WHNF. -/ +theorem supported_is_sort {candidate : KExpr .anon} + (hcandidate : support candidate) : + ∃ u info, candidate = .sort u info := by + rcases hcandidate with rfl | rfl + · exact ⟨sourceUniv, source.info, by rfl⟩ + · exact ⟨resultUniv, result.info, by rfl⟩ + +/-- Both possible sort views have the exact finite universe-subterm support +required by the checker pipeline. -/ +theorem sortResources : SortComponentResources support := by + intro u info hsource + rcases hsource with hsource | hresult + · have heq : (.sort u info : KExpr .anon) = source := hsource + change (.sort u info : KExpr .anon) = KExpr.mkSort sourceUniv at heq + cases heq + constructor + · change 1 < UInt64.size + decide + · intro child hchild + cases hchild + exact Or.inl rfl + · have heq : (.sort u info : KExpr .anon) = result := hresult + change (.sort u info : KExpr .anon) = KExpr.mkSort resultUniv at heq + cases heq + constructor + · change 2 < UInt64.size + decide + · intro child hchild + cases hchild with + | refl => exact Or.inr rfl + | succ hchild => + cases hchild + exact Or.inl rfl + +/-- Closed sorts contain no declaration references, so the empty trusted +world supplies the exact run-scoped reference policy. -/ +theorem trustedReferences : + RecM.TrustedReferences VerifyWorld.empty support := by + intro candidate id hcandidate href + obtain ⟨u, info, hsort⟩ := supported_is_sort hcandidate + subst candidate + simp [KExpr.References] at href + +/-- Empty Theory has no literal constants; the literal premise is therefore +vacuous. Projection closure is definitionally empty as well. -/ +def theory (uvars : Nat) : + WhnfTheory RawProjRel.none VerifyWorld.empty uvars where + literalWF := by + intro literal hliteral + cases literal <;> + simp [VerifyWorld.empty, VerifyWorld.ofCatalog, + Lean4Lean.VEnv.ContainsLits, Lean4Lean.VEnv.contains, + Lean4Lean.VEnv.empty] at hliteral + projections := RawProjRel.none_ok VerifyWorld.empty.venv uvars + +/-! ## Concrete run-scoped suffix instance -/ + +/-- K2S's production suffix model for this closed fixture. Unlike the +legacy theorems below, this value contains only the singleton normalized +context input reached by the run. -/ +def scopedModel : ScopedKernelSuffixModel RawProjRel.none VerifyWorld.empty := + ClosedContextDigest.model RawProjRel.none VerifyWorld.empty 0 + +/-- A genuinely positive-fuel production state with empty semantic caches +and no local context. -/ +def scopedInitialState : TcState .anon := + { TcState.ofEnvAnon ({} : KEnv .anon) with + noAccel := true + recFuel := 1 + fuelBudget := 1 } + +theorem scopedInitialState_closed : ClosedContextState scopedInitialState := by + constructor <;> rfl + +theorem scopedInitialState_core : + TcStateWF RawProjRel.none scopedInitialState VerifyWorld.empty := by + refine ⟨TrustedCatalogRel.ofCatalog Catalog.empty, ?_, InternTable.WF.empty⟩ + exact LoadedAgrees.empty Catalog.empty + +theorem scopedInitialState_kernel : + KernelStateWF (kernelCacheSemantics scopedModel.keys RawProjRel.none) + RawProjRel.none VerifyWorld.empty support scopedInitialState := by + apply KernelStateWF.of_no_cache_entries scopedInitialState_core + · constructor + · intro candidate hcandidate + obtain ⟨addr, haddr⟩ := hcandidate + simp [scopedInitialState, TcState.ofEnvAnon] at haddr + · intro candidate hcandidate + obtain ⟨addr, haddr⟩ := hcandidate + simp [scopedInitialState, TcState.ofEnvAnon] at haddr + · rfl + · intro entry hentry + cases hentry <;> + simp [scopedInitialState, TcState.ofEnvAnon] at * + +theorem scopedInitialState_baseInv : + WhnfStateInv .noAccel + (kernelCacheSemantics scopedModel.keys RawProjRel.none) + RawProjRel.none VerifyWorld.empty support scopedModel.keys.uvars [] + scopedInitialState := by + refine ⟨scopedInitialState_kernel, ?_, rfl, + Primitives.ofAnonAddrs_canonical⟩ + apply CtxRecon.empty <;> rfl + +theorem scopedInitialState_inv : + ScopedWhnfStateInv scopedModel .noAccel + (kernelCacheSemantics scopedModel.keys RawProjRel.none) + support [] scopedInitialState := + ⟨scopedInitialState_baseInv, + ClosedContextDigest.model_stateInScope scopedInitialState_closed⟩ + +theorem source_translation : + TrKExprS VerifyWorld.empty.venv scopedModel.keys.uvars + VerifyWorld.empty.nameOf RawProjRel.none [] source (.sort .zero) := by + unfold source sourceUniv + exact .sort (by trivial) + +/-- The public positive-fuel sort theorem consumes the concrete finite model +directly. There is no global `KernelSuffixModel` premise or scoped-to-global +conversion anywhere in this statement. -/ +theorem scopedPublicInference_wf (separation : AddressSeparation) : + TcM.WF + (ScopedWhnfStateInv scopedModel .noAccel + (kernelCacheSemantics scopedModel.keys RawProjRel.none) support []) + scopedInitialState (TcM.infer source) + (fun inferred _ => support inferred ∧ + InferPost RawProjRel.none VerifyWorld.empty scopedModel.keys.uvars [] + (.sort .zero) inferred) := by + simpa [source, result, resultUniv] using + (TcM.infer.sort_scoped_wf_fuel_one + (initial := scopedInitialState) (model := scopedModel) + (u := sourceUniv) (info := source.info) + (Delta := []) (sourceV := .sort .zero) + (by rfl) (support_collisionFree separation) source_supported + result_supported (theory 0) trustedReferences source_translation) + +def scopedInferKey : Address × Address := (source.addr, emptyCtxAddr) + +theorem scopedInitialState_inferKey : + TcM.inferKey source scopedInitialState = + .ok scopedInferKey scopedInitialState := by + simpa [scopedInferKey, TcM.inferKey_eq_whnfKey] using + (TcM.whnfKey_closed (s := scopedInitialState) (source := source) + (by rfl)) + +theorem scopedInitialState_inferMiss : + scopedInitialState.env.inferCache[scopedInferKey]? = none := by + simp [scopedInitialState, scopedInferKey, TcState.ofEnvAnon] + +/-- An exact execution witness for the real public `TcM.infer` entry at +positive fuel. The run takes the production context-key fast path, misses +the empty inference cache, interns the successor sort, writes the validated +cache entry, and finishes in the finite suffix state domain. -/ +theorem scopedPublicInference_execution + (separation : AddressSeparation) : + ∃ after, + TcM.infer source scopedInitialState = .ok result after ∧ + ScopedWhnfStateInv scopedModel .noAccel + (kernelCacheSemantics scopedModel.keys RawProjRel.none) support [] + after ∧ + support result ∧ + InferPost RawProjRel.none VerifyWorld.empty scopedModel.keys.uvars [] + (.sort .zero) result := by + obtain ⟨afterIntern, hintern, _hbaseAfter, _hframe⟩ := + TcM.intern_whnf_eval (support_collisionFree separation) + result_supported scopedInitialState_baseInv + have hbody : + (RecM.inferUncached RecM.inferCall false source).run + (Ix.Tc.methodsN (m := .anon) 1) scopedInitialState = + .ok result afterIntern := by + simpa [source, result, resultUniv] using hintern + have hshell := RecM.inferWith_fullMiss_success + (inferRec := RecM.inferCall) + (methods := Ix.Tc.methodsN (m := .anon) 1) + (source := source) (ty := result) (key := scopedInferKey) + (s := scopedInitialState) (sKey := scopedInitialState) + (sBody := afterIntern) (by rfl) scopedInitialState_inferKey + scopedInitialState_inferMiss hbody + let after : TcState .anon := + { afterIntern with env := { afterIntern.env with + inferCache := afterIntern.env.inferCache.insert scopedInferKey result } } + have hrun : TcM.infer source scopedInitialState = .ok result after := by + simpa [TcM.infer, TcM.runRec, RecM.infer, scopedInitialState, after] + using hshell + have hverified := + (scopedPublicInference_wf separation) scopedInitialState_inv + rw [hrun] at hverified + exact ⟨after, hrun, hverified.1, hverified.2⟩ + +/-- The exact depth-two schedule needed by a public body whose callback table +has recursion fuel one. -/ +theorem scheduleAtFuelOne + (separation : AddressSeparation) + (model : KernelSuffixModel RawProjRel.none VerifyWorld.empty) : + Methods.CallScheduleAt .noAccel + (kernelCacheSemantics model.keys RawProjRel.none) + RawProjRel.none VerifyWorld.empty support model.keys.uvars + (Methods.SortSchedule.calls source) 2 := + Methods.SortSchedule.two (support_collisionFree separation) source_supported + result_supported (theory model.keys.uvars) trustedReferences + +/-- Concrete C1A contract for the outer production body at fuel one. Its +only admitted method call is inference of `source`. -/ +theorem methodContractAtFuelOne + (separation : AddressSeparation) + (model : KernelSuffixModel RawProjRel.none VerifyWorld.empty) : + Methods.WFAtOn .noAccel + (kernelCacheSemantics model.keys RawProjRel.none) + RawProjRel.none VerifyWorld.empty support model.keys.uvars + (.singletonInfer source) + (Methods.next (Ix.Tc.methodsN (m := .anon) 1)) := by + simpa [Methods.SortSchedule.calls] using + (scheduleAtFuelOne separation model).nextSelected + +/-- Concrete strong K3 inference contract obtained from the bounded C1A +contract because sort pretranslation is already typed. -/ +theorem fullInferenceAtFuelOne + (separation : AddressSeparation) + (model : KernelSuffixModel RawProjRel.none VerifyWorld.empty) : + Methods.FullInferenceWFAtOn + (kernelCacheSemantics model.keys RawProjRel.none) + RawProjRel.none VerifyWorld.empty support model.keys.uvars + (.singletonInfer source) + (Methods.next (Ix.Tc.methodsN (m := .anon) 1)) := + Methods.FullInferenceWFAtOn.ofSingletonSort + (methodContractAtFuelOne separation model) + (Methods.next_preservesInferOnly _ + (Methods.methodsN_concrete_preservesInferOnly 1)) + +/-- Declaration-local K3 pipeline resources at fuel one. The type pipeline +admits one sort inference and no WHNF/DefEq callback. -/ +def pipelinesAtFuelOne + (separation : AddressSeparation) + (model : KernelSuffixModel RawProjRel.none VerifyWorld.empty) : + StandalonePipelineResources + (kernelCacheSemantics model.keys RawProjRel.none) + RawProjRel.none VerifyWorld.empty support model.keys.uvars + (.singletonInfer source) (Ix.Tc.methodsN (m := .anon) 1) := + StandalonePipelineResources.singletonSortAxiom + (fullInferenceAtFuelOne separation model) sortResources supported_is_sort + +def concreteAxiom : KConst .anon := .axio () () false 0 source + +/-- The concrete sort axiom is covered by the positive-fuel K3 resources. -/ +theorem pipelines_cover_concreteAxiom + (separation : AddressSeparation) + (model : KernelSuffixModel RawProjRel.none VerifyWorld.empty) : + (pipelinesAtFuelOne separation model).Covers concreteAxiom := + .axiom rfl + +end Ix.Tc.PositiveFuelSort diff --git a/Ix/Tc/Verify/Check/PreTranslation.lean b/Ix/Tc/Verify/Check/PreTranslation.lean new file mode 100644 index 000000000..d816cc002 --- /dev/null +++ b/Ix/Tc/Verify/Check/PreTranslation.lean @@ -0,0 +1,115 @@ +import Ix.Tc.Verify.Check.Scoped +import Ix.Tc.Verify.Decl +import Ix.Tc.Verify.Trans + +/-! +# Untyped structural translation for checker ingress + +`TrKExprS` is intentionally strong: its application and binder constructors +already contain the typing facts which make reduction and infer-only +soundness useful. That makes it the wrong precondition for `checkConst`, +whose job is to establish those very facts. + +`PreTrKExprS` is the non-circular bridge. It retains exact variable +resolution, universe bounds, constant resolution/arity, literal availability, +and projection interpretation, but contains no `HasType` or `IsType` +premise. Successful full inference will upgrade this relation to +`TrKExprS`; merely constructing a value of this relation cannot admit a +declaration. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr VEnv VConstant) + +variable (env : VEnv) (uvars : Nat) + (nameOf : Address → Option Lean.Name) (trProj : RawProjRel) in +/-- Syntax-directed, well-scoped, but deliberately untyped translation. -/ +inductive PreTrKExprS : KVLCtx → KExpr .anon → VExpr → Prop + | var {Delta : KVLCtx} {idx : UInt64} {name : Mode.anon.F Name} + {info : ExprInfo .anon} {value type : VExpr} : + Delta.find? (.inl idx.toNat) = some (value, type) → + PreTrKExprS Delta (.var idx name info) value + | fvar {Delta : KVLCtx} {fv : FVarId} {name : Mode.anon.F Name} + {info : ExprInfo .anon} {value type : VExpr} : + Delta.find? (.inr fv) = some (value, type) → + PreTrKExprS Delta (.fvar fv name info) value + | sort {Delta : KVLCtx} {u : KUniv .anon} {info : ExprInfo .anon} : + u.toVLevel.WF uvars → + PreTrKExprS Delta (.sort u info) (.sort u.toVLevel) + | const {Delta : KVLCtx} {id : KId .anon} + {levels : Array (KUniv .anon)} {info : ExprInfo .anon} + {name : Lean.Name} {ci : VConstant} : + nameOf id.addr = some name → + env.constants name = some ci → + (∀ level ∈ levels, level.toVLevel.WF uvars) → + levels.size = ci.uvars → + PreTrKExprS Delta (.const id levels info) + (.const name (levels.toList.map KUniv.toVLevel)) + | app {Delta : KVLCtx} {fn arg : KExpr .anon} + {info : ExprInfo .anon} {fnV argV : VExpr} : + PreTrKExprS Delta fn fnV → + PreTrKExprS Delta arg argV → + PreTrKExprS Delta (.app fn arg info) (.app fnV argV) + | lam {Delta : KVLCtx} {name : Mode.anon.F Name} + {bi : Mode.anon.F Lean.BinderInfo} {type body : KExpr .anon} + {info : ExprInfo .anon} {typeV bodyV : VExpr} : + PreTrKExprS Delta type typeV → + PreTrKExprS ((none, .vlam typeV) :: Delta) body bodyV → + PreTrKExprS Delta (.lam name bi type body info) (.lam typeV bodyV) + | all {Delta : KVLCtx} {name : Mode.anon.F Name} + {bi : Mode.anon.F Lean.BinderInfo} {type body : KExpr .anon} + {info : ExprInfo .anon} {typeV bodyV : VExpr} : + PreTrKExprS Delta type typeV → + PreTrKExprS ((none, .vlam typeV) :: Delta) body bodyV → + PreTrKExprS Delta (.all name bi type body info) (.forallE typeV bodyV) + | letE {Delta : KVLCtx} {name : Mode.anon.F Name} + {type value body : KExpr .anon} {nonDep : Bool} + {info : ExprInfo .anon} {typeV valueV bodyV : VExpr} : + PreTrKExprS Delta type typeV → + PreTrKExprS Delta value valueV → + PreTrKExprS ((none, .vlet typeV valueV) :: Delta) body bodyV → + PreTrKExprS Delta (.letE name type value body nonDep info) bodyV + | prj {Delta : KVLCtx} {id : KId .anon} {field : UInt64} + {value : KExpr .anon} {info : ExprInfo .anon} + {name : Lean.Name} {valueV resultV : VExpr} : + nameOf id.addr = some name → + PreTrKExprS Delta value valueV → + trProj Delta.toCtx name field.toNat valueV resultV → + PreTrKExprS Delta (.prj id field value info) resultV + | nat {Delta : KVLCtx} {value : Nat} {blob : Address} + {info : ExprInfo .anon} : + env.ContainsLits (.natVal value) → + PreTrKExprS Delta (.nat value blob info) (.natLit value) + | str {Delta : KVLCtx} {value : String} {blob : Address} + {info : ExprInfo .anon} : + env.ContainsLits (.strVal value) → + PreTrKExprS Delta (.str value blob info) (.trLiteral (.strVal value)) + +namespace TrKExprS + +/-- Forget only the typing premises of a checked structural translation. -/ +theorem pre + {env : VEnv} {uvars : Nat} {nameOf : Address → Option Lean.Name} + {trProj : RawProjRel} {Delta : KVLCtx} {source : KExpr .anon} + {sourceV : VExpr} + (h : TrKExprS env uvars nameOf trProj Delta source sourceV) : + PreTrKExprS env uvars nameOf trProj Delta source sourceV := by + induction h with + | var h => exact .var h + | fvar h => exact .fvar h + | sort h => exact .sort h + | const hname hlookup hlevels harity => + exact .const hname hlookup hlevels harity + | app _ _ _ _ ihfn iharg => exact .app ihfn iharg + | lam _ _ _ ihtype ihbody => exact .lam ihtype ihbody + | all _ _ _ _ ihtype ihbody => exact .all ihtype ihbody + | letE _ _ _ _ ihtype ihvalue ihbody => + exact .letE ihtype ihvalue ihbody + | prj hname _ hproj ihvalue => exact .prj hname ihvalue hproj + | nat hlit => exact .nat hlit + | str hlit => exact .str hlit + +end TrKExprS + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/PreTranslationCompatibility.lean b/Ix/Tc/Verify/Check/PreTranslationCompatibility.lean new file mode 100644 index 000000000..f4cf8c3bd --- /dev/null +++ b/Ix/Tc/Verify/Check/PreTranslationCompatibility.lean @@ -0,0 +1,171 @@ +import Ix.Tc.Verify.Check.PreTranslationIngress +import Lean4Lean.Theory.Typing.Strong + +/-! +# Compatibility of raw and typed structural translations + +A cache hit can supply a typed translation produced by an earlier checked +run, while the current `checkConst` ingress supplies only `PreTrKExprS`. +This theorem reconciles the two witnesses. It keeps the exact Theory term +chosen by the current raw translation and borrows only the typing evidence +from the checked witness. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr VEnv) + +/-- Upgrade a raw structural translation using any typed translation of the +same kernel expression in a pairwise-definitionally-equal context. -/ +theorem PreTrKExprS.upgradeOfTyped + {env : VEnv} {uvars : Nat} + {nameOf : Address → Option Lean.Name} + {trProj : RawProjRel} + (henv : VEnv.WF env) + (hlit : ∀ l, env.ContainsLits l → + VExpr.WF env uvars [] (VExpr.trLiteral l)) + (htp : TrProjOK env uvars trProj) + {DeltaRaw DeltaTyped : KVLCtx} {source : KExpr .anon} + {rawV typedV : VExpr} + (hDelta : KVLCtx.IsDefEq env uvars DeltaRaw DeltaTyped) + (Hraw : PreTrKExprS env uvars nameOf trProj DeltaRaw source rawV) + (Htyped : TrKExprS env uvars nameOf trProj DeltaTyped source typedV) : + TrKExprS env uvars nameOf trProj DeltaRaw source rawV := by + induction Hraw generalizing DeltaTyped typedV with + | var hfind => exact .var hfind + | fvar hfind => exact .fvar hfind + | sort hlevel => exact .sort hlevel + | const hname hlookup hlevels harity => + exact .const hname hlookup hlevels harity + | app hrawFn hrawArg ihFn ihArg => + let .app hfnType hargType htypedFn htypedArg := Htyped + have hfn := ihFn hDelta htypedFn + have harg := ihArg hDelta htypedArg + have hfnEq := hfn.uniq henv hlit htp hDelta htypedFn + have hargEq := harg.uniq henv hlit htp hDelta htypedArg + have hfnType := hfnType.defeqDFC henv (hDelta.symm henv).defeqCtx + have hargType := hargType.defeqDFC henv (hDelta.symm henv).defeqCtx + exact .app + (hfnType.defeqU_l henv hDelta.wf.toCtx hfnEq.symm) + (hargType.defeqU_l henv hDelta.wf.toCtx hargEq.symm) + hfn harg + | lam hrawType hrawBody ihType ihBody => + let .lam htypeType htypedType htypedBody := Htyped + have htype := ihType hDelta htypedType + have htypeEq := htype.uniq henv hlit htp hDelta htypedType + have htypeType := + htypeType.defeqDFC henv (hDelta.symm henv).defeqCtx + have hrawTypeType := + htypeType.defeqU_l henv hDelta.wf.toCtx htypeEq.symm + obtain ⟨_, hrawTypeHasType⟩ := hrawTypeType + have htypeEq' := + htypeEq.of_l henv hDelta.wf.toCtx hrawTypeHasType + have hbodyDelta : KVLCtx.IsDefEq env uvars + ((none, .vlam _) :: _) ((none, .vlam _) :: _) := + hDelta.cons nofun (.vlam htypeEq') + have hbody := ihBody hbodyDelta htypedBody + exact .lam ⟨_, hrawTypeHasType⟩ htype hbody + | all hrawType hrawBody ihType ihBody => + let .all htypeType hbodyType htypedType htypedBody := Htyped + have htype := ihType hDelta htypedType + have htypeEq := htype.uniq henv hlit htp hDelta htypedType + have htypeType := + htypeType.defeqDFC henv (hDelta.symm henv).defeqCtx + have hrawTypeType := + htypeType.defeqU_l henv hDelta.wf.toCtx htypeEq.symm + obtain ⟨_, hrawTypeHasType⟩ := hrawTypeType + have htypeEq' := + htypeEq.of_l henv hDelta.wf.toCtx hrawTypeHasType + have hbodyDelta : KVLCtx.IsDefEq env uvars + ((none, .vlam _) :: _) ((none, .vlam _) :: _) := + hDelta.cons nofun (.vlam htypeEq') + have hbody := ihBody hbodyDelta htypedBody + have hbodyEq := hbody.uniq henv hlit htp hbodyDelta htypedBody + have hbodyType := + hbodyType.defeqDFC henv (hbodyDelta.symm henv).defeqCtx + have hrawBodyType := + hbodyType.defeqU_l henv hbodyDelta.wf.toCtx hbodyEq.symm + exact .all ⟨_, hrawTypeHasType⟩ hrawBodyType htype hbody + | letE hrawType hrawValue hrawBody ihType ihValue ihBody => + let .letE hvalueType htypedType htypedValue htypedBody := Htyped + have htype := ihType hDelta htypedType + have hvalue := ihValue hDelta htypedValue + have htypeEq := htype.uniq henv hlit htp hDelta htypedType + have hvalueEq := hvalue.uniq henv hlit htp hDelta htypedValue + have hvalueType := + hvalueType.defeqDFC henv (hDelta.symm henv).defeqCtx + have hrawValueType := + (hvalueType.defeqU_l henv hDelta.wf.toCtx hvalueEq.symm).defeqU_r + henv hDelta.wf.toCtx htypeEq.symm + have hvalueEq' := hvalueEq.of_l henv hDelta.wf.toCtx hrawValueType + obtain ⟨_, hrawTypeHasType⟩ := + hrawValueType.isType henv hDelta.wf.toCtx + have htypeEq' := + htypeEq.of_l henv hDelta.wf.toCtx hrawTypeHasType + have hbodyDelta : KVLCtx.IsDefEq env uvars + ((none, .vlet _ _) :: _) ((none, .vlet _ _) :: _) := + hDelta.cons nofun (.vlet hvalueEq' htypeEq') + have hbody := ihBody hbodyDelta htypedBody + exact .letE hrawValueType htype hvalue hbody + | prj hname hrawValue hprojection ihValue => + let .prj _ htypedValue _ := Htyped + have hvalue := ihValue hDelta htypedValue + exact .prj hname hvalue hprojection + | nat hlit => exact .nat hlit + | str hlit => exact .str hlit + +/-- Binder-core pre-translation can be upgraded from well-formedness of its +exact Theory target. Strong inversion supplies precisely the application +and binder typing premises omitted by `PreTrKExprS`; the core restriction +excludes lets and projections, whose result well-formedness alone would not +recover all child judgments. -/ +theorem PreTrKExprS.upgradeBinderCoreOfWF + {env : VEnv} {uvars : Nat} + {nameOf : Address → Option Lean.Name} {trProj : RawProjRel} + (henv : VEnv.WF env) + {Delta : KVLCtx} (hDelta : KVLCtx.WF env uvars Delta) + {source : KExpr .anon} {sourceV : VExpr} + (hcore : source.binderCore = true) + (hpre : PreTrKExprS env uvars nameOf trProj Delta source sourceV) + (hwf : VExpr.WF env uvars Delta.toCtx sourceV) : + TrKExprS env uvars nameOf trProj Delta source sourceV := by + induction hpre with + | var hfind => exact .var hfind + | fvar => simp [KExpr.binderCore] at hcore + | sort hlevel => exact .sort hlevel + | const hname hlookup hlevels harity => + exact .const hname hlookup hlevels harity + | app hpreFn hpreArg ihFn ihArg => + simp only [KExpr.binderCore, Bool.and_eq_true] at hcore + obtain ⟨type, body, hfnType, hargType⟩ := + Lean4Lean.VExpr.WF.app_inv henv.ordered hDelta.toCtx hwf + exact .app hfnType hargType + (ihFn hDelta hcore.1 ⟨_, hfnType⟩) + (ihArg hDelta hcore.2 ⟨_, hargType⟩) + | lam hpreType hpreBody ihType ihBody => + simp only [KExpr.binderCore, Bool.and_eq_true] at hcore + obtain ⟨htype, hbody⟩ := + Lean4Lean.VExpr.WF.lam_inv henv.ordered hDelta.toCtx hwf + have htypeWF : VExpr.WF env uvars _ _ := + ⟨_, htype.choose_spec⟩ + exact .lam htype + (ihType hDelta hcore.1 htypeWF) + (ihBody ⟨hDelta, nofun, htype⟩ hcore.2 hbody) + | all hpreType hpreBody ihType ihBody => + simp only [KExpr.binderCore, Bool.and_eq_true] at hcore + obtain ⟨_, hwhole⟩ := hwf + obtain ⟨htype, hbody⟩ := + Lean4Lean.VEnv.HasType.forallE_inv henv.ordered hwhole + have htypeWF : VExpr.WF env uvars _ _ := + ⟨_, htype.choose_spec⟩ + have hbodyWF : VExpr.WF env uvars _ _ := + ⟨_, hbody.choose_spec⟩ + exact .all htype hbody + (ihType hDelta hcore.1 htypeWF) + (ihBody ⟨hDelta, nofun, htype⟩ hcore.2 hbodyWF) + | letE => simp [KExpr.binderCore] at hcore + | prj => simp [KExpr.binderCore] at hcore + | nat => simp [KExpr.binderCore] at hcore + | str => simp [KExpr.binderCore] at hcore + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/PreTranslationIngress.lean b/Ix/Tc/Verify/Check/PreTranslationIngress.lean new file mode 100644 index 000000000..9f7d7081c --- /dev/null +++ b/Ix/Tc/Verify/Check/PreTranslationIngress.lean @@ -0,0 +1,381 @@ +import Ix.Tc.Verify.Check.PreTranslation +import Ix.Tc.Verify.Subst + +/-! +# Raw-declaration ingress into `PreTrKExprS` + +`RawExprRel` deliberately records the direct syntax translation used before +checking. In particular, it leaves de Bruijn variables in place and performs +the substitution for a `let` only when leaving the let body. `PreTrKExprS`, +on the other hand, resolves every variable immediately through `KVLCtx`; +let-bound variables therefore translate directly to their values. + +`RawCtxInterp` is the exact bridge between those two views. Its substitution +maps the raw de Bruijn context to the Theory context represented by `KVLCtx`. +The main theorem below proves that raw translation plus the syntax-only +`KExpr.Scoped` result is sufficient to construct the untyped, well-scoped +translation required by full inference. No typing judgment is assumed. +-/ + +namespace Lean4Lean.VExpr + +private def Subst.comp (sigma tau : Subst) : Subst := + fun index => (sigma index).subst tau + +private theorem Subst.comp_lift {sigma tau : Subst} : + (Subst.comp sigma tau).lift = Subst.comp sigma.lift tau.lift := by + funext index + cases index with + | zero => rfl + | succ index => + simp only [Subst.comp, Subst.lift] + rw [lift_eq_lift', lift_eq_lift', lift'_subst, subst_lift'] + congr 1 + funext inner + simp [Subst.lift_r, Subst.lift_l, Lean4Lean.Lift.liftVar, + Subst.lift, lift_eq_lift'] + +private theorem subst_subst {e : VExpr} {sigma tau : Subst} : + (e.subst sigma).subst tau = e.subst (Subst.comp sigma tau) := by + induction e generalizing sigma tau with + | bvar => rfl + | sort => rfl + | const => rfl + | app fn arg ihFn ihArg => + simp only [subst, ihFn, ihArg] + | lam type body ihType ihBody => + simp only [subst, ihType, ihBody, Subst.comp_lift] + | forallE type body ihType ihBody => + simp only [subst, ihType, ihBody, Subst.comp_lift] + +private theorem lift_subst_cons {e : VExpr} {sigma : Subst} {value : VExpr} : + e.lift.subst (sigma.cons value) = e.subst sigma := by + rw [lift_eq_lift', subst_lift'] + have hs : Subst.lift_l (.skip .refl) (sigma.cons value) = sigma := by + funext index + rfl + rw [hs] + +/-- Substitution commutes with eliminating the head de Bruijn variable. -/ +theorem inst_subst_cons (body value : VExpr) (sigma : Subst) : + (body.inst value).subst sigma = + body.subst (sigma.cons (value.subst sigma)) := by + rw [inst_eq, subst_subst] + congr 1 + funext index + cases index with + | zero => simp [Subst.comp, Subst.one, Subst.cons] + | succ index => + simp only [Subst.comp, Subst.one, Subst.cons, Subst.id] + simpa [VExpr.subst] using + (lift_subst_cons (e := VExpr.bvar index) + (sigma := sigma) (value := value.subst sigma)) + +end Lean4Lean.VExpr + +namespace Ix.Tc + +open Lean4Lean (VExpr VLocalDecl) + +private theorem subst_natLit (value : Nat) (sigma : VExpr.Subst) : + (VExpr.natLit value).subst sigma = VExpr.natLit value := by + induction value with + | zero => rfl + | succ value ih => + simp [VExpr.natLit, VExpr.natSucc, VExpr.natZero, VExpr.subst, ih] + +private theorem subst_listCharLit (value : List Char) (sigma : VExpr.Subst) : + (VExpr.listCharLit value).subst sigma = VExpr.listCharLit value := by + induction value with + | nil => rfl + | cons head tail ih => + simp [VExpr.listCharLit, VExpr.listCharNil, VExpr.listCharCons, + VExpr.charOfNat, VExpr.char, VExpr.subst, subst_natLit, ih] + +private theorem subst_trLiteral (literal : Lean.Literal) + (sigma : VExpr.Subst) : + (VExpr.trLiteral literal).subst sigma = VExpr.trLiteral literal := by + cases literal with + | natVal value => exact subst_natLit value sigma + | strVal value => + simp [VExpr.trLiteral, VExpr.stringOfList, VExpr.subst, + subst_listCharLit] + +/-- Interpretation of the raw de Bruijn context in a translation-side +`KVLCtx`. Lambda frames retain a Theory binder; let frames disappear from +`KVLCtx.toCtx` and extend the substitution with their value instead. -/ +inductive RawCtxInterp : List VExpr -> KVLCtx -> VExpr.Subst -> Prop + | nil : RawCtxInterp [] [] .id + | lam {ctx : List VExpr} {Delta : KVLCtx} {sigma : VExpr.Subst} + (h : RawCtxInterp ctx Delta sigma) (type : VExpr) : + RawCtxInterp (type :: ctx) + ((none, .vlam (type.subst sigma)) :: Delta) sigma.lift + | letE {ctx : List VExpr} {Delta : KVLCtx} {sigma : VExpr.Subst} + (h : RawCtxInterp ctx Delta sigma) (type value : VExpr) : + RawCtxInterp (type :: ctx) + ((none, .vlet (type.subst sigma) (value.subst sigma)) :: Delta) + (sigma.cons (value.subst sigma)) + +namespace RawCtxInterp + +/-- Every in-range raw de Bruijn variable resolves to the value selected by +the interpretation substitution. -/ +theorem find?_inl + {ctx : List VExpr} {Delta : KVLCtx} {sigma : VExpr.Subst} + (h : RawCtxInterp ctx Delta sigma) {index : Nat} + (hindex : index < ctx.length) : + exists type, Delta.find? (.inl index) = some (sigma index, type) := by + induction h generalizing index with + | nil => simp at hindex + | @lam ctx Delta sigma h type ih => + cases index with + | zero => + refine ⟨(type.subst sigma).lift, ?_⟩ + simp [KVLCtx.find?, KVLCtx.next, VExpr.Subst.lift, + VLocalDecl.value, VLocalDecl.type] + | succ index => + obtain ⟨resultType, hfind⟩ := ih (by simpa using hindex) + refine ⟨resultType.lift, ?_⟩ + simp only [KVLCtx.find?, KVLCtx.next, Option.bind_eq_bind, hfind, + Option.bind_some, VExpr.Subst.lift] + rfl + | @letE ctx Delta sigma h type value ih => + cases index with + | zero => + refine ⟨type.subst sigma, ?_⟩ + simp [KVLCtx.find?, KVLCtx.next, VExpr.Subst.cons, + VLocalDecl.value, VLocalDecl.type] + | succ index => + obtain ⟨resultType, hfind⟩ := ih (by simpa using hindex) + refine ⟨resultType, ?_⟩ + simpa [KVLCtx.find?, KVLCtx.next, VExpr.Subst.cons, + VLocalDecl.depth, VExpr.liftN_zero] using hfind + +@[simp] theorem bvars_eq + {ctx : List VExpr} {Delta : KVLCtx} {sigma : VExpr.Subst} + (h : RawCtxInterp ctx Delta sigma) : Delta.bvars = ctx.length := by + induction h <;> simp [KVLCtx.bvars, *] + +end RawCtxInterp + +namespace RawProjRel + +/-- The substitution law needed to move a raw projection witness from the +raw binder/let context to the `KVLCtx` Theory context. It is explicit because +`RawProjRel` is abstract; closure, typing, or uniqueness alone cannot imply +this representation law. -/ +def SubstCompatible (trProj : RawProjRel) : Prop := + forall {ctx : List VExpr} {Delta : KVLCtx} {sigma : VExpr.Subst} + {name : Lean.Name} {field : Nat} {value result : VExpr}, + RawCtxInterp ctx Delta sigma -> + trProj ctx name field value result -> + trProj Delta.toCtx name field (value.subst sigma) (result.subst sigma) + +theorem none_substCompatible : SubstCompatible RawProjRel.none := by + intro ctx Delta sigma name field value result hctx hprojection + exact False.elim hprojection + +end RawProjRel + +/-- The declaration syntax for which raw ingress needs neither literal +availability nor a projection interpretation. It is the closed binder core +used by generated recursor types and equations. -/ +def KExpr.binderCore : KExpr .anon → Bool + | .var .. | .sort .. | .const .. => true + | .app fn argument _ => fn.binderCore && argument.binderCore + | .lam _ _ type body _ | .all _ _ type body _ => + type.binderCore && body.binderCore + | _ => false + +namespace RawExprRel + +/-- General substitution-aware ingress theorem. The size bound rules out +`UInt64` wraparound when the validator descends through a binder. -/ +theorem toPre_of_scoped_aux + {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address -> Option Lean.Name} {trProj : RawProjRel} + (hprojection : trProj.SubstCompatible) + (hliterals : forall literal, env.ContainsLits literal) + {ctx : List VExpr} {Delta : KVLCtx} {sigma : VExpr.Subst} + {depth : UInt64} {source : KExpr .anon} {sourceV : VExpr} + (hraw : RawExprRel env nameOf trProj ctx source sourceV) + (hctx : RawCtxInterp ctx Delta sigma) + (hdepth : depth.toNat = ctx.length) + (hscoped : source.Scoped depth uvars) + (hbound : depth.toNat + source.size < UInt64.size) : + PreTrKExprS env uvars nameOf trProj Delta source + (sourceV.subst sigma) := by + induction hraw generalizing Delta sigma depth with + | var => + obtain ⟨type, hfind⟩ := hctx.find?_inl (by + rw [← hdepth] + exact UInt64.lt_iff_toNat_lt.mp hscoped) + exact .var hfind + | sort => + exact .sort (KUniv.Scoped.toVLevel_wf hscoped) + | const hname hlookup harity => + exact .const hname hlookup + (fun level hlevel => + KUniv.Scoped.toVLevel_wf (hscoped level hlevel)) harity + | app hrawFn hrawArg ihFn ihArg => + exact .app + (ihFn hctx hdepth hscoped.1 (by + change depth.toNat + (_ + _ + 1) < UInt64.size at hbound + omega)) + (ihArg hctx hdepth hscoped.2 (by + change depth.toNat + (_ + _ + 1) < UInt64.size at hbound + omega)) + | @lam ctx name bi type body info typeV bodyV hrawType hrawBody ihType ihBody => + have hfull : depth.toNat + (type.size + body.size + 1) < UInt64.size := + by simpa [KExpr.size] using hbound + have hnext : (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 + (Nat.add_le_add_left (by omega : 1 <= type.size + body.size + 1) _) + hfull + have htype := ihType hctx hdepth hscoped.1 (by omega) + have hbody := ihBody (hctx.lam typeV) + (by simp [hnext, hdepth]) hscoped.2 (by rw [hnext]; omega) + simpa [VExpr.subst] using + (PreTrKExprS.lam htype hbody) + | @all ctx name bi type body info typeV bodyV hrawType hrawBody ihType ihBody => + have hfull : depth.toNat + (type.size + body.size + 1) < UInt64.size := + by simpa [KExpr.size] using hbound + have hnext : (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 + (Nat.add_le_add_left (by omega : 1 <= type.size + body.size + 1) _) + hfull + have htype := ihType hctx hdepth hscoped.1 (by omega) + have hbody := ihBody (hctx.lam typeV) + (by simp [hnext, hdepth]) hscoped.2 (by rw [hnext]; omega) + simpa [VExpr.subst] using + (PreTrKExprS.all htype hbody) + | @letE ctx name type value body nonDep info typeV valueV bodyV + hrawType hrawValue hrawBody ihType ihValue ihBody => + have hfull : + depth.toNat + (type.size + value.size + body.size + 1) < + UInt64.size := by simpa [KExpr.size] using hbound + have hnext : (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 + (Nat.add_le_add_left + (by omega : 1 <= type.size + value.size + body.size + 1) _) + hfull + have htype := ihType hctx hdepth hscoped.1 (by omega) + have hvalue := ihValue hctx hdepth hscoped.2.1 (by omega) + have hbody := ihBody (hctx.letE typeV valueV) + (by simp [hnext, hdepth]) hscoped.2.2 (by rw [hnext]; omega) + rw [VExpr.inst_subst_cons] + exact .letE htype hvalue hbody + | @prj ctx id field value info name ci valueV resultV + hname hlookup hrawValue hrawProjection ihValue => + have hvalue := ihValue hctx hdepth hscoped (by + change depth.toNat + (value.size + 1) < UInt64.size at hbound + omega) + exact .prj hname hvalue (hprojection hctx hrawProjection) + | nat => simpa [subst_natLit] using (PreTrKExprS.nat (hliterals _)) + | str => simpa [subst_trLiteral] using (PreTrKExprS.str (hliterals _)) + +/-- Closed declaration ingress: successful scoping turns the exact raw +Theory term into the `PreTrKExprS` witness consumed by full inference. -/ +theorem toPre_of_scoped + {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address -> Option Lean.Name} {trProj : RawProjRel} + (hprojection : trProj.SubstCompatible) + (hliterals : forall literal, env.ContainsLits literal) + {source : KExpr .anon} {sourceV : VExpr} + (hraw : RawExprRel env nameOf trProj [] source sourceV) + (hscoped : source.Scoped 0 uvars) + (hbound : source.size < UInt64.size) : + PreTrKExprS env uvars nameOf trProj [] source sourceV := by + simpa using hraw.toPre_of_scoped_aux hprojection hliterals + RawCtxInterp.nil rfl hscoped (by simpa using hbound) + +/-- Binder-core counterpart of `toPre_of_scoped_aux`. Excluding literals, +lets, and projections makes their ambient semantic hypotheses unnecessary; +all remaining premises are syntax-only scoping and exact raw translation. -/ +theorem toPreBinderCore_of_scoped_aux + {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address -> Option Lean.Name} {trProj : RawProjRel} + {ctx : List VExpr} {Delta : KVLCtx} {sigma : VExpr.Subst} + {depth : UInt64} {source : KExpr .anon} {sourceV : VExpr} + (hraw : RawExprRel env nameOf trProj ctx source sourceV) + (hcore : source.binderCore = true) + (hctx : RawCtxInterp ctx Delta sigma) + (hdepth : depth.toNat = ctx.length) + (hscoped : source.Scoped depth uvars) + (hbound : depth.toNat + source.size < UInt64.size) : + PreTrKExprS env uvars nameOf trProj Delta source + (sourceV.subst sigma) := by + induction hraw generalizing Delta sigma depth with + | var => + obtain ⟨type, hfind⟩ := hctx.find?_inl (by + rw [← hdepth] + exact UInt64.lt_iff_toNat_lt.mp hscoped) + exact .var hfind + | sort => + exact .sort (KUniv.Scoped.toVLevel_wf hscoped) + | const hname hlookup harity => + exact .const hname hlookup + (fun level hlevel => + KUniv.Scoped.toVLevel_wf (hscoped level hlevel)) harity + | app hrawFn hrawArg ihFn ihArg => + simp only [KExpr.binderCore, Bool.and_eq_true] at hcore + exact .app + (ihFn hcore.1 hctx hdepth hscoped.1 (by + change depth.toNat + (_ + _ + 1) < UInt64.size at hbound + omega)) + (ihArg hcore.2 hctx hdepth hscoped.2 (by + change depth.toNat + (_ + _ + 1) < UInt64.size at hbound + omega)) + | @lam ctx name bi type body info typeV bodyV hrawType hrawBody ihType ihBody => + simp only [KExpr.binderCore, Bool.and_eq_true] at hcore + have hfull : depth.toNat + (type.size + body.size + 1) < UInt64.size := + by simpa [KExpr.size] using hbound + have hnext : (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 + (Nat.add_le_add_left (by omega : 1 <= type.size + body.size + 1) _) + hfull + have htype := ihType hcore.1 hctx hdepth hscoped.1 (by omega) + have hbody := ihBody hcore.2 (hctx.lam typeV) + (by simp [hnext, hdepth]) hscoped.2 (by rw [hnext]; omega) + simpa [VExpr.subst] using + (PreTrKExprS.lam htype hbody) + | @all ctx name bi type body info typeV bodyV hrawType hrawBody ihType ihBody => + simp only [KExpr.binderCore, Bool.and_eq_true] at hcore + have hfull : depth.toNat + (type.size + body.size + 1) < UInt64.size := + by simpa [KExpr.size] using hbound + have hnext : (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 + (Nat.add_le_add_left (by omega : 1 <= type.size + body.size + 1) _) + hfull + have htype := ihType hcore.1 hctx hdepth hscoped.1 (by omega) + have hbody := ihBody hcore.2 (hctx.lam typeV) + (by simp [hnext, hdepth]) hscoped.2 (by rw [hnext]; omega) + simpa [VExpr.subst] using + (PreTrKExprS.all htype hbody) + | letE => simp [KExpr.binderCore] at hcore + | prj => simp [KExpr.binderCore] at hcore + | nat => simp [KExpr.binderCore] at hcore + | str => simp [KExpr.binderCore] at hcore + +/-- Closed binder-core declarations enter `PreTrKExprS` without requiring an +irrelevant primitive-literal environment. -/ +theorem toPreBinderCore_of_scoped + {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address -> Option Lean.Name} {trProj : RawProjRel} + {source : KExpr .anon} {sourceV : VExpr} + (hraw : RawExprRel env nameOf trProj [] source sourceV) + (hcore : source.binderCore = true) + (hscoped : source.Scoped 0 uvars) + (hbound : source.size < UInt64.size) : + PreTrKExprS env uvars nameOf trProj [] source sourceV := by + simpa using hraw.toPreBinderCore_of_scoped_aux hcore RawCtxInterp.nil rfl + hscoped (by simpa using hbound) + +end RawExprRel + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/PreTranslationOpening.lean b/Ix/Tc/Verify/Check/PreTranslationOpening.lean new file mode 100644 index 000000000..48f402999 --- /dev/null +++ b/Ix/Tc/Verify/Check/PreTranslationOpening.lean @@ -0,0 +1,190 @@ +import Ix.Tc.Verify.Check.PreTranslation +import Ix.Tc.Verify.Infer.BinderOpening + +/-! +# Binder opening for untyped checker ingress + +`checkConst` enters inference before it has a typed `TrKExprS` witness. Its +recursive binder branches nevertheless use the same `instantiateRev` +operation as the already verified typed inference path. This file proves +that operation preserves the deliberately untyped `PreTrKExprS` relation. +-/ + +namespace Ix.Tc + +open Lean4Lean (VExpr VEnv VLocalDecl) + +/-- Replacing one de Bruijn binder with its freshly tagged fvar leaves the +pre-translation's Theory expression unchanged. -/ +theorem PreTrKExprS.openFVar + {env : VEnv} {uvars : Nat} + {nameOf : Address → Option Lean.Name} + {trProj : RawProjRel} + {source : KVLCtx} {body : KExpr .anon} {bodyV : VExpr} + (H : PreTrKExprS 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 → + PreTrKExprS 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 (type := 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 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 + (ihf W hdepth hfresh (by omega)) + (iha W hdepth hfresh (by omega)) + | @lam source name bi ty body info tyV bodyV 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 + (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 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 + (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 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 + (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 production binder branches. -/ +theorem PreTrKExprS.openFVarZero + {env : VEnv} {uvars : Nat} + {nameOf : Address → Option Lean.Name} + {trProj : RawProjRel} + {Delta : KVLCtx} {decl : VLocalDecl} + {body : KExpr .anon} {bodyV : VExpr} + {fv : FVarId} {deps : List FVarId} {name : Mode.anon.F Name} + (H : PreTrKExprS env uvars nameOf trProj + ((none, decl) :: Delta) body bodyV) + (hfresh : fv ∉ Delta.fvars) + (hbound : body.size + 1 < UInt64.size) : + PreTrKExprS 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/Check/PreTranslationScopes.lean b/Ix/Tc/Verify/Check/PreTranslationScopes.lean new file mode 100644 index 000000000..0ed1b2987 --- /dev/null +++ b/Ix/Tc/Verify/Check/PreTranslationScopes.lean @@ -0,0 +1,374 @@ +import Ix.Tc.Verify.Check.InferencePolicy +import Ix.Tc.Verify.Check.PreTranslationOpening +import Ix.Tc.Verify.Infer.BinderScopes +import Ix.Tc.Verify.Infer.LetScopes + +/-! +# Binder scopes for pre-typed checker ingress + +The ordinary inference scope theorem assumes the binder body already has a +typed `TrKExprS` witness. K3 cannot make that assumption: full inference is +the operation which must construct the witness. This wrapper combines the +factored operational binder-opening core with `PreTrKExprS.openFVarZero` and +the independent inference-policy frame. +-/ + +namespace Ix.Tc + +namespace TcM + +/-- Opening a binder with a typed domain and a merely pre-translated body +returns the exact opened body under the tagged pre-translation context. -/ +theorem openBinder_pre_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} + {type body : KExpr .anon} {typeV bodyV : Lean4Lean.VExpr} + (htype : TrKExprS world.venv uvars world.nameOf trProj Delta type typeV) + (htypeType : world.venv.IsType uvars Delta.toCtx typeV) + (hbody : PreTrKExprS world.venv uvars world.nameOf trProj + ((none, .vlam typeV) :: 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 type 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 typeV) :: Delta) + after ∧ + support bodyOpen ∧ + ⟨s.env.nextFVarId⟩ ∉ Delta.fvars ∧ + PreTrKExprS world.venv uvars world.nameOf trProj + ((some (⟨s.env.nextFVarId⟩, Delta.fvars), .vlam typeV) :: Delta) + bodyOpen bodyV ∧ + after.inferOnly = s.inferOnly + | .error _ after => + WhnfStateInv layer semantics trProj world support uvars Delta after ∧ + after = s := by + intro hI + have hbase := TcM.openBinder_scope_base (bi := bi) htype htypeType + hcollision hresources hI + have hpolicy := TcM.PreservesInferOnly.openBinder name bi type body + cases hopen : TcM.openBinder name bi type body s with + | error err after => + rw [hopen] at hbase + simpa only using hbase + | ok opened after => + rcases opened with ⟨bodyOpen, fv⟩ + rw [hopen] at hbase + simp only + rcases hbase with ⟨hfv, hbodyEq, hIopen, hsupport⟩ + have hopenBound := hresources.instRevBounds ⟨s.env.nextFVarId⟩ + have hbodyOpen := hbody.openFVarZero + (fv := ⟨s.env.nextFVarId⟩) (deps := Delta.fvars) (name := name) + hI.2.1.nextFVarId_fresh (by simpa using hopenBound.2.2) + have hpolicyAfter := hpolicy.ok hopen + refine ⟨hfv, hbodyEq, hIopen, hsupport, + hI.2.1.nextFVarId_fresh, ?_, hpolicyAfter⟩ + subst fv + subst bodyOpen + exact hbodyOpen + +/-- Opening a let with typed type/value and a merely pre-translated body +returns the exact opened body under the tagged `vlet` context. -/ +theorem openLet_pre_scope + {support : RunSupport} + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {s : TcState .anon} + {name : Mode.anon.F Name} + {type value body : KExpr .anon} + {typeV valueV bodyV : Lean4Lean.VExpr} + (htype : TrKExprS world.venv uvars world.nameOf trProj Delta type typeV) + (hvalue : TrKExprS world.venv uvars world.nameOf trProj Delta value valueV) + (hvalueType : world.venv.HasType uvars Delta.toCtx valueV typeV) + (hbody : PreTrKExprS world.venv uvars world.nameOf trProj + ((none, .vlet typeV valueV) :: Delta) body bodyV) + (hcollision : support.CollisionFree) + (hresources : BinderOpeningResources support name body) : + WhnfStateInv layer semantics trProj world support uvars Delta s → + match TcM.openLet name type value 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 typeV valueV) :: Delta) after ∧ + support bodyOpen ∧ + ⟨s.env.nextFVarId⟩ ∉ Delta.fvars ∧ + PreTrKExprS world.venv uvars world.nameOf trProj + ((some (⟨s.env.nextFVarId⟩, Delta.fvars), + .vlet typeV valueV) :: Delta) bodyOpen bodyV ∧ + after.inferOnly = s.inferOnly + | .error _ after => + WhnfStateInv layer semantics trProj world support uvars Delta after ∧ + after = s := by + intro hI + have hbase := TcM.openLet_scope_base htype hvalue hvalueType + hcollision hresources hI + have hpolicy := TcM.PreservesInferOnly.openLet name type value body + cases hopen : TcM.openLet name type value body s with + | error err after => + rw [hopen] at hbase + simpa only using hbase + | ok opened after => + rcases opened with ⟨bodyOpen, fv⟩ + rw [hopen] at hbase + simp only + rcases hbase with ⟨hfv, hbodyEq, hIopen, hsupport⟩ + have hopenBound := hresources.instRevBounds ⟨s.env.nextFVarId⟩ + have hbodyOpen := hbody.openFVarZero + (fv := ⟨s.env.nextFVarId⟩) (deps := Delta.fvars) (name := name) + hI.2.1.nextFVarId_fresh (by simpa using hopenBound.2.2) + have hpolicyAfter := hpolicy.ok hopen + refine ⟨hfv, hbodyEq, hIopen, hsupport, + hI.2.1.nextFVarId_fresh, ?_, hpolicyAfter⟩ + subst fv + subst bodyOpen + exact hbodyOpen + +end TcM + +namespace RecM + +/-- Scope a pre-translated binder around one fixed recursive method table. +Unlike the ordinary K2 scope rule, the body need not be typed before the +continuation runs: the continuation receives its exact opened +pre-translation and may establish typing by recursive full inference. -/ +theorem withLctxScope_openBinder_pre_wf + {beta : Type} {support : RunSupport} + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {methods : Methods .anon} {s : TcState .anon} + {name : Mode.anon.F Name} {bi : Mode.anon.F Lean.BinderInfo} + {type body : KExpr .anon} {typeV bodyV : Lean4Lean.VExpr} + (htype : TrKExprS world.venv uvars world.nameOf trProj Delta type typeV) + (htypeType : world.venv.IsType uvars Delta.toCtx typeV) + (hbody : PreTrKExprS world.venv uvars world.nameOf trProj + ((none, .vlam typeV) :: Delta) body bodyV) + (hcollision : support.CollisionFree) + (hresources : BinderOpeningResources support name body) + (hpolicy : s.inferOnly = false) + {k : KExpr .anon → FVarId → RecM .anon beta} + {Qinner Qouter : beta → TcState .anon → Prop} + {Einner Eouter : TcError .anon → TcState .anon → Prop} + (hk : ∀ {bodyOpen fv after}, + fv = ⟨s.env.nextFVarId⟩ → + bodyOpen = KExpr.instantiateRevSpec body + #[.mkFVar ⟨s.env.nextFVarId⟩ name] 0 → + support bodyOpen → + ⟨s.env.nextFVarId⟩ ∉ Delta.fvars → + PreTrKExprS world.venv uvars world.nameOf trProj + ((some (⟨s.env.nextFVarId⟩, Delta.fvars), .vlam typeV) :: Delta) + bodyOpen bodyV → + after.inferOnly = false → + TcM.WF + (WhnfStateInv layer semantics trProj world support uvars + ((some (⟨s.env.nextFVarId⟩, Delta.fvars), .vlam typeV) :: Delta)) + after ((k bodyOpen fv).run methods) Qinner Einner) + (hclose : ∀ result after, Qinner result after → + Qouter result + {after with lctx := after.lctx.truncate s.lctx.size}) + (hcloseError : ∀ err after, Einner err after → + Eouter err {after with lctx := after.lctx.truncate s.lctx.size}) + (hopenError : ∀ err, Eouter err s) : + TcM.WF + (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((withLctxScope do + let (bodyOpen, fv) ← + (liftM (TcM.openBinder name bi type body) : + RecM .anon (KExpr .anon × FVarId)) + k bodyOpen fv).run methods) + Qouter Eouter := by + intro hI + rw [RecM.withLctxScope_eq] + have hopenPost := TcM.openBinder_pre_scope (bi := bi) htype htypeType + hbody hcollision hresources hI + cases hopenRun : TcM.openBinder name bi type 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 type body) : + RecM .anon (KExpr .anon × FVarId)) + k bodyOpen fv).run methods s = .error err afterOpen := by + change EStateM.bind (TcM.openBinder name bi type 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, hopenError err⟩ + | ok opened afterOpen => + rcases opened with ⟨bodyOpen, fv⟩ + rw [hopenRun] at hopenPost + simp only at hopenPost + rcases hopenPost with + ⟨hfv, hbodyEq, hIOpen, hbodySupport, hfresh, hbodyPre, + hopenPolicy⟩ + have htail := hk hfv hbodyEq hbodySupport hfresh hbodyPre + (hopenPolicy.trans hpolicy) 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 type body) : + RecM .anon (KExpr .anon × FVarId)) + k bodyOpen fv).run methods s = .ok result after := by + change EStateM.bind (TcM.openBinder name bi type 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 type body) : + RecM .anon (KExpr .anon × FVarId)) + k bodyOpen fv).run methods s = .error tailErr after := by + change EStateM.bind (TcM.openBinder name bi type 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, + hcloseError _ _ htail.2⟩ + +/-- Fixed-method-table scope rule for a pre-translated let body. -/ +theorem withLctxScope_openLet_pre_wf + {beta : Type} {support : RunSupport} + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {Delta : KVLCtx} {methods : Methods .anon} {s : TcState .anon} + {name : Mode.anon.F Name} + {type value body : KExpr .anon} + {typeV valueV bodyV : Lean4Lean.VExpr} + (htype : TrKExprS world.venv uvars world.nameOf trProj Delta type typeV) + (hvalue : TrKExprS world.venv uvars world.nameOf trProj Delta value valueV) + (hvalueType : world.venv.HasType uvars Delta.toCtx valueV typeV) + (hbody : PreTrKExprS world.venv uvars world.nameOf trProj + ((none, .vlet typeV valueV) :: Delta) body bodyV) + (hcollision : support.CollisionFree) + (hresources : BinderOpeningResources support name body) + (hpolicy : s.inferOnly = false) + {k : KExpr .anon → FVarId → RecM .anon beta} + {Qinner Qouter : beta → TcState .anon → Prop} + {Einner Eouter : TcError .anon → TcState .anon → Prop} + (hk : ∀ {bodyOpen fv after}, + fv = ⟨s.env.nextFVarId⟩ → + bodyOpen = KExpr.instantiateRevSpec body + #[.mkFVar ⟨s.env.nextFVarId⟩ name] 0 → + support bodyOpen → + ⟨s.env.nextFVarId⟩ ∉ Delta.fvars → + PreTrKExprS world.venv uvars world.nameOf trProj + ((some (⟨s.env.nextFVarId⟩, Delta.fvars), + .vlet typeV valueV) :: Delta) bodyOpen bodyV → + after.inferOnly = false → + TcM.WF + (WhnfStateInv layer semantics trProj world support uvars + ((some (⟨s.env.nextFVarId⟩, Delta.fvars), + .vlet typeV valueV) :: Delta)) + after ((k bodyOpen fv).run methods) Qinner Einner) + (hclose : ∀ result after, Qinner result after → + Qouter result + {after with lctx := after.lctx.truncate s.lctx.size}) + (hcloseError : ∀ err after, Einner err after → + Eouter err {after with lctx := after.lctx.truncate s.lctx.size}) + (hopenError : ∀ err, Eouter err s) : + TcM.WF + (WhnfStateInv layer semantics trProj world support uvars Delta) s + ((withLctxScope do + let (bodyOpen, fv) ← + (liftM (TcM.openLet name type value body) : + RecM .anon (KExpr .anon × FVarId)) + k bodyOpen fv).run methods) + Qouter Eouter := by + intro hI + rw [RecM.withLctxScope_eq] + have hopenPost := TcM.openLet_pre_scope htype hvalue hvalueType hbody + hcollision hresources hI + cases hopenRun : TcM.openLet name type value 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 type value body) : + RecM .anon (KExpr .anon × FVarId)) + k bodyOpen fv).run methods s = .error err afterOpen := by + change EStateM.bind (TcM.openLet name type value 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, hopenError err⟩ + | ok opened afterOpen => + rcases opened with ⟨bodyOpen, fv⟩ + rw [hopenRun] at hopenPost + simp only at hopenPost + rcases hopenPost with + ⟨hfv, hbodyEq, hIOpen, hbodySupport, hfresh, hbodyPre, + hopenPolicy⟩ + have htail := hk hfv hbodyEq hbodySupport hfresh hbodyPre + (hopenPolicy.trans hpolicy) 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 type value body) : + RecM .anon (KExpr .anon × FVarId)) + k bodyOpen fv).run methods s = .ok result after := by + change EStateM.bind (TcM.openLet name type value 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 type value body) : + RecM .anon (KExpr .anon × FVarId)) + k bodyOpen fv).run methods s = .error tailErr after := by + change EStateM.bind (TcM.openLet name type value 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, + hcloseError _ _ htail.2⟩ + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/ProjectionInferencePolicy.lean b/Ix/Tc/Verify/Check/ProjectionInferencePolicy.lean new file mode 100644 index 000000000..268104ae8 --- /dev/null +++ b/Ix/Tc/Verify/Check/ProjectionInferencePolicy.lean @@ -0,0 +1,388 @@ +import Ix.Tc.Verify.Check.UncachedInferencePolicy + +/-! +# Operational policy for projection inference + +This module discharges the operational premise left explicit by uncached +inference. It follows the production projection helper through WHNF spine +exposure, lazy declaration lookup, inductive-result classification, universe +instantiation, parameter substitution, and the selected-field telescope. + +The range-loop lemmas account for both `done` and `yield`, so early field +selection and every partial-error path preserve the caller's `inferOnly` +policy. The final theorem combines this helper with the uncached dispatcher +and cache shell, reducing the current inference layer to the current WHNF +policy over a policy-framed smaller method table. +-/ + +namespace Ix.Tc + +namespace RecM + +private theorem forInList_preservesInferOnly + {methods : Methods .anon} + {step : alpha → beta → RecM .anon (ForInStep beta)} + (hstep : ∀ item state, + ((step item state).run methods).PreservesInferOnly) : + ∀ (items : List alpha) (initial : beta), + ((forIn (m := RecM .anon) items initial step).run methods).PreservesInferOnly + | [], initial => by + exact TcM.PreservesInferOnly.pure initial + | item :: rest, initial => by + rw [List.forIn_cons, ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind (hstep item initial) + intro action + cases action with + | done result => exact TcM.PreservesInferOnly.pure result + | yield next => exact forInList_preservesInferOnly hstep rest next + +private theorem forInRange_preservesInferOnly + {methods : Methods .anon} + {step : Nat → beta → RecM .anon (ForInStep beta)} + (hstep : ∀ item state, + ((step item state).run methods).PreservesInferOnly) + (range : _root_.Std.Legacy.Range) (initial : beta) : + ((forIn (m := RecM .anon) range initial step).run methods).PreservesInferOnly := by + rw [_root_.Std.Legacy.Range.forIn_eq_forIn_range'] + exact forInList_preservesInferOnly hstep _ initial + +theorem peelProjForall_preservesInferOnly + {methods : Methods .anon} + (hwhnf : ∀ source, + ((RecM.whnf source).run methods).PreservesInferOnly) + (source : KExpr .anon) (err : String) : + ((peelProjForall source err).run methods).PreservesInferOnly := by + cases source <;> simp only [peelProjForall, pure_bind] + all_goals + first + | exact TcM.PreservesInferOnly.pure _ + | (simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind (hwhnf _) + intro reduced + cases reduced <;> simp only <;> + first + | exact TcM.PreservesInferOnly.pure _ + | exact TcM.PreservesInferOnly.throw _) + +theorem instantiateProjParamStep_preservesInferOnly + {methods : Methods .anon} + (hwhnf : ∀ source, + ((RecM.whnf source).run methods).PreservesInferOnly) + (args : Array (KExpr .anon)) (i : Nat) (ctorTy : KExpr .anon) : + ((instantiateProjParamStep args i ctorTy).run methods).PreservesInferOnly := by + unfold instantiateProjParamStep + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind + (peelProjForall_preservesInferOnly hwhnf ctorTy _) + intro peeled + rcases peeled with ⟨_, body⟩ + split + · simp only [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.runIntern _) + intro result + exact TcM.PreservesInferOnly.pure (ForInStep.yield result) + · exact TcM.PreservesInferOnly.throw _ + +theorem instantiateProjParams_preservesInferOnly + {methods : Methods .anon} + (hwhnf : ∀ source, + ((RecM.whnf source).run methods).PreservesInferOnly) + (args : Array (KExpr .anon)) (numParams : Nat) + (ctorTy : KExpr .anon) : + ((instantiateProjParams args numParams ctorTy).run methods).PreservesInferOnly := by + unfold instantiateProjParams + exact forInRange_preservesInferOnly + (fun i current => + instantiateProjParamStep_preservesInferOnly hwhnf args i current) + _ ctorTy + +private theorem inferProjectionSort_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hwhnf : ∀ source, + ((RecM.whnf source).run methods).PreservesInferOnly) + (source : KExpr .anon) : + ((do + let sourceTy ← inferCall source + ensureSortDirect sourceTy).run methods).PreservesInferOnly := by + simp only [ReaderT.run_bind, inferCall] + apply TcM.PreservesInferOnly.bind (hmethods.infer source) + intro sourceTy + exact ensureSortDirect_preservesInferOnly hwhnf + +private theorem inferProjFieldTail_preservesInferOnly + {methods : Methods .anon} (structId : KId .anon) (i : Nat) + (val body : KExpr .anon) : + ((do + let proj ← TcM.intern (.mkPrj structId i.toUInt64 val) + let result ← TcM.runIntern (subst body proj 0) + pure (ForInStep.yield result) : + RecM .anon (ForInStep (KExpr .anon))).run methods).PreservesInferOnly := by + change (do + let proj ← TcM.intern (.mkPrj structId i.toUInt64 val) + let result ← TcM.runIntern (subst body proj 0) + pure (ForInStep.yield result) : + TcM .anon (ForInStep (KExpr .anon))).PreservesInferOnly + unfold TcM.intern + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.runIntern _) + intro proj + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.runIntern (subst body proj 0)) + intro result + exact TcM.PreservesInferOnly.pure (ForInStep.yield result) + +theorem inferProjFieldStep_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hwhnf : ∀ source, + ((RecM.whnf source).run methods).PreservesInferOnly) + (structId : KId .anon) (field : UInt64) (val : KExpr .anon) + (isPropStruct : Bool) (i : Nat) (current : KExpr .anon) : + ((inferProjFieldStep structId field val isPropStruct i current).run + methods).PreservesInferOnly := by + unfold inferProjFieldStep + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind + (peelProjForall_preservesInferOnly hwhnf current _) + intro peeled + rcases peeled with ⟨dom, body⟩ + split + · cases isPropStruct with + | false => exact TcM.PreservesInferOnly.pure (ForInStep.done dom) + | true => + simp only [if_true, ReaderT.run_bind, inferCall] + apply TcM.PreservesInferOnly.bind (hmethods.infer dom) + intro fieldSortTy + apply TcM.PreservesInferOnly.bind + (ensureSortDirect_preservesInferOnly hwhnf) + intro fieldLevel + split + · exact TcM.PreservesInferOnly.throw _ + · exact TcM.PreservesInferOnly.pure (ForInStep.done dom) + · cases isPropStruct with + | false => + exact inferProjFieldTail_preservesInferOnly structId i val body + | true => + simp only [if_true, ReaderT.run_bind, pure_bind, + inferCall] + apply TcM.PreservesInferOnly.bind (hmethods.infer dom) + intro fieldSortTy + apply TcM.PreservesInferOnly.bind + (ensureSortDirect_preservesInferOnly hwhnf) + intro fieldLevel + split + · exact TcM.PreservesInferOnly.throw _ + · exact inferProjFieldTail_preservesInferOnly structId i val body + +theorem inferProjFieldsLoopStep_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hwhnf : ∀ source, + ((RecM.whnf source).run methods).PreservesInferOnly) + (structId : KId .anon) (field : UInt64) (val : KExpr .anon) + (isPropStruct : Bool) (i : Nat) + (state : Option (KExpr .anon) × KExpr .anon) : + ((inferProjFieldsLoopStep structId field val isPropStruct i state).run + methods).PreservesInferOnly := by + unfold inferProjFieldsLoopStep + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind + (inferProjFieldStep_preservesInferOnly hmethods hwhnf structId field val + isPropStruct i state.2) + intro action + cases action with + | done result => + exact TcM.PreservesInferOnly.pure + (ForInStep.done (some result, state.2)) + | yield next => + exact TcM.PreservesInferOnly.pure + (ForInStep.yield (none, next)) + +theorem inferProjFields_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hwhnf : ∀ source, + ((RecM.whnf source).run methods).PreservesInferOnly) + (structId : KId .anon) (field : UInt64) (val : KExpr .anon) + (isPropStruct : Bool) (ctorTy : KExpr .anon) : + ((inferProjFields structId field val isPropStruct ctorTy).run + methods).PreservesInferOnly := by + unfold inferProjFields + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind + (forInRange_preservesInferOnly + (fun i state => + inferProjFieldsLoopStep_preservesInferOnly hmethods hwhnf structId + field val isPropStruct i state) + _ ((none : Option (KExpr .anon)), ctorTy)) + intro state + cases state.1 with + | none => exact TcM.PreservesInferOnly.throw _ + | some result => exact TcM.PreservesInferOnly.pure result + +theorem inductiveAppBinderStep_preservesInferOnly + {methods : Methods .anon} + (hwhnf : ∀ source, + ((RecM.whnf source).run methods).PreservesInferOnly) + (current : KExpr .anon) : + ((inductiveAppBinderStep current).run methods).PreservesInferOnly := by + unfold inductiveAppBinderStep + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind (hwhnf current) + intro reduced + cases reduced <;> simp only <;> + first + | exact TcM.PreservesInferOnly.pure _ + | exact TcM.PreservesInferOnly.throw _ + +theorem inductiveAppBinders_preservesInferOnly + {methods : Methods .anon} + (hwhnf : ∀ source, + ((RecM.whnf source).run methods).PreservesInferOnly) + (binders : Nat) (indTy : KExpr .anon) : + ((inductiveAppBinders binders indTy).run methods).PreservesInferOnly := by + unfold inductiveAppBinders + exact forInRange_preservesInferOnly + (fun _ current => inductiveAppBinderStep_preservesInferOnly hwhnf current) + _ indTy + +theorem inductiveAppResultIsProp_preservesInferOnly + {methods : Methods .anon} + (hwhnf : ∀ source, + ((RecM.whnf source).run methods).PreservesInferOnly) + (resultTy : KExpr .anon) : + ((inductiveAppResultIsProp resultTy).run methods).PreservesInferOnly := by + unfold inductiveAppResultIsProp + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind (hwhnf resultTy) + intro sortTy + apply TcM.PreservesInferOnly.bind + (ensureSortDirect_preservesInferOnly hwhnf) + intro level + exact TcM.PreservesInferOnly.pure (univEq level .mkZero) + +theorem inductiveAppIsProp_preservesInferOnly + {methods : Methods .anon} + (hwhnf : ∀ source, + ((RecM.whnf source).run methods).PreservesInferOnly) + (indId : KId .anon) (levels : Array (KUniv .anon)) + (binders : Nat) : + ((inductiveAppIsProp indId levels binders).run methods).PreservesInferOnly := by + unfold inductiveAppIsProp + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.tryGetConst indId) + intro declaration + cases declaration with + | none => exact TcM.PreservesInferOnly.throw _ + | some declaration => + cases declaration with + | indc name levelParams lvls params indices isUnsafe block memberIdx + indTy ctors leanAll => + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.instantiateUnivParams indTy levels) + intro instantiated + apply TcM.PreservesInferOnly.bind + (inductiveAppBinders_preservesInferOnly hwhnf binders + instantiated) + intro resultTy + exact inductiveAppResultIsProp_preservesInferOnly hwhnf resultTy + | _ => exact TcM.PreservesInferOnly.throw _ + +theorem inferProj_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hwhnf : ∀ source, + ((RecM.whnf source).run methods).PreservesInferOnly) + (structId : KId .anon) (field : UInt64) (val valTy : KExpr .anon) : + ((inferProj structId field val valTy).run methods).PreservesInferOnly := by + unfold inferProj + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind (hwhnf valTy) + intro reduced + rcases hspine : reduced.collectSpine with ⟨head, args⟩ + cases head with + | const headId levels info => + simp only + split + · exact TcM.PreservesInferOnly.throw _ + · simp only [ReaderT.run_bind, ReaderT.run_monadLift, pure_bind] + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.tryGetConst headId) + intro declaration + cases declaration with + | none => exact TcM.PreservesInferOnly.throw _ + | some declaration => + cases declaration with + | indc name levelParams lvls params indices isUnsafe block + memberIdx indTy ctors leanAll => + simp only + split + · exact TcM.PreservesInferOnly.throw _ + · simp only [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.PreservesInferOnly.bind + (inductiveAppIsProp_preservesInferOnly hwhnf headId + levels (params.toNat + indices.toNat)) + intro isPropStruct + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.tryGetConst ctors[0]!) + intro constructor + cases constructor with + | none => exact TcM.PreservesInferOnly.throw _ + | some constructor => + simp only + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.instantiateUnivParams + constructor.ty levels) + intro instantiatedCtorTy + apply TcM.PreservesInferOnly.bind + (instantiateProjParams_preservesInferOnly hwhnf args + params.toNat instantiatedCtorTy) + intro parameterizedCtorTy + exact inferProjFields_preservesInferOnly hmethods hwhnf + structId field val isPropStruct parameterizedCtorTy + | _ => exact TcM.PreservesInferOnly.throw _ + | _ => exact TcM.PreservesInferOnly.throw _ + +end RecM + +namespace ProjectionInference + +/-- The production projection helper preserves inference policy whenever its +smaller method table and the current WHNF layer do. -/ +theorem preservesInferOnlyAt + (methods : Methods .anon) (hmethods : methods.PreservesInferOnly) + (hwhnf : ∀ source, + ((RecM.whnf source).run methods).PreservesInferOnly) : + PreservesInferOnlyAt methods := by + intro structId field val valTy + exact RecM.inferProj_preservesInferOnly hmethods hwhnf structId field val + valTy + +end ProjectionInference + +namespace RecM + +/-- Discharge the uncached dispatcher's projection premise from the concrete +projection helper implementation. -/ +theorem inferUncached_preservesInferOnly_of_whnf + (methods : Methods .anon) (hmethods : methods.PreservesInferOnly) + (hwhnf : ∀ source, + ((RecM.whnf source).run methods).PreservesInferOnly) + (inferOnly : Bool) (source : KExpr .anon) : + ((inferUncached inferCall inferOnly source).run methods).PreservesInferOnly := + inferUncached_preservesInferOnly methods hmethods hwhnf + (ProjectionInference.preservesInferOnlyAt methods hmethods hwhnf) + inferOnly source + +/-- The production inference cache shell and uncached dispatcher together +preserve inference policy once the current WHNF layer is framed. -/ +theorem infer_preservesInferOnly_of_whnf + (methods : Methods .anon) (hmethods : methods.PreservesInferOnly) + (hwhnf : ∀ source, + ((RecM.whnf source).run methods).PreservesInferOnly) + (source : KExpr .anon) : + ((infer source).run methods).PreservesInferOnly := by + apply infer_preservesInferOnly methods + exact inferUncached_preservesInferOnly_of_whnf methods hmethods hwhnf + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/PublicBlocks.lean b/Ix/Tc/Verify/Check/PublicBlocks.lean new file mode 100644 index 000000000..3ba1abfb1 --- /dev/null +++ b/Ix/Tc/Verify/Check/PublicBlocks.lean @@ -0,0 +1,69 @@ +import Ix.Tc.Verify.Check.CheckConstTransaction +import Ix.Tc.Verify.Check.BlockDefinition +import Ix.Tc.Verify.Check.BlockOracle +import Ix.Tc.Verify.Check.QuotientBoundary + +/-! +# Public coordinated-block checker theorem + +This is E0's stable public import frontier. It instantiates the recursive +driver with the exact finite method table chosen by `TcM.runRec` and crosses +the public error-isolation wrapper. Successful isolation is transparent, so +the semantic disposition is indexed by the public checker's exact final +state. +-/ + +namespace Ix.Tc + +namespace TcM.checkConst + +/-- A successful public checker call either atomically accepts the exact +routed block or executes the separately verified standalone branch. The +coordinated body certifier is explicitly relative to K3 singleton-definition +evidence or E2's inductive/recursor oracle resources. -/ +theorem blockDisposition + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {id : KId .anon} {before after : TcState .anon} + (hbefore : CoordinatedKernelStateWF semantics trProj world support before) + (hexactCatalog : ExactCoordinatedCatalog world) + (hfault : TcM.LazyFaultPreserves + (CoordinatedKernelStateWF semantics trProj world support)) + (hfaultBlock : TcM.LazyFaultPreserves + (fun state => BlockStateWF trProj state world)) + (certify : ∀ {block : KId .anon} + {members : Array (KId .anon)} {kind : CheckBlockKind} + {routed bodyAfter : TcState .anon}, + ExactCheckBlock world block members kind → + id ∈ members → + RecM.ExactBlockBodySuccessTrace + (Ix.Tc.methodsN (m := .anon) before.recFuel.toNat) + block id members kind routed bodyAfter → + CertifiedBlockBodySuccess semantics trProj world support + (Ix.Tc.methodsN (m := .anon) before.recFuel.toNat) + block id members kind routed bodyAfter) + (hrun : TcM.checkConst id before = .ok () after) : + CheckConstSuccessDisposition semantics trProj world support + (Ix.Tc.methodsN (m := .anon) before.recFuel.toNat) + id before after := by + let methods := Ix.Tc.methodsN (m := .anon) before.recFuel.toNat + have hbody : (RecM.checkConst id).run methods before = .ok () after := by + unfold TcM.checkConst TcM.isolateCheckErrors TcM.runRec at hrun + cases hinner : + (RecM.checkConst id).run + (Ix.Tc.methodsN (m := .anon) before.recFuel.toNat) before with + | ok value middle => + simp only [hinner] at hrun + cases hrun + rfl + | error err failed => + simp only [hinner] at hrun + contradiction + apply RecM.checkConst_success_disposition hbefore hexactCatalog hfault + hfaultBlock ?_ hbody + intro block members kind routed bodyAfter hexact hmember trace + simpa [methods] using certify hexact hmember trace + +end TcM.checkConst + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/PublicStandalone.lean b/Ix/Tc/Verify/Check/PublicStandalone.lean new file mode 100644 index 000000000..c7bd6312c --- /dev/null +++ b/Ix/Tc/Verify/Check/PublicStandalone.lean @@ -0,0 +1,316 @@ +import Ix.Tc.Verify.Check.ScopedStandaloneDriver +import Ix.Tc.Verify.RecursiveMethods.Public + +/-! +# Public standalone constant checking + +The member and driver proofs establish K3 for a fixed method table. This +module instantiates that table with the exact finite approximation selected +by production `TcM.runRec`, and then crosses `isolateCheckErrors`. The latter +is transparent on success, so the certified final state is exactly the state +returned by the public checker. + +Whole-block coordination remains the separately named E0 boundary. The +theorem below therefore requires `StandaloneRoute`; axioms discharge it +definitionally, while standalone definitions may supply a finite routing +proof for their concrete block environment. +-/ + +namespace Ix.Tc + +namespace TcM.checkConst + +/-- The public wrapper returns the exact failed recursive execution after +restoring subject-sensitive caches against the entry state. Lazy loads, +intern growth, fuel consumption, and cached block errors remain governed by +`TcState.restoreCheckCachesOnError`. -/ +theorem rollback_on_error + {before failed : TcState .anon} {id : KId .anon} + {err : TcError .anon} + (hbody : + (RecM.checkConst id).run + (Ix.Tc.methodsN (m := .anon) before.recFuel.toNat) before = + .error err failed) : + TcM.checkConst id before = + .error err (before.restoreCheckCachesOnError failed) := by + unfold TcM.checkConst TcM.runRec + exact TcM.isolateCheckErrors_error hbody + +/-- The exact public rollback equation reassembles the stable kernel/cache +invariant from the entry caches and the failed execution's ordinary +state/intern frames. No semantic claim about entries written by the failed +subject is assumed. -/ +theorem rollback_preserves_kernel + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {before failed : TcState .anon} {id : KId .anon} + {err : TcError .anon} + (hbody : + (RecM.checkConst id).run + (Ix.Tc.methodsN (m := .anon) before.recFuel.toNat) before = + .error err failed) + (hbefore : KernelStateWF semantics trProj world support before) + (hfailedCore : TcStateWF trProj failed world) + (hfailedIntern : support.CoversIntern failed.env.intern) : + TcM.checkConst id before = + .error err (before.restoreCheckCachesOnError failed) ∧ + KernelStateWF semantics trProj world support + (before.restoreCheckCachesOnError failed) := + ⟨rollback_on_error hbody, + hbefore.restoreCheckCachesOnError hfailedCore hfailedIntern⟩ + +/-- Successful public checking of a pending standalone declaration produces +the concrete K3 acceptance result and promotes exactly that declaration into +a trusted ghost world. The recursive callbacks and the stronger checker +inference pipeline are both restricted to the successor-layer call domain +selected by the finite production schedule. -/ +theorem wf_legacy + {before : TcState .anon} {id : KId .anon} + {requests : List WalkerRequest} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (context : RecursiveMethodRunContext before (TcM.checkConst id) + requests trProj world support) + (pipelines : StandalonePipelineResources + (kernelCacheSemantics context.proposition.model.keys trProj) + trProj world support context.proposition.model.keys.uvars + (context.calls (before.recFuel.toNat + 1)) + (Ix.Tc.methodsN (m := .anon) before.recFuel.toNat)) + {concrete : KConst .anon} {decl : Lean4Lean.VDecl} + (hprojection : trProj.SubstCompatible) + (hliterals : ∀ literal, world.venv.ContainsLits literal) + (hpending : PendingDecl trProj world id decl) + (hcatalog : world.catalog id = some concrete) + (hresources : StandaloneValidationResources support concrete) + (hpipelines : pipelines.Covers concrete) + (hcollision : support.CollisionFree) + (huvars : context.proposition.model.keys.uvars = concrete.lvls.toNat) + (hroute : StandaloneRoute + (WhnfStateInv .noAccel + (kernelCacheSemantics context.proposition.model.keys trProj) trProj + world support context.proposition.model.keys.uvars []) + (Ix.Tc.methodsN (m := .anon) before.recFuel.toNat) concrete) + (hI : WhnfStateInv .noAccel + (kernelCacheSemantics context.proposition.model.keys trProj) trProj world + support context.proposition.model.keys.uvars [] before) + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv .noAccel + (kernelCacheSemantics context.proposition.model.keys trProj) trProj + world support context.proposition.model.keys.uvars [])) + {after : TcState .anon} + (hrun : TcM.checkConst id before = .ok () after) : + StandaloneCheckResult trProj world support id concrete decl ∧ + ∃ world', + Promotes world (fun target => target = id) world' ∧ + WhnfStateInv .noAccel + (kernelCacheSemantics context.proposition.model.keys trProj) trProj + world' support context.proposition.model.keys.uvars [] after ∧ + TrustedDecl trProj world' id decl := by + let methods := Ix.Tc.methodsN (m := .anon) before.recFuel.toNat + have hmethods : Methods.WFAtOn .noAccel + (kernelCacheSemantics context.proposition.model.keys trProj) trProj world + support context.proposition.model.keys.uvars + (context.calls (before.recFuel.toNat + 1)) (Methods.next methods) := by + simpa [methods] using context.schedule.nextSelected + have hpolicy : (Methods.next methods).PreservesInferOnly := + Methods.next_preservesInferOnly methods + (Methods.methodsN_concrete_preservesInferOnly before.recFuel.toNat) + have hroute' : StandaloneRoute + (WhnfStateInv .noAccel + (kernelCacheSemantics context.proposition.model.keys trProj) trProj world + support context.proposition.model.keys.uvars []) methods concrete := by + simpa [methods] using hroute + have hbody : (RecM.checkConst id).run methods before = .ok () after := by + unfold TcM.checkConst TcM.isolateCheckErrors TcM.runRec at hrun + cases hinner : + (RecM.checkConst id).run + (Ix.Tc.methodsN before.recFuel.toNat) before with + | ok value middle => + simp only [hinner] at hrun + cases hrun + rfl + | error err failed => + simp only [hinner] at hrun + contradiction + exact RecM.checkConst_standalone_pending_sound pipelines hmethods hpolicy + hprojection hliterals hpending hcatalog hresources hpipelines hcollision + huvars hroute' hI hfault hbody + +/-- Successful public checking of a pending standalone declaration over one +finite suffix-state domain. Unlike `wf_legacy`, this contract carries +`StateInScope` through every recursive callback, lazy-ingress transition, +reset, and checker stage; it has no globally quantified suffix model or +scoped-to-global conversion premise. -/ +theorem wf + {before : TcState .anon} {id : KId .anon} + {requests : List WalkerRequest} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (context : ScopedRecursiveMethodRunContext before (TcM.checkConst id) + requests trProj world support) + (pipelines : ScopedStandalonePipelineResources context.model support + (context.calls (before.recFuel.toNat + 1)) + (Ix.Tc.methodsN (m := .anon) before.recFuel.toNat)) + {concrete : KConst .anon} {decl : Lean4Lean.VDecl} + (hprojection : trProj.SubstCompatible) + (hliterals : ∀ literal, world.venv.ContainsLits literal) + (hpending : PendingDecl trProj world id decl) + (hcatalog : world.catalog id = some concrete) + (hresources : StandaloneValidationResources support concrete) + (hpipelines : pipelines.Covers concrete) + (hcollision : support.CollisionFree) + (huvars : context.model.keys.uvars = concrete.lvls.toNat) + (hresetScope : context.model.ResetPreservesScope) + (hroute : StandaloneRoute + (ScopedWhnfStateInv context.model .noAccel + (kernelCacheSemantics context.model.keys trProj) support []) + (Ix.Tc.methodsN (m := .anon) before.recFuel.toNat) concrete) + (hI : ScopedWhnfStateInv context.model .noAccel + (kernelCacheSemantics context.model.keys trProj) support [] before) + (hfault : TcM.LazyFaultPreserves + (ScopedWhnfStateInv context.model .noAccel + (kernelCacheSemantics context.model.keys trProj) support [])) + {after : TcState .anon} + (hrun : TcM.checkConst id before = .ok () after) : + StandaloneCheckResult trProj world support id concrete decl ∧ + ∃ world', + Promotes world (fun target => target = id) world' ∧ + WhnfStateInv .noAccel + (kernelCacheSemantics context.model.keys trProj) trProj world' + support context.model.keys.uvars [] after ∧ + context.model.StateInScope after ∧ + TrustedDecl trProj world' id decl := by + let methods := Ix.Tc.methodsN (m := .anon) before.recFuel.toNat + have hmethods : Methods.ScopedWFAtOn context.model .noAccel + (kernelCacheSemantics context.model.keys trProj) support + (context.calls (before.recFuel.toNat + 1)) (Methods.next methods) := by + simpa [methods] using context.schedule.nextSelected + have hpolicy : (Methods.next methods).PreservesInferOnly := + Methods.next_preservesInferOnly methods + (Methods.methodsN_concrete_preservesInferOnly before.recFuel.toNat) + have hroute' : StandaloneRoute + (ScopedWhnfStateInv context.model .noAccel + (kernelCacheSemantics context.model.keys trProj) support []) methods + concrete := by + simpa [methods] using hroute + have hbody : (RecM.checkConst id).run methods before = .ok () after := by + unfold TcM.checkConst TcM.isolateCheckErrors TcM.runRec at hrun + cases hinner : + (RecM.checkConst id).run + (Ix.Tc.methodsN before.recFuel.toNat) before with + | ok value middle => + simp only [hinner] at hrun + cases hrun + rfl + | error err failed => + simp only [hinner] at hrun + contradiction + exact RecM.checkConst_standalone_scoped_pending_sound pipelines hmethods + hpolicy hprojection hliterals hpending hcatalog hresources hpipelines + hcollision huvars hresetScope hroute' hI hfault hbody + +/-- An intrinsically ill-typed pending standalone declaration cannot be +accepted by the public checker. The contradiction uses the raw pending +translation and freshness to turn K3's successful semantic evidence into the +forbidden Theory declaration transition; no typing fact is assumed at +ingress. -/ +theorem rejected_of_no_decl_wf + {before : TcState .anon} {id : KId .anon} + {requests : List WalkerRequest} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (context : RecursiveMethodRunContext before (TcM.checkConst id) + requests trProj world support) + (pipelines : StandalonePipelineResources + (kernelCacheSemantics context.proposition.model.keys trProj) + trProj world support context.proposition.model.keys.uvars + (context.calls (before.recFuel.toNat + 1)) + (Ix.Tc.methodsN (m := .anon) before.recFuel.toNat)) + {concrete : KConst .anon} {decl : Lean4Lean.VDecl} + (hprojection : trProj.SubstCompatible) + (hliterals : ∀ literal, world.venv.ContainsLits literal) + (hpending : PendingDecl trProj world id decl) + (hcatalog : world.catalog id = some concrete) + (hresources : StandaloneValidationResources support concrete) + (hpipelines : pipelines.Covers concrete) + (hcollision : support.CollisionFree) + (huvars : context.proposition.model.keys.uvars = concrete.lvls.toNat) + (hroute : StandaloneRoute + (WhnfStateInv .noAccel + (kernelCacheSemantics context.proposition.model.keys trProj) trProj + world support context.proposition.model.keys.uvars []) + (Ix.Tc.methodsN (m := .anon) before.recFuel.toNat) concrete) + (hI : WhnfStateInv .noAccel + (kernelCacheSemantics context.proposition.model.keys trProj) trProj world + support context.proposition.model.keys.uvars [] before) + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv .noAccel + (kernelCacheSemantics context.proposition.model.keys trProj) trProj + world support context.proposition.model.keys.uvars [])) + (hnotWF : ¬∃ world', Lean4Lean.VDecl.WF world.venv decl world') : + ∃ err failed, + TcM.checkConst id before = .error err failed ∧ + PendingDecl trProj world id decl := by + cases hrun : TcM.checkConst id before with + | error err failed => + exact ⟨err, failed, rfl, hpending⟩ + | ok value after => + cases value + have hresult := wf_legacy context pipelines hprojection hliterals + hpending hcatalog hresources hpipelines hcollision huvars hroute hI + hfault hrun + obtain ⟨_pendingConcrete, _hpendingCatalog, hraw, _huntrusted, _hclosed, + hfresh⟩ := hpending + exact False.elim <| hnotWF (hraw.wfOfAccepted hfresh hresult.1.accepted) + +/-- Axioms take the standalone route by definition, so their public K3 +theorem has no residual block-coordination premise. -/ +theorem axiom_pending_sound + {before : TcState .anon} {id : KId .anon} + {requests : List WalkerRequest} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (context : RecursiveMethodRunContext before (TcM.checkConst id) + requests trProj world support) + (pipelines : StandalonePipelineResources + (kernelCacheSemantics context.proposition.model.keys trProj) + trProj world support context.proposition.model.keys.uvars + (context.calls (before.recFuel.toNat + 1)) + (Ix.Tc.methodsN (m := .anon) before.recFuel.toNat)) + {name : Mode.anon.F Name} + {levelParams : Mode.anon.F (Array Name)} {isUnsafe : Bool} + {levels : UInt64} {type : KExpr .anon} {decl : Lean4Lean.VDecl} + (hprojection : trProj.SubstCompatible) + (hliterals : ∀ literal, world.venv.ContainsLits literal) + (hpending : PendingDecl trProj world id decl) + (hcatalog : world.catalog id = some + (.axio name levelParams isUnsafe levels type)) + (hresources : StandaloneValidationResources support + (.axio name levelParams isUnsafe levels type)) + (hpipelines : pipelines.Covers + (.axio name levelParams isUnsafe levels type)) + (hcollision : support.CollisionFree) + (huvars : context.proposition.model.keys.uvars = levels.toNat) + (hI : WhnfStateInv .noAccel + (kernelCacheSemantics context.proposition.model.keys trProj) trProj world + support context.proposition.model.keys.uvars [] before) + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv .noAccel + (kernelCacheSemantics context.proposition.model.keys trProj) trProj + world support context.proposition.model.keys.uvars [])) + {after : TcState .anon} + (hrun : TcM.checkConst id before = .ok () after) : + StandaloneCheckResult trProj world support id + (.axio name levelParams isUnsafe levels type) decl ∧ + ∃ world', + Promotes world (fun target => target = id) world' ∧ + WhnfStateInv .noAccel + (kernelCacheSemantics context.proposition.model.keys trProj) trProj + world' support context.proposition.model.keys.uvars [] after ∧ + TrustedDecl trProj world' id decl := by + apply wf_legacy context pipelines hprojection hliterals hpending + hcatalog hresources hpipelines hcollision huvars + · exact StandaloneRoute.axiomRoute _ _ name levelParams isUnsafe levels type + · exact hI + · exact hfault + · exact hrun + +end TcM.checkConst + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/QuotientAdmission.lean b/Ix/Tc/Verify/Check/QuotientAdmission.lean new file mode 100644 index 000000000..ef9fd18bd --- /dev/null +++ b/Ix/Tc/Verify/Check/QuotientAdmission.lean @@ -0,0 +1,260 @@ +import Ix.Tc.Verify.Env +import Ix.Tc.Primitive +import Lean4Lean.Theory.Typing.QuotLemmas + +/-! +# Atomic quotient admission + +`KConst.quot` declarations are physically standalone entries, but their +semantic meaning is not four independent axioms. Lean4Lean installs `Quot`, +`Quot.mk`, `Quot.lift`, and `Quot.ind` in order and then registers one quotient +definitional equation. This file records the corresponding address-keyed Ix +boundary without granting a successful check of any one member authority over +the other three. + +The relation deliberately retains each intermediate `VEnv`: later primitive +types mention earlier primitives, so translating all four against the initial +environment would be false. The production-checker proof still has to +construct this relation from the four exact `checkQuot` successes and the +`Eq`/`Eq.refl` prerequisite. Once it does, the theorems below close the atomic +Lean4Lean transition without another oracle. +-/ + +namespace Ix.Tc + +open Lean4Lean (VDecl VEnv VConstant) + +/-- One address-keyed quotient insertion in the exact environment where its +type is interpreted. The final conjunct prevents a prefix from masquerading +as the whole quotient bundle. -/ +def QuotientAdmissionStep + (catalog : Catalog) (nameOf : Address → Option Lean.Name) + (trProj : RawProjRel) (id : KId .anon) (name : Lean.Name) + (kind : Ix.QuotKind) (semantic : VConstant) + (Next : VEnv → Prop) (before : VEnv) : Prop := + ∃ levels type after, + catalog id = some (.quot () () kind levels type) ∧ + nameOf id.addr = some name ∧ + TrKConstant .safe before nameOf trProj + (.quot () () kind levels type) semantic ∧ + before.addConst name semantic = some after ∧ + Next after + +namespace QuotientAdmissionStep + +/-- Compose one witnessed insertion with the remaining `Option` chain. -/ +theorem bind + {catalog : Catalog} {nameOf : Address → Option Lean.Name} + {trProj : RawProjRel} {id : KId .anon} {name : Lean.Name} + {kind : Ix.QuotKind} {semantic : VConstant} + {Next : VEnv → Prop} {before final : VEnv} {tail : VEnv → Option VEnv} + (hnext : ∀ env, Next env → tail env = some final) + (h : QuotientAdmissionStep catalog nameOf trProj id name kind + semantic Next before) : + before.addConst name semantic >>= tail = some final := by + obtain ⟨levels, type, after, hcatalog, hname, htranslated, hadd, + htail⟩ := h + rw [hadd] + exact hnext after htail + +/-- Each step extends the Theory environment when its continuation does. -/ +theorem le + {catalog : Catalog} {nameOf : Address → Option Lean.Name} + {trProj : RawProjRel} {id : KId .anon} {name : Lean.Name} + {kind : Ix.QuotKind} {semantic : VConstant} + {Next : VEnv → Prop} {before final : VEnv} + (hnext : ∀ env, Next env → env ≤ final) + (h : QuotientAdmissionStep catalog nameOf trProj id name kind + semantic Next before) : + before ≤ final := by + obtain ⟨levels, type, after, hcatalog, hname, htranslated, hadd, + htail⟩ := h + exact (VEnv.addConst_le hadd).trans (hnext after htail) + +end QuotientAdmissionStep + +/-- The complete address-keyed analogue of Lean4Lean's four-step +`AddQuot1` chain. The final equality installs the quotient defeq only after +all four exact constants have been added. -/ +def QuotientBundleAdmission + (catalog : Catalog) (nameOf : Address → Option Lean.Name) + (trProj : RawProjRel) (prims : Primitives .anon) + (before after : VEnv) : Prop := + QuotientAdmissionStep catalog nameOf trProj prims.quotType ``Quot + .type Lean4Lean.quotConst (before := before) fun env₁ => + QuotientAdmissionStep catalog nameOf trProj prims.quotCtor ``Quot.mk + .ctor Lean4Lean.quotMkConst (before := env₁) fun env₂ => + QuotientAdmissionStep catalog nameOf trProj prims.quotLift ``Quot.lift + .lift Lean4Lean.quotLiftConst (before := env₂) fun env₃ => + QuotientAdmissionStep catalog nameOf trProj prims.quotInd ``Quot.ind + .ind Lean4Lean.quotIndConst (before := env₃) fun env₄ => + env₄.addDefEq Lean4Lean.quotDefEq = after + +/-- The complete semantic acceptance input: the pre-environment already has +the canonical `Eq`, and the four-member Ix bundle follows the exact atomic +Theory insertion chain. -/ +structure QuotientAdmission + (catalog : Catalog) (nameOf : Address → Option Lean.Name) + (trProj : RawProjRel) (prims : Primitives .anon) + (before after : VEnv) : Prop where + ready : before.QuotReady + bundle : + QuotientBundleAdmission catalog nameOf trProj prims before after + +namespace QuotientBundleAdmission + +/-- Atomic admission contains exact catalog witnesses for all four primitive +roles. In particular, no successful prefix is a bundle witness. -/ +theorem catalogEntries + {catalog : Catalog} {nameOf : Address → Option Lean.Name} + {trProj : RawProjRel} {prims : Primitives .anon} + {before after : VEnv} + (h : QuotientBundleAdmission catalog nameOf trProj prims before after) : + (∃ levels type, + catalog prims.quotType = some (.quot () () .type levels type)) ∧ + (∃ levels type, + catalog prims.quotCtor = some (.quot () () .ctor levels type)) ∧ + (∃ levels type, + catalog prims.quotLift = some (.quot () () .lift levels type)) ∧ + (∃ levels type, + catalog prims.quotInd = some (.quot () () .ind levels type)) := by + unfold QuotientBundleAdmission at h + obtain ⟨typeLevels, typeType, env₁, htype, _, _, _, h₁⟩ := h + obtain ⟨ctorLevels, ctorType, env₂, hctor, _, _, _, h₂⟩ := h₁ + obtain ⟨liftLevels, liftType, env₃, hlift, _, _, _, h₃⟩ := h₂ + obtain ⟨indLevels, indType, env₄, hind, _, _, _, h₄⟩ := h₃ + exact ⟨⟨typeLevels, typeType, htype⟩, + ⟨ctorLevels, ctorType, hctor⟩, + ⟨liftLevels, liftType, hlift⟩, + ⟨indLevels, indType, hind⟩⟩ + +/-- The address-keyed primitive table is tied to the four distinct Lean +names used by the Theory transition. -/ +theorem nameAssignments + {catalog : Catalog} {nameOf : Address → Option Lean.Name} + {trProj : RawProjRel} {prims : Primitives .anon} + {before after : VEnv} + (h : QuotientBundleAdmission catalog nameOf trProj prims before after) : + nameOf prims.quotType.addr = some ``Quot ∧ + nameOf prims.quotCtor.addr = some ``Quot.mk ∧ + nameOf prims.quotLift.addr = some ``Quot.lift ∧ + nameOf prims.quotInd.addr = some ``Quot.ind := by + unfold QuotientBundleAdmission at h + obtain ⟨_, _, _, _, htype, _, _, h₁⟩ := h + obtain ⟨_, _, _, _, hctor, _, _, h₂⟩ := h₁ + obtain ⟨_, _, _, _, hlift, _, _, h₃⟩ := h₂ + obtain ⟨_, _, _, _, hind, _, _, h₄⟩ := h₃ + exact ⟨htype, hctor, hlift, hind⟩ + +/-- A complete Ix bundle witness executes Lean4Lean's production-order +`addQuot` operation exactly. -/ +theorem toAddQuot + {catalog : Catalog} {nameOf : Address → Option Lean.Name} + {trProj : RawProjRel} {prims : Primitives .anon} + {before after : VEnv} + (h : QuotientBundleAdmission catalog nameOf trProj prims before after) : + before.addQuot = some after := by + unfold QuotientBundleAdmission at h + unfold VEnv.addQuot + apply h.bind + intro env₁ h₁ + apply h₁.bind + intro env₂ h₂ + apply h₂.bind + intro env₃ h₃ + apply h₃.bind + intro env₄ h₄ + simp only [h₄] + +/-- Atomic quotient admission extends, rather than replacing, the prior +Theory environment. -/ +theorem le + {catalog : Catalog} {nameOf : Address → Option Lean.Name} + {trProj : RawProjRel} {prims : Primitives .anon} + {before after : VEnv} + (h : QuotientBundleAdmission catalog nameOf trProj prims before after) : + before ≤ after := by + unfold QuotientBundleAdmission at h + apply h.le + intro env₁ h₁ + apply h₁.le + intro env₂ h₂ + apply h₂.le + intro env₃ h₃ + apply h₃.le + intro env₄ h₄ + rw [← h₄] + exact VEnv.addDefEq_le + +/-- The completed bundle installs the exact `Quot` type constant. -/ +theorem quotType + {catalog : Catalog} {nameOf : Address → Option Lean.Name} + {trProj : RawProjRel} {prims : Primitives .anon} + {before after : VEnv} + (h : QuotientBundleAdmission catalog nameOf trProj prims before after) : + after.constants ``Quot = some Lean4Lean.quotConst := + VEnv.addQuot_quot h.toAddQuot + +/-- The completed bundle installs the exact quotient constructor. -/ +theorem quotCtor + {catalog : Catalog} {nameOf : Address → Option Lean.Name} + {trProj : RawProjRel} {prims : Primitives .anon} + {before after : VEnv} + (h : QuotientBundleAdmission catalog nameOf trProj prims before after) : + after.constants ``Quot.mk = some Lean4Lean.quotMkConst := + VEnv.addQuot_quotMk h.toAddQuot + +/-- The completed bundle installs the exact computational eliminator. -/ +theorem quotLift + {catalog : Catalog} {nameOf : Address → Option Lean.Name} + {trProj : RawProjRel} {prims : Primitives .anon} + {before after : VEnv} + (h : QuotientBundleAdmission catalog nameOf trProj prims before after) : + after.constants ``Quot.lift = some Lean4Lean.quotLiftConst := + VEnv.addQuot_quotLift h.toAddQuot + +/-- The completed bundle installs the exact propositional eliminator. -/ +theorem quotInd + {catalog : Catalog} {nameOf : Address → Option Lean.Name} + {trProj : RawProjRel} {prims : Primitives .anon} + {before after : VEnv} + (h : QuotientBundleAdmission catalog nameOf trProj prims before after) : + after.constants ``Quot.ind = some Lean4Lean.quotIndConst := + VEnv.addQuot_quotInd h.toAddQuot + +/-- The quotient reduction equation is available only after the entire +bundle has been admitted. -/ +theorem quotientDefEq + {catalog : Catalog} {nameOf : Address → Option Lean.Name} + {trProj : RawProjRel} {prims : Primitives .anon} + {before after : VEnv} + (h : QuotientBundleAdmission catalog nameOf trProj prims before after) : + after.defeqs Lean4Lean.quotDefEq := + VEnv.addQuot_defeq h.toAddQuot + +end QuotientBundleAdmission + +namespace QuotientAdmission + +/-- The complete Ix-side witness constructs one Lean4Lean quotient +declaration transition; no member can be promoted separately. -/ +theorem wf + {catalog : Catalog} {nameOf : Address → Option Lean.Name} + {trProj : RawProjRel} {prims : Primitives .anon} + {before after : VEnv} + (h : QuotientAdmission catalog nameOf trProj prims before after) : + VDecl.WF before .quot after := + .quot h.ready h.bundle.toAddQuot + +/-- The atomic acceptance witness is monotone in the semantic environment. -/ +theorem le + {catalog : Catalog} {nameOf : Address → Option Lean.Name} + {trProj : RawProjRel} {prims : Primitives .anon} + {before after : VEnv} + (h : QuotientAdmission catalog nameOf trProj prims before after) : + before ≤ after := + h.bundle.le + +end QuotientAdmission + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/QuotientBoundary.lean b/Ix/Tc/Verify/Check/QuotientBoundary.lean new file mode 100644 index 000000000..5b08e2580 --- /dev/null +++ b/Ix/Tc/Verify/Check/QuotientBoundary.lean @@ -0,0 +1,106 @@ +import Ix.Tc.Verify.Check.BlockClassification +import Ix.Tc.Verify.Check.QuotientAdmission +import Ix.Tc.Verify.Check.StandaloneDriver + +/-! +# Quotient checking is not a coordinated-block transaction + +Production validates quotient declarations through `checkConstMember`; they +never enter `coordinatedBlockFor`. If a quotient is nevertheless present in +a physical block array, the production classifier rejects it at the exact +member where it is observed. The semantic catalog relation likewise has no +coordinated quotient constructor. + +This keeps quotient acceptance as its own future theorem instead of granting +it inductive-oracle or block-cache authority through E0. +-/ + +namespace Ix.Tc + +namespace RecM + +/-- The production router never selects a coordinated block for a quotient. -/ +theorem coordinatedBlockFor_quotient + (name : Mode.anon.F Name) + (levelParams : Mode.anon.F (Array Name)) (kind : Ix.QuotKind) + (levels : UInt64) (type : KExpr .anon) (methods : Methods .anon) + (state : TcState .anon) : + (coordinatedBlockFor (.quot name levelParams kind levels type)).run + methods state = .ok none state := by + rfl + +/-- Axioms share the same non-coordinated routing boundary. -/ +theorem coordinatedBlockFor_axiom + (name : Mode.anon.F Name) + (levelParams : Mode.anon.F (Array Name)) (isUnsafe : Bool) + (levels : UInt64) (type : KExpr .anon) (methods : Methods .anon) + (state : TcState .anon) : + (coordinatedBlockFor (.axio name levelParams isUnsafe levels type)).run + methods state = .ok none state := by + rfl + +end RecM + +namespace RecM.BlockClassFlags + +/-- Encountering a quotient in the named production census is an immediate +classifier error; no later flag combination can turn it into a block kind. -/ +theorem note_quotient + (flags : BlockClassFlags) (member : KId .anon) + (name : Mode.anon.F Name) (levelParams : Mode.anon.F (Array Name)) + (kind : Ix.QuotKind) (levels : UInt64) (type : KExpr .anon) : + flags.note member (.quot name levelParams kind levels type) = + .error (.other + s!"unsupported check block {member}: axiom/quotient member") := by + rfl + +/-- Axioms are rejected by the same production census branch. -/ +theorem note_axiom + (flags : BlockClassFlags) (member : KId .anon) + (name : Mode.anon.F Name) (levelParams : Mode.anon.F (Array Name)) + (isUnsafe : Bool) (levels : UInt64) (type : KExpr .anon) : + flags.note member (.axio name levelParams isUnsafe levels type) = + .error (.other + s!"unsupported check block {member}: axiom/quotient member") := by + rfl + +end RecM.BlockClassFlags + +namespace Catalog + +/-- A catalogued quotient cannot satisfy any coordinated member kind. -/ +theorem quotient_not_coordinated + {catalog : Catalog} {id block : KId .anon} + {name : Mode.anon.F Name} {levelParams : Mode.anon.F (Array Name)} + {quotKind : Ix.QuotKind} {levels : UInt64} {type : KExpr .anon} + (hcatalog : catalog id = + some (.quot name levelParams quotKind levels type)) + (kind : CheckBlockKind) : + ¬catalog.CoordinatedMember block kind id := by + rintro ⟨concrete, hfound, hshape⟩ + have hconcrete : concrete = + .quot name levelParams quotKind levels type := + Option.some.inj (hfound.symm.trans hcatalog) + subst concrete + cases kind <;> + simp [KConst.IsMemberOfKind, KConst.IsDefinitionMemberOf, + KConst.IsInductiveMemberOf, KConst.IsRecursorMemberOf] at hshape + +end Catalog + +namespace StandaloneRoute + +/-- Quotient declarations take the operational standalone branch, while +their semantic acceptance remains deliberately outside K3/E0. -/ +theorem quotientRoute + (I : TcState .anon → Prop) (methods : Methods .anon) + (name : Mode.anon.F Name) (levelParams : Mode.anon.F (Array Name)) + (kind : Ix.QuotKind) (levels : UInt64) (type : KExpr .anon) : + StandaloneRoute I methods + (.quot name levelParams kind levels type) := by + intro state hI + exact ⟨hI, rfl⟩ + +end StandaloneRoute + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/RecursiveMethodPolicy.lean b/Ix/Tc/Verify/Check/RecursiveMethodPolicy.lean new file mode 100644 index 000000000..035fec191 --- /dev/null +++ b/Ix/Tc/Verify/Check/RecursiveMethodPolicy.lean @@ -0,0 +1,81 @@ +import Ix.Tc.Verify.Check.DefEqCachePolicy + +/-! +# Operational closure of the recursive method table + +All concrete WHNF, inference, and DefEq implementations preserve the +caller's `inferOnly` bit when their recursive calls use a predecessor table +with the same six-field frame. This is the non-circular one-layer theorem +needed to close every finite `methodsN` approximation. +-/ + +namespace Ix.Tc + +namespace Methods + +/-- One production `Methods.next` layer preserves inference policy whenever +its strictly smaller callback table does. -/ +theorem next_preservesInferOnly + (methods : Methods .anon) (hmethods : methods.PreservesInferOnly) : + (Methods.next methods).PreservesInferOnly := by + let reductionPolicy := + RecM.concreteWhnfReductionPolicy methods hmethods + let noDeltaPolicy : RecM.WhnfNoDeltaPolicyAt methods := + reductionPolicy.toWhnfNoDeltaPolicyAt + have hwhnf : ∀ source, + ((RecM.whnf source).run methods).PreservesInferOnly := + RecM.whnf_preservesInferOnly reductionPolicy + have hcore : ∀ source, + ((RecM.whnfCore source).run methods).PreservesInferOnly := + RecM.whnfCore_preservesInferOnly noDeltaPolicy + have hmode : ∀ source mode, + ((RecM.whnfWithNatSuccMode source mode).run + methods).PreservesInferOnly := + RecM.whnfWithNatSuccMode_preservesInferOnly reductionPolicy + have hcoreFlags : ∀ source flags, + ((RecM.whnfCoreWithFlags source flags).run + methods).PreservesInferOnly := + RecM.whnfCoreWithFlags_preservesInferOnly noDeltaPolicy + have hnoDelta : ∀ source, + ((RecM.whnfNoDelta source).run methods).PreservesInferOnly := + RecM.whnfNoDelta_preservesInferOnly noDeltaPolicy + have hcheapCore : ∀ source, + ((RecM.whnfCoreForDefEq source).run methods).PreservesInferOnly := + RecM.whnfCoreForDefEq_preservesInferOnly noDeltaPolicy + have hcheapNoDelta : ∀ source, + ((RecM.whnfNoDeltaForDefEq source).run + methods).PreservesInferOnly := + RecM.whnfNoDeltaForDefEq_preservesInferOnly noDeltaPolicy + have hinfer : ∀ source, + ((RecM.infer source).run methods).PreservesInferOnly := + RecM.infer_preservesInferOnly_of_whnf methods hmethods hwhnf + have hinner : ∀ left right, + ((RecM.isDefEqInner left right).run + methods).PreservesInferOnly := + RecM.isDefEqInner_preservesInferOnly hmethods hwhnf hcore hnoDelta + hcheapCore hcheapNoDelta + have hdefeq : ∀ left right, + ((RecM.isDefEq left right).run methods).PreservesInferOnly := + RecM.isDefEq_preservesInferOnly_of_inner hinner + exact { + whnf := hwhnf + whnfCore := hcore + whnfMode := hmode + whnfCoreFlags := hcoreFlags + infer := hinfer + isDefEq := hdefeq } + +/-- Concrete one-layer closure used by the finite production knot. -/ +theorem inferOnlyClosed : Methods.InferOnlyClosed := by + intro methods hmethods + exact next_preservesInferOnly methods hmethods + +/-- Every depth-indexed production table restores its caller's inference +policy on success and error. -/ +theorem methodsN_concrete_preservesInferOnly (depth : Nat) : + (methodsN (m := .anon) depth).PreservesInferOnly := + methodsN_preservesInferOnly inferOnlyClosed depth + +end Methods + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/ResetFrame.lean b/Ix/Tc/Verify/Check/ResetFrame.lean new file mode 100644 index 000000000..7cd4e1bec --- /dev/null +++ b/Ix/Tc/Verify/Check/ResetFrame.lean @@ -0,0 +1,102 @@ +import Ix.Tc.Verify.Check.MemberEvidence + +/-! +# Per-constant reset framing + +The public checker enters the recursive method table before executing +`TcM.reset`. This file proves that the exact reset establishes the empty +local-context invariant while retaining the stable kernel/cache state needed +by the fixed method table. +-/ + +namespace Ix.Tc + +namespace TcM + +/-- The production reset preserves the stable kernel invariant and +establishes the exact empty-context, full-inference entry conditions. -/ +theorem reset_whnf_entry + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} (before : TcState .anon) + (hlayer : layer.StateOK before) : + TcM.WF + (KernelStateWF semantics trProj world support) before + (TcM.reset (m := .anon)) + (fun _ after => + after.inferOnly = false ∧ + CtxRecon world.venv uvars world.nameOf trProj after [] ∧ + layer.StateOK after ∧ + after.recFuel = before.fuelBudget) := by + intro hkernel + change KernelStateWF semantics trProj world support + { before with + ctx := #[] + letVals := #[] + numLetBindings := 0 + ctxId := emptyCtxAddr + ctxIdStack := #[] + equivManager := {} + inferOnly := false + inNativeReduce := false + cheapRecursionDepth := 0 + eagerReduce := false + defEqDepth := 0 + defEqPeak := 0 + dispatchDepth := 0 + recFuel := before.fuelBudget + ctxAddrCache := {} + lctx := {} } ∧ + (false = false ∧ + CtxRecon world.venv uvars world.nameOf trProj + { before with + ctx := #[] + letVals := #[] + numLetBindings := 0 + ctxId := emptyCtxAddr + ctxIdStack := #[] + equivManager := {} + inferOnly := false + inNativeReduce := false + cheapRecursionDepth := 0 + eagerReduce := false + defEqDepth := 0 + defEqPeak := 0 + dispatchDepth := 0 + recFuel := before.fuelBudget + ctxAddrCache := {} + lctx := {} } [] ∧ + layer.StateOK + { before with + ctx := #[] + letVals := #[] + numLetBindings := 0 + ctxId := emptyCtxAddr + ctxIdStack := #[] + equivManager := {} + inferOnly := false + inNativeReduce := false + cheapRecursionDepth := 0 + eagerReduce := false + defEqDepth := 0 + defEqPeak := 0 + dispatchDepth := 0 + recFuel := before.fuelBudget + ctxAddrCache := {} + lctx := {} } ∧ + before.fuelBudget = before.fuelBudget) + refine ⟨?_, rfl, ?_, ?_, rfl⟩ + · exact + { core := hkernel.core.of_env_eq rfl + internSupport := hkernel.internSupport + caches := hkernel.caches + equivalences := EquivManager.WF.empty } + · exact CtxRecon.empty rfl rfl rfl rfl + · cases layer with + | structuralNoAccel => exact hlayer + | noAccel => exact hlayer + | accelerated => exact hlayer + +end TcM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/SafetyFrame.lean b/Ix/Tc/Verify/Check/SafetyFrame.lean new file mode 100644 index 000000000..2fcfafef9 --- /dev/null +++ b/Ix/Tc/Verify/Check/SafetyFrame.lean @@ -0,0 +1,144 @@ +import Ix.Tc.Verify.Check.ValidatorFrame + +/-! +# State framing for the unsafe-reference traversal + +`checkNoUnsafeRefs` is semantically a safety guard. For K3 its important +operational property is that the iterative expression walk changes checker +state only through optional constant lookup. Consequently every outcome +preserves any invariant framed by the installed lazy-ingress hook. +-/ + +namespace Ix.Tc + +namespace RecM + +/-- The production safety worklist preserves an arbitrary lazy-ingress-framed +state invariant on both success and error. -/ +theorem checkNoUnsafeRefs_go_frame : + ∀ (callerSafety : Ix.DefinitionSafety) + (stack : List (KExpr .anon)) + (seenExprs seenConsts : Std.HashSet Address) + (methods : Methods .anon) (I : TcState .anon → Prop), + TcM.LazyFaultPreserves I → + ∀ (state : TcState .anon), + TcM.WF I state + ((RecM.checkNoUnsafeRefs.go callerSafety stack seenExprs seenConsts).run + methods) + (fun _ _ => True) + | callerSafety, [], seenExprs, seenConsts, methods, I, hfault, state => by + rw [RecM.checkNoUnsafeRefs.go] + exact TcM.WF.pure fun _ => trivial + | callerSafety, expr :: stack, seenExprs, seenConsts, methods, I, hfault, + state => by + rw [RecM.checkNoUnsafeRefs.go] + split + · simp only [bind_pure] + exact checkNoUnsafeRefs_go_frame callerSafety stack seenExprs + seenConsts methods I hfault state + · cases expr with + | var idx name info => + simp only [pure_bind] + exact checkNoUnsafeRefs_go_frame callerSafety stack + (seenExprs.insert (KExpr.var idx name info).addr) seenConsts + methods I hfault state + | fvar id name info => + simp only [pure_bind] + exact checkNoUnsafeRefs_go_frame callerSafety stack + (seenExprs.insert (KExpr.fvar id name info).addr) seenConsts + methods I hfault state + | sort level info => + simp only [pure_bind] + exact checkNoUnsafeRefs_go_frame callerSafety stack + (seenExprs.insert (KExpr.sort level info).addr) seenConsts + methods I hfault state + | nat value blob info => + simp only [pure_bind] + exact checkNoUnsafeRefs_go_frame callerSafety stack + (seenExprs.insert (KExpr.nat value blob info).addr) seenConsts + methods I hfault state + | str value blob info => + simp only [pure_bind] + exact checkNoUnsafeRefs_go_frame callerSafety stack + (seenExprs.insert (KExpr.str value blob info).addr) seenConsts + methods I hfault state + | const id levels info => + simp only [pure_bind] + split + · simp only [bind_pure] + exact checkNoUnsafeRefs_go_frame callerSafety stack + (seenExprs.insert (KExpr.const id levels info).addr) + seenConsts methods I hfault state + · simp only [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.WF.bind (TcM.tryGetConst_wf hfault id state) + intro found lookupState _ + split + · simp only [ReaderT.run_bind] + exact TcM.WF.throw fun _ => trivial + · simp only [ReaderT.run_bind] + exact TcM.WF.throw fun _ => trivial + · split + · simp only [ReaderT.run_bind] + exact TcM.WF.throw fun _ => trivial + · exact checkNoUnsafeRefs_go_frame callerSafety stack + (seenExprs.insert (KExpr.const id levels info).addr) + (seenConsts.insert id.addr) methods I hfault lookupState + · simp only [ReaderT.run_bind] + exact TcM.WF.throw fun _ => trivial + · simp only [ReaderT.run_bind] + exact TcM.WF.throw fun _ => trivial + · simp only [ReaderT.run_bind] + exact TcM.WF.throw fun _ => trivial + · exact checkNoUnsafeRefs_go_frame callerSafety stack + (seenExprs.insert (KExpr.const id levels info).addr) + (seenConsts.insert id.addr) methods I hfault lookupState + | app fn arg info => + simp only [pure_bind] + exact checkNoUnsafeRefs_go_frame callerSafety + (arg :: fn :: stack) + (seenExprs.insert (KExpr.app fn arg info).addr) seenConsts + methods I hfault state + | lam name bi type body info => + simp only [pure_bind] + exact checkNoUnsafeRefs_go_frame callerSafety + (body :: type :: stack) + (seenExprs.insert (KExpr.lam name bi type body info).addr) + seenConsts methods I hfault state + | all name bi type body info => + simp only [pure_bind] + exact checkNoUnsafeRefs_go_frame callerSafety + (body :: type :: stack) + (seenExprs.insert (KExpr.all name bi type body info).addr) + seenConsts methods I hfault state + | letE name type value body nonDep info => + simp only [pure_bind] + exact checkNoUnsafeRefs_go_frame callerSafety + (body :: value :: type :: stack) + (seenExprs.insert + (KExpr.letE name type value body nonDep info).addr) + seenConsts methods I hfault state + | prj id field value info => + simp only [pure_bind] + exact checkNoUnsafeRefs_go_frame callerSafety (value :: stack) + (seenExprs.insert (KExpr.prj id field value info).addr) + seenConsts methods I hfault state +termination_by _ stack _ _ _ _ _ _ => exprWorkSize stack +decreasing_by + all_goals simp_all [exprWorkSize, KExpr.treeSize, KExpr.treeSize_pos] + all_goals try omega + +/-- Public safety-traversal frame in the exact shape used twice by the +definition branch of `checkConstMember`. -/ +theorem checkNoUnsafeRefs_frame + (root : KExpr .anon) (callerSafety : Ix.DefinitionSafety) + (methods : Methods .anon) (I : TcState .anon → Prop) + (hfault : TcM.LazyFaultPreserves I) (state : TcState .anon) : + TcM.WF I state ((checkNoUnsafeRefs root callerSafety).run methods) + (fun _ _ => True) := by + rw [RecM.checkNoUnsafeRefs_equation] + exact checkNoUnsafeRefs_go_frame callerSafety [root] {} {} methods I hfault + state + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/Scoped.lean b/Ix/Tc/Verify/Check/Scoped.lean new file mode 100644 index 000000000..f40b095bb --- /dev/null +++ b/Ix/Tc/Verify/Check/Scoped.lean @@ -0,0 +1,77 @@ +import Ix.Tc.Verify.Level +import Ix.Tc.Verify.Totalization + +/-! +# Successful well-scopedness validation + +`PendingDecl` deliberately permits raw, ill-scoped syntax. K3 therefore +cannot assume universe-parameter or de Bruijn bounds when it starts checking +a declaration: those facts have to be recovered from the successful +production `validateExprWellScoped` pass. + +This file first records the pure syntax predicate implemented by that pass. +The operational proof below it is kept separate from typing; in particular, +`Scoped` says nothing about applications being well typed or declarations +being admissible. +-/ + +namespace Ix.Tc + +namespace KUniv + +/-- Every positional universe parameter occurring in `u` is below `bound`. +This is the pure predicate decided by `validateUnivParamsSeen`; addresses are +irrelevant to the predicate itself. -/ +def Scoped (bound : Nat) : KUniv m → Prop + | .zero _ => True + | .succ u _ => u.Scoped bound + | .max a b _ | .imax a b _ => a.Scoped bound ∧ b.Scoped bound + | .param idx _ _ => idx.toNat < bound + +/-- Positional universe scoping is exactly Theory `VLevel.WF` after the +structure-preserving `toVLevel` translation. -/ +theorem scoped_iff_toVLevel_wf {u : KUniv m} {bound : Nat} : + u.Scoped bound ↔ u.toVLevel.WF bound := by + induction u with + | zero => rfl + | succ u _ ih => simpa [Scoped, toVLevel, Lean4Lean.VLevel.WF] using ih + | max a b _ iha ihb => + simp only [Scoped, toVLevel, Lean4Lean.VLevel.WF, iha, ihb] + | imax a b _ iha ihb => + simp only [Scoped, toVLevel, Lean4Lean.VLevel.WF, iha, ihb] + | param => rfl + +theorem Scoped.toVLevel_wf {u : KUniv m} {bound : Nat} + (h : u.Scoped bound) : u.toVLevel.WF bound := + scoped_iff_toVLevel_wf.mp h + +end KUniv + +namespace KExpr + +/-- The syntax-only portion of `validateExprWellScoped`. + +The depth is intentionally a `UInt64`, matching the production worklist and +its exact comparison. Constant arity and projection-head existence are +state/world obligations and are recorded separately by the operational +validator theorem; this predicate captures precisely the binder and universe +bounds needed to turn raw syntax into a Theory expression. Free variables +are leaves because the validator accepts them and the active local-context +relation is responsible for resolving them. -/ +def Scoped (depth : UInt64) (levelBound : Nat) : KExpr m → Prop + | .var idx _ _ => idx < depth + | .fvar .. => True + | .sort u _ => u.Scoped levelBound + | .const _ us _ => ∀ u ∈ us, u.Scoped levelBound + | .app f a _ => f.Scoped depth levelBound ∧ a.Scoped depth levelBound + | .lam _ _ ty body _ | .all _ _ ty body _ => + ty.Scoped depth levelBound ∧ body.Scoped (depth + 1) levelBound + | .letE _ ty val body _ _ => + ty.Scoped depth levelBound ∧ val.Scoped depth levelBound ∧ + body.Scoped (depth + 1) levelBound + | .prj _ _ val _ => val.Scoped depth levelBound + | .nat .. | .str .. => True + +end KExpr + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/ScopedBoundedPipelines.lean b/Ix/Tc/Verify/Check/ScopedBoundedPipelines.lean new file mode 100644 index 000000000..ffdb5cf89 --- /dev/null +++ b/Ix/Tc/Verify/Check/ScopedBoundedPipelines.lean @@ -0,0 +1,410 @@ +import Ix.Tc.Verify.Check.BoundedPipelines +import Ix.Tc.Verify.RecursiveMethods.ScopedCallDomains + +/-! +# Run-scoped standalone-checker pipelines + +This is K3's bounded type/value pipeline with `StateInScope` retained across +every method callback. It deliberately consumes `Methods.ScopedWFAtOn` +directly and contains no conversion to the legacy global suffix model. +-/ + +namespace Ix.Tc + +namespace Methods + +/-- Strong full inference over one bounded call domain and one finite suffix +state domain. -/ +def ScopedFullInferenceWFAtOn + {trProj : RawProjRel} {world : VerifyWorld} + (model : ScopedKernelSuffixModel trProj world) + (support : RunSupport) (calls : CallDomain) (methods : Methods .anon) : + Prop := + ∀ {Delta : KVLCtx} {s : TcState .anon} + {source : KExpr .anon} {sourceV : Lean4Lean.VExpr}, + calls.infer source → + s.inferOnly = false → + PreTrKExprS world.venv model.keys.uvars world.nameOf trProj Delta source + sourceV → + TcM.WF + (ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) support Delta) s + (methods.infer source) + (fun result after => + after.inferOnly = false ∧ + FullInferPost trProj world support model.keys.uvars Delta source + sourceV result) + (fun _ after => after.inferOnly = false) + +namespace ScopedFullInferenceWFAtOn + +/-- Ordinary scoped inference upgrades to the K3 contract wherever raw +ingress is intrinsically typed. -/ +theorem ofTypedIngress + {trProj : RawProjRel} {world : VerifyWorld} + {model : ScopedKernelSuffixModel trProj world} + {support : RunSupport} {calls : CallDomain} {methods : Methods .anon} + (semantic : Methods.ScopedWFAtOn model .noAccel + (kernelCacheSemantics model.keys trProj) support calls methods) + (policy : methods.PreservesInferOnly) + (upgrade : ∀ {Delta : KVLCtx} {source : KExpr .anon} + {sourceV : Lean4Lean.VExpr}, + calls.infer source → + PreTrKExprS world.venv model.keys.uvars world.nameOf trProj Delta source + sourceV → + TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta source + sourceV) : + Methods.ScopedFullInferenceWFAtOn model support calls methods := by + intro Delta s source sourceV hcall hbefore hsource + have htyped := upgrade hcall hsource + apply TcM.WF.mono + (TcM.PreservesInferOnly.strengthenWFValue + (semantic.infer hcall htyped) (policy.infer source) hbefore) + · intro _ _ post + exact ⟨post.1, FullInferPost.of_typed htyped post.2⟩ + · intro _ _ post + exact post.1 + +/-- A singleton sort domain is intrinsically typed. -/ +theorem ofSingletonSort + {trProj : RawProjRel} {world : VerifyWorld} + {model : ScopedKernelSuffixModel trProj world} + {support : RunSupport} {u : KUniv .anon} {info : ExprInfo .anon} + {methods : Methods .anon} + (semantic : Methods.ScopedWFAtOn model .noAccel + (kernelCacheSemantics model.keys trProj) support + (.singletonInfer (.sort u info)) methods) + (policy : methods.PreservesInferOnly) : + Methods.ScopedFullInferenceWFAtOn model support + (.singletonInfer (.sort u info)) methods := by + apply ofTypedIngress semantic policy + intro Delta source sourceV hcall hsource + change source = .sort u info at hcall + subst source + cases hsource with + | sort hu => exact .sort hu + +end ScopedFullInferenceWFAtOn + +end Methods + +/-- Declaration-local K3 resources whose method contracts preserve the +finite suffix-state witness. -/ +structure ScopedStandalonePipelineResources + {trProj : RawProjRel} {world : VerifyWorld} + (model : ScopedKernelSuffixModel trProj world) + (support : RunSupport) (calls : Methods.CallDomain) + (methods : Methods .anon) : Type where + fullInference : Methods.ScopedFullInferenceWFAtOn model support calls + (Methods.next methods) + sorts : SortComponentResources support + typeSources : KExpr .anon → Prop + valueSources : KExpr .anon → KExpr .anon → Prop + typeInfer : ∀ {source}, typeSources source → calls.infer source + valueInfer : ∀ {value declaredType}, + valueSources value declaredType → calls.infer value + typeWhnf : ∀ {Delta : KVLCtx} {source : KExpr .anon} + {sourceV : Lean4Lean.VExpr} {inferred : KExpr .anon}, + typeSources source → + FullInferPost trProj world support model.keys.uvars Delta source sourceV + inferred → + calls.AdmitsEnsureSortDirect inferred + valueDefEq : ∀ {Delta : KVLCtx} {value declaredType : KExpr .anon} + {valueV : Lean4Lean.VExpr} {inferred : KExpr .anon}, + valueSources value declaredType → + FullInferPost trProj world support model.keys.uvars Delta value valueV + inferred → + calls.isDefEq inferred declaredType + +namespace ScopedStandalonePipelineResources + +inductive Covers + {trProj : RawProjRel} {world : VerifyWorld} + {model : ScopedKernelSuffixModel trProj world} + {support : RunSupport} {calls : Methods.CallDomain} + {methods : Methods .anon} + (resources : ScopedStandalonePipelineResources model support calls + methods) : KConst .anon → Prop + | axiom + {name : Mode.anon.F Name} {levelParams : Mode.anon.F (Array Name)} + {isUnsafe : Bool} {levels : UInt64} {type : KExpr .anon} : + resources.typeSources type → + Covers resources (.axio name levelParams isUnsafe levels type) + | defn + {name : Mode.anon.F Name} {levelParams : Mode.anon.F (Array Name)} + {kind : Ix.DefKind} {safety : Ix.DefinitionSafety} + {hints : Lean.ReducibilityHints} {levels : UInt64} + {type value : KExpr .anon} + {leanAll : Mode.anon.F (Array (KId .anon))} {block : KId .anon} : + resources.typeSources type → + resources.valueSources value type → + Covers resources + (.defn name levelParams kind safety hints levels type value leanAll + block) + +/-- Exact scoped resources for a concrete sort axiom. -/ +def singletonSortAxiom + {trProj : RawProjRel} {world : VerifyWorld} + {model : ScopedKernelSuffixModel trProj world} + {support : RunSupport} {u : KUniv .anon} {info : ExprInfo .anon} + {methods : Methods .anon} + (hfull : Methods.ScopedFullInferenceWFAtOn model support + (.singletonInfer (.sort u info)) (Methods.next methods)) + (hsorts : SortComponentResources support) + (hresults : ∀ {result : KExpr .anon}, support result → + ∃ resultUniv resultInfo, result = .sort resultUniv resultInfo) : + ScopedStandalonePipelineResources model support + (.singletonInfer (.sort u info)) methods where + fullInference := hfull + sorts := hsorts + typeSources := fun source => source = .sort u info + valueSources := fun _ _ => False + typeInfer hsource := hsource + valueInfer hsource := False.elim hsource + typeWhnf := by + intro Delta source sourceV inferred hsource hpost + obtain ⟨resultUniv, resultInfo, rfl⟩ := hresults hpost.1 + trivial + valueDefEq hsource := False.elim hsource + +end ScopedStandalonePipelineResources + +namespace RecM + +private theorem ensureSortDirect_scopedWFAtOn + {trProj : RawProjRel} {world : VerifyWorld} + {model : ScopedKernelSuffixModel trProj world} + {support : RunSupport} {calls : Methods.CallDomain} + {methods : Methods .anon} {Delta : KVLCtx} {s : TcState .anon} + {input : KExpr .anon} {inputV : Lean4Lean.VExpr} + (hmethods : Methods.ScopedWFAtOn model .noAccel + (kernelCacheSemantics model.keys trProj) support calls + (Methods.next methods)) + (hresources : SortComponentResources support) + (hcall : calls.AdmitsEnsureSortDirect input) + (hinputSupport : support input) + (hinput : TrKExpr world.venv model.keys.uvars world.nameOf trProj Delta + input inputV) : + TcM.WF + (ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) support Delta) s + ((ensureSortDirect input).run methods) + (fun result _ => SortView world support model.keys.uvars Delta inputV + result) := by + obtain ⟨inputCoreV, hinputCore, hinputEq⟩ := hinput + cases input <;> simp only [ensureSortDirect, ReaderT.run_pure, pure_bind] + case sort result info => + apply TcM.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 + have hwhnf := hmethods.whnf (s := s) hcall hinputCore + simp only [Methods.next] at hwhnf + unfold ensureSortWhnf + simp only [ReaderT.run_bind] + apply TcM.WF.bind hwhnf + 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 TcM.WF.pure fun hI => + { sizeBound := hsize + subtermSupport := hsubterms + levelWF := hlevel + inputEq := hinputEq.symm.trans world.venvWF + hI.1.2.1.wf.toCtx hcoreReduced } + all_goals + exact TcM.WF.throw fun _ => trivial + +theorem checkTypePipeline_scoped_sound + {trProj : RawProjRel} {world : VerifyWorld} + {model : ScopedKernelSuffixModel trProj world} + {support : RunSupport} {calls : Methods.CallDomain} + {methods : Methods .anon} + (resources : ScopedStandalonePipelineResources model support calls + methods) + (hmethods : Methods.ScopedWFAtOn model .noAccel + (kernelCacheSemantics model.keys trProj) support calls + (Methods.next methods)) + (hpolicyMethods : (Methods.next methods).PreservesInferOnly) + {Delta : KVLCtx} {s after : TcState .anon} + {source : KExpr .anon} {sourceV : Lean4Lean.VExpr} + (hsourceCall : resources.typeSources source) + (hsource : PreTrKExprS world.venv model.keys.uvars world.nameOf trProj + Delta source sourceV) + (hpolicy : s.inferOnly = false) + (hI : ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) support Delta s) + (hrun : + ((do + let inferred ← infer source + let _ ← ensureSortDirect inferred).run methods) s = .ok () after) : + ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) support Delta after ∧ + after.inferOnly = false ∧ + TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta source + sourceV ∧ + TypeCheckEvidence trProj world support model.keys.uvars Delta + sourceV := by + have hinfer : TcM.WF + (ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) support Delta) s + ((infer source).run methods) + (fun result after => after.inferOnly = false ∧ + FullInferPost trProj world support model.keys.uvars Delta source + sourceV result) + (fun _ after => after.inferOnly = false) := by + simpa [Methods.next] using + resources.fullInference (resources.typeInfer hsourceCall) hpolicy hsource + have hpipeline : TcM.WF + (ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) support Delta) s + ((do + let inferred ← infer source + let _ ← ensureSortDirect inferred).run methods) + (fun _ after => after.inferOnly = false ∧ + TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta source + sourceV ∧ + TypeCheckEvidence trProj world support model.keys.uvars Delta + sourceV) + (fun _ after => after.inferOnly = false) := by + simp only [ReaderT.run_bind, ReaderT.run_pure] + apply TcM.WF.bind hinfer + intro inferred afterInfer hinferred + rcases hinferred with + ⟨hpolicyAfter, hinferredSupport, hsourceTr, inferredV, + hinferredTr, hsourceType⟩ + have hfull : FullInferPost trProj world support model.keys.uvars Delta + source sourceV inferred := + ⟨hinferredSupport, hsourceTr, inferredV, hinferredTr, hsourceType⟩ + have hsortSemantic := ensureSortDirect_scopedWFAtOn (s := afterInfer) + hmethods resources.sorts (resources.typeWhnf hsourceCall hfull) + hinferredSupport hinferredTr + have hwhnfPolicy : ∀ candidate, + ((whnf candidate).run methods).PreservesInferOnly := by + intro candidate + simpa [Methods.next] using hpolicyMethods.whnf candidate + have hsort : TcM.WF + (ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) support Delta) + afterInfer ((ensureSortDirect inferred).run methods) + (fun result after => after.inferOnly = false ∧ + SortView world support model.keys.uvars Delta inferredV result) + (fun _ after => after.inferOnly = false) := by + apply TcM.WF.mono + (TcM.PreservesInferOnly.strengthenWFValue hsortSemantic + (ensureSortDirect_preservesInferOnly hwhnfPolicy) hpolicyAfter) + · intro _ _ post + exact post + · intro _ _ post + exact post.1 + apply TcM.WF.bind hsort + intro sort _ hsortPost + exact TcM.WF.pure fun _ => + ⟨hsortPost.1, hsourceTr, inferred, inferredV, hinferredTr, + hsourceType, sort, hsortPost.2⟩ + have hpost := hpipeline hI + rw [hrun] at hpost + exact hpost + +theorem checkValuePipeline_scoped_sound + {trProj : RawProjRel} {world : VerifyWorld} + {model : ScopedKernelSuffixModel trProj world} + {support : RunSupport} {calls : Methods.CallDomain} + {methods : Methods .anon} + (resources : ScopedStandalonePipelineResources model support calls + methods) + (hmethods : Methods.ScopedWFAtOn model .noAccel + (kernelCacheSemantics model.keys trProj) support calls + (Methods.next methods)) + {Delta : KVLCtx} {s after : TcState .anon} + {value declaredType : KExpr .anon} + {valueV declaredTypeV : Lean4Lean.VExpr} + (hvalueCall : resources.valueSources value declaredType) + (hvalue : PreTrKExprS world.venv model.keys.uvars world.nameOf trProj + Delta value valueV) + (hdeclared : TrKExprS world.venv model.keys.uvars world.nameOf trProj + Delta declaredType declaredTypeV) + (hpolicy : s.inferOnly = false) + (hI : ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) support Delta s) + (hrun : + ((do + let inferredType ← infer value + if !(← isDefEq inferredType declaredType) then + throw TcError.declTypeMismatch).run methods) s = .ok () after) : + ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) support Delta after ∧ + ValueCheckEvidence world model.keys.uvars Delta valueV + declaredTypeV := by + have hinfer : TcM.WF + (ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) support Delta) s + ((infer value).run methods) + (fun result after => after.inferOnly = false ∧ + FullInferPost trProj world support model.keys.uvars Delta value valueV + result) + (fun _ after => after.inferOnly = false) := by + simpa [Methods.next] using + resources.fullInference (resources.valueInfer hvalueCall) hpolicy hvalue + have hpipeline : TcM.WF + (ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) support Delta) s + ((do + let inferredType ← infer value + if !(← isDefEq inferredType declaredType) then + throw TcError.declTypeMismatch).run methods) + (fun _ _ => ValueCheckEvidence world model.keys.uvars Delta valueV + declaredTypeV) := by + simp only [ReaderT.run_bind] + apply TcM.WF.bind + (TcM.WF.mono hinfer (fun _ _ post => post) + (fun _ _ _ => by trivial)) + intro inferredType afterInfer hinferred + rcases hinferred with + ⟨_hpolicyAfter, hinferredSupport, hvalueTr, inferredTypeV, + hinferredTr, hvalueType⟩ + have hfull : FullInferPost trProj world support model.keys.uvars Delta + value valueV inferredType := + ⟨hinferredSupport, hvalueTr, inferredTypeV, hinferredTr, hvalueType⟩ + obtain ⟨inferredCoreV, hinferredCore, hcoreEq⟩ := hinferredTr + have hdefeq : TcM.WF + (ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) support Delta) + afterInfer ((isDefEq inferredType declaredType).run methods) + (fun answer _ => answer = true → + world.venv.IsDefEqU model.keys.uvars Delta.toCtx inferredCoreV + declaredTypeV) := by + simpa [Methods.next] using + hmethods.isDefEq (resources.valueDefEq hvalueCall hfull) + hinferredCore hdeclared + apply TcM.WF.bind hdefeq + intro answer _ heq + cases answer with + | false => + simp only [Bool.not_false, if_true] + exact TcM.WF.throw fun _ => trivial + | true => + simp only [Bool.not_true, Bool.false_eq] + exact TcM.WF.pure fun hI => + ⟨inferredCoreV, + hvalueType.defeqU_r world.venvWF hI.1.2.1.wf.toCtx hcoreEq.symm, + heq rfl⟩ + have hpost := hpipeline hI + rw [hrun] at hpost + exact hpost + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/ScopedMemberEvidence.lean b/Ix/Tc/Verify/Check/ScopedMemberEvidence.lean new file mode 100644 index 000000000..d30735c47 --- /dev/null +++ b/Ix/Tc/Verify/Check/ScopedMemberEvidence.lean @@ -0,0 +1,419 @@ +import Ix.Tc.Verify.Check.MemberEvidence +import Ix.Tc.Verify.Check.ScopedBoundedPipelines +import Ix.Tc.Verify.Check.SafetyFrame + +/-! +# Run-scoped evidence from standalone member checking + +The production trace decomposition mirrors `MemberEvidence`, but every +validator, inference, DefEq, and safety-traversal state retains the finite +suffix-model domain. The semantic promotion is ghost-only, so the final +state carries the original model's `StateInScope` witness alongside the +rebased checker invariant. +-/ + +namespace Ix.Tc + +namespace RecM + +private theorem scopedRunTcBind {a b : Type} + (x : TcM .anon a) (k : a → TcM .anon b) + (state : TcState .anon) : + (x >>= k) state = match x state with + | .ok value after => k value after + | .error err after => .error err after := by + show EStateM.bind x k state = _ + unfold EStateM.bind + cases x state <;> rfl + +private theorem scopedRunInferEnsureSort + (source : KExpr .anon) (methods : Methods .anon) + {before afterInfer after : TcState .anon} + {inferred : KExpr .anon} {sort : KUniv .anon} + (hinfer : (infer source).run methods before = .ok inferred afterInfer) + (hsort : (ensureSortDirect inferred).run methods afterInfer = + .ok sort after) : + ((do + let inferred ← infer source + let _ ← ensureSortDirect inferred).run methods) before = + .ok () after := by + simp only [ReaderT.run_bind] + change EStateM.bind ((infer source).run methods) _ before = _ + unfold EStateM.bind + rw [hinfer] + change EStateM.map _ ((ensureSortDirect inferred).run methods) afterInfer = _ + unfold EStateM.map + rw [hsort] + +private theorem scopedRunInferDefEqTrue + (value declaredType : KExpr .anon) (methods : Methods .anon) + {before afterInfer after : TcState .anon} + {inferredType : KExpr .anon} + (hinfer : (infer value).run methods before = .ok inferredType afterInfer) + (hdefeq : (isDefEq inferredType declaredType).run methods afterInfer = + .ok true after) : + ((do + let inferredType ← infer value + if !(← isDefEq inferredType declaredType) then + throw TcError.declTypeMismatch).run methods) before = .ok () after := by + simp only [ReaderT.run_bind] + change EStateM.bind ((infer value).run methods) _ before = _ + unfold EStateM.bind + rw [hinfer] + change EStateM.bind ((isDefEq inferredType declaredType).run methods) _ + afterInfer = _ + unfold EStateM.bind + rw [hdefeq] + rfl + +theorem checkConstMember_axiom_scoped_sound + {trProj : RawProjRel} {world : VerifyWorld} + {model : ScopedKernelSuffixModel trProj world} + {support : RunSupport} {calls : Methods.CallDomain} + {methods : Methods .anon} + (context : ScopedStandalonePipelineResources model support calls methods) + (hmethods : Methods.ScopedWFAtOn model .noAccel + (kernelCacheSemantics model.keys trProj) support calls + (Methods.next methods)) + (hmethodPolicy : (Methods.next methods).PreservesInferOnly) + {id : KId .anon} {name : Mode.anon.F Name} + {levelParams : Mode.anon.F (Array Name)} {isUnsafe : Bool} + {levels : UInt64} {type : KExpr .anon} + {typeV : Lean4Lean.VExpr} + (hresources : StandaloneValidationResources support + (.axio name levelParams isUnsafe levels type)) + (hsourceCall : context.typeSources type) + (hsource : PreTrKExprS world.venv levels.toNat world.nameOf trProj + [] type typeV) + (huvars : model.keys.uvars = levels.toNat) + {state after : TcState .anon} + (hpolicy : state.inferOnly = false) + (hI : ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) support [] state) + (hfault : TcM.LazyFaultPreserves + (ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) support [])) + (hrun : + (checkConstMember id (.axio name levelParams isUnsafe levels type)).run + methods state = .ok () after) : + ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) support [] after ∧ + after.inferOnly = false ∧ + TrKExprS world.venv levels.toNat world.nameOf trProj [] type typeV ∧ + TypeCheckEvidence trProj world support levels.toNat [] typeV := by + have hframe := validateConstWellScoped_frame hresources methods + (hfault.withInferOnly false) state ⟨hI, hpolicy⟩ + unfold checkConstMember at hrun + simp only [Mode.F.hasDups, Bool.false_eq_true, if_false, + ReaderT.run_bind, pure_bind] at hrun + cases hvalidation : + (validateConstWellScoped + (.axio name levelParams isUnsafe levels type)).run methods state with + | error err failed => + rw [scopedRunTcBind, hvalidation] at hrun + contradiction + | ok validationValue afterValidation => + rw [scopedRunTcBind, hvalidation] at hrun + have hIValidation : ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) support [] + afterValidation := by + rw [hvalidation] at hframe + exact hframe.1.1 + have hpolicyValidation : afterValidation.inferOnly = false := by + rw [hvalidation] at hframe + exact hframe.1.2 + have hsource' : PreTrKExprS world.venv model.keys.uvars world.nameOf + trProj [] type typeV := by + simpa [huvars] using hsource + have hpipeline := checkTypePipeline_scoped_sound context hmethods + hmethodPolicy hsourceCall hsource' hpolicyValidation hIValidation hrun + simpa [huvars] using hpipeline + +theorem checkConstMember_defn_scoped_sound + {trProj : RawProjRel} {world : VerifyWorld} + {model : ScopedKernelSuffixModel trProj world} + {support : RunSupport} {calls : Methods.CallDomain} + {methods : Methods .anon} + (context : ScopedStandalonePipelineResources model support calls methods) + (hmethods : Methods.ScopedWFAtOn model .noAccel + (kernelCacheSemantics model.keys trProj) support calls + (Methods.next methods)) + (hmethodPolicy : (Methods.next methods).PreservesInferOnly) + {id : KId .anon} {name : Mode.anon.F Name} + {levelParams : Mode.anon.F (Array Name)} {kind : Ix.DefKind} + {safety : Ix.DefinitionSafety} {hints : Lean.ReducibilityHints} + {levels : UInt64} {type value : KExpr .anon} + {leanAll : Mode.anon.F (Array (KId .anon))} {block : KId .anon} + {typeV valueV : Lean4Lean.VExpr} + (hresources : StandaloneValidationResources support + (.defn name levelParams kind safety hints levels type value leanAll + block)) + (htypeCall : context.typeSources type) + (hvalueCall : context.valueSources value type) + (htype : PreTrKExprS world.venv levels.toNat world.nameOf trProj + [] type typeV) + (hvalue : PreTrKExprS world.venv levels.toNat world.nameOf trProj + [] value valueV) + (huvars : model.keys.uvars = levels.toNat) + {state after : TcState .anon} + (hpolicy : state.inferOnly = false) + (hI : ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) support [] state) + (hfault : TcM.LazyFaultPreserves + (ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) support [])) + (hrun : + (checkConstMember id + (.defn name levelParams kind safety hints levels type value leanAll + block)).run methods state = .ok () after) : + ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) support [] after ∧ + TypeCheckEvidence trProj world support levels.toNat [] typeV ∧ + ValueCheckEvidence world levels.toNat [] valueV typeV := by + have hframe := validateConstWellScoped_frame hresources methods + (hfault.withInferOnly false) state ⟨hI, hpolicy⟩ + unfold checkConstMember at hrun + simp only [Mode.F.hasDups, Bool.false_eq_true, if_false, + ReaderT.run_bind, pure_bind] at hrun + cases hvalidation : + (validateConstWellScoped + (.defn name levelParams kind safety hints levels type value leanAll + block)).run methods state with + | error err failed => + simp only [scopedRunTcBind, hvalidation] at hrun + contradiction + | ok validationValue afterValidation => + simp only [scopedRunTcBind, hvalidation] at hrun + have hIValidation : ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) support [] + afterValidation := by + rw [hvalidation] at hframe + exact hframe.1.1 + have hpolicyValidation : afterValidation.inferOnly = false := by + rw [hvalidation] at hframe + exact hframe.1.2 + have htype' : PreTrKExprS world.venv model.keys.uvars world.nameOf + trProj [] type typeV := by + simpa [huvars] using htype + have hvalue' : PreTrKExprS world.venv model.keys.uvars world.nameOf + trProj [] value valueV := by + simpa [huvars] using hvalue + cases hinferType : (infer type).run methods afterValidation with + | error err failed => + simp only [hinferType] at hrun + contradiction + | ok inferred afterInferType => + simp only [hinferType] at hrun + cases hsort : (ensureSortDirect inferred).run methods afterInferType with + | error err failed => + simp only [hsort] at hrun + contradiction + | ok level afterType => + simp only [hsort] at hrun + have htypePipeline : + ((do + let inferred ← infer type + let _ ← ensureSortDirect inferred).run methods) + afterValidation = .ok () afterType := + scopedRunInferEnsureSort type methods hinferType hsort + have htypePost := checkTypePipeline_scoped_sound context + hmethods hmethodPolicy htypeCall htype' hpolicyValidation + hIValidation htypePipeline + have hIType := htypePost.1 + have hpolicyType := htypePost.2.1 + have htypeTr := htypePost.2.2.1 + have htypeEvidence := htypePost.2.2.2 + by_cases htheorem : kind == .thm && !univEq level .mkZero + · simp only [htheorem, if_true] at hrun + contradiction + · simp only [htheorem, Bool.false_eq_true, if_false, + ReaderT.run_bind] at hrun + cases hinferValue : (infer value).run methods afterType with + | error err failed => + simp only [scopedRunTcBind, hinferValue] at hrun + contradiction + | ok inferredType afterInferValue => + simp only [scopedRunTcBind, hinferValue] at hrun + cases hanswer : + (isDefEq inferredType type).run methods afterInferValue with + | error err failed => + simp only [hanswer] at hrun + contradiction + | ok answer afterDefEq => + simp only [hanswer] at hrun + cases answer with + | false => + simp only [Bool.not_false, if_true] at hrun + contradiction + | true => + have hvaluePipeline : + ((do + let inferredType ← infer value + if !(← isDefEq inferredType type) then + throw TcError.declTypeMismatch).run methods) + afterType = .ok () afterDefEq := + scopedRunInferDefEqTrue value type methods + hinferValue hanswer + have hvaluePost := + checkValuePipeline_scoped_sound context hmethods + hvalueCall hvalue' htypeTr hpolicyType hIType + hvaluePipeline + have hIDefEq := hvaluePost.1 + have hvalueEvidence := hvaluePost.2 + by_cases hsafety : safety != .unsaf + · simp only [Bool.not_true, Bool.false_eq_true, + if_false] at hrun + simp only [hsafety, if_true, + ReaderT.run_bind] at hrun + cases htypeSafety : + (checkNoUnsafeRefs type safety).run methods + afterDefEq with + | error err failed => + rw [scopedRunTcBind, htypeSafety] at hrun + contradiction + | ok typeSafetyValue afterTypeSafety => + rw [scopedRunTcBind, htypeSafety] at hrun + have htypePost := + checkNoUnsafeRefs_frame type safety methods + (ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys + trProj) support []) + hfault afterDefEq hIDefEq + rw [htypeSafety] at htypePost + cases hvalueSafety : + (checkNoUnsafeRefs value safety).run + methods afterTypeSafety with + | error err failed => + simp only [hvalueSafety] at hrun + contradiction + | ok valueSafetyValue afterValueSafety => + simp only [hvalueSafety] at hrun + cases hrun + have hvalueSafetyPost := + checkNoUnsafeRefs_frame value safety + methods + (ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys + trProj) support []) + hfault afterTypeSafety htypePost.1 + rw [hvalueSafety] at hvalueSafetyPost + exact ⟨hvalueSafetyPost.1, + by simpa [huvars] using htypeEvidence, + by simpa [huvars] using hvalueEvidence⟩ + · simp only [Bool.not_true, Bool.false_eq_true, + if_false] at hrun + simp only [hsafety] at hrun + cases hrun + exact ⟨hIDefEq, + by simpa [huvars] using htypeEvidence, + by simpa [huvars] using hvalueEvidence⟩ + +theorem checkConstMember_scoped_sound + {trProj : RawProjRel} {world : VerifyWorld} + {model : ScopedKernelSuffixModel trProj world} + {support : RunSupport} {calls : Methods.CallDomain} + {methods : Methods .anon} + (context : ScopedStandalonePipelineResources model support calls methods) + (hmethods : Methods.ScopedWFAtOn model .noAccel + (kernelCacheSemantics model.keys trProj) support calls + (Methods.next methods)) + (hmethodPolicy : (Methods.next methods).PreservesInferOnly) + {id : KId .anon} {concrete : KConst .anon} + {decl : Lean4Lean.VDecl} + (hingress : PreDeclRel world.venv world.nameOf trProj id concrete decl) + (hcovers : context.Covers concrete) + (hresources : StandaloneValidationResources support concrete) + (huvars : model.keys.uvars = concrete.lvls.toNat) + {state after : TcState .anon} + (hpolicy : state.inferOnly = false) + (hI : ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) support [] state) + (hfault : TcM.LazyFaultPreserves + (ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) support [])) + (hrun : (checkConstMember id concrete).run methods state = + .ok () after) : + ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) support [] after ∧ + StandaloneCheckEvidence trProj world support decl := by + cases hingress with + | @«axiom» name levelParams isUnsafe levels type theoryName typeV _ htype => + cases hresources with + | «axiom» hcoverage hsize => + cases hcovers with + | «axiom» htypeCall => + have hresult := checkConstMember_axiom_scoped_sound context + hmethods hmethodPolicy (.axiom hcoverage hsize) htypeCall + htype huvars hpolicy hI hfault hrun + exact ⟨hresult.1, .axiom hresult.2.2.2⟩ + | @defn name levelParams kind safety hints levels type value leanAll block + theoryName typeV valueV decl _ htype hvalue hkind => + cases hresources with + | defn htypeCoverage htypeSize hvalueCoverage hvalueSize => + cases hcovers with + | defn htypeCall hvalueCall => + have hevidence := checkConstMember_defn_scoped_sound context + hmethods hmethodPolicy + (.defn htypeCoverage htypeSize hvalueCoverage hvalueSize) + htypeCall hvalueCall htype hvalue huvars hpolicy hI hfault hrun + cases hkind with + | defn => + exact ⟨hevidence.1, .defn hevidence.2.1 hevidence.2.2⟩ + | opaq => + exact ⟨hevidence.1, .opaque hevidence.2.1 hevidence.2.2⟩ + | thm => + exact ⟨hevidence.1, .opaque hevidence.2.1 hevidence.2.2⟩ + +/-- End-to-end scoped member theorem, including ghost-only promotion. -/ +theorem checkConstMember_scoped_pending_sound + {trProj : RawProjRel} {world : VerifyWorld} + {model : ScopedKernelSuffixModel trProj world} + {support : RunSupport} {calls : Methods.CallDomain} + {methods : Methods .anon} + (context : ScopedStandalonePipelineResources model support calls methods) + (hmethods : Methods.ScopedWFAtOn model .noAccel + (kernelCacheSemantics model.keys trProj) support calls + (Methods.next methods)) + (hmethodPolicy : (Methods.next methods).PreservesInferOnly) + {id : KId .anon} {concrete : KConst .anon} + {decl : Lean4Lean.VDecl} + (hprojection : trProj.SubstCompatible) + (hliterals : ∀ literal, world.venv.ContainsLits literal) + (hpending : PendingDecl trProj world id decl) + (hcatalog : world.catalog id = some concrete) + (hresources : StandaloneValidationResources support concrete) + (hcovers : context.Covers concrete) + (hcollision : support.CollisionFree) + (huvars : model.keys.uvars = concrete.lvls.toNat) + {state after : TcState .anon} + (hpolicy : state.inferOnly = false) + (hI : ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) support [] state) + (hfault : TcM.LazyFaultPreserves + (ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) support [])) + (hrun : (checkConstMember id concrete).run methods state = + .ok () after) : + StandaloneCheckResult trProj world support id concrete decl ∧ + ∃ world', + Promotes world (fun target => target = id) world' ∧ + WhnfStateInv .noAccel + (kernelCacheSemantics model.keys trProj) trProj world' support + model.keys.uvars [] after ∧ + model.StateInScope after ∧ + TrustedDecl trProj world' id decl := by + obtain ⟨afterValidation, hvalidation⟩ := + checkConstMember_validation_success hresources hrun + have hingress := hpending.toPre_of_validation hprojection hliterals hcatalog + hresources hcollision hvalidation + have hevidence := checkConstMember_scoped_sound context hmethods + hmethodPolicy hingress hcovers hresources huvars hpolicy hI hfault hrun + obtain ⟨world', hpromotes, hcore, htrusted⟩ := + PendingDecl.promoteOfAccepted hevidence.1.1.1.core hpending + hevidence.2.accepted + exact ⟨⟨hingress, hevidence.2⟩, world', hpromotes, + hevidence.1.1.rebaseWorld hpromotes.1 hcore, hevidence.1.2, htrusted⟩ + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/ScopedPositiveFuelAxiom.lean b/Ix/Tc/Verify/Check/ScopedPositiveFuelAxiom.lean new file mode 100644 index 000000000..61a8174c7 --- /dev/null +++ b/Ix/Tc/Verify/Check/ScopedPositiveFuelAxiom.lean @@ -0,0 +1,490 @@ +import Ix.Tc.Verify.Check.PositiveFuelSort +import Ix.Tc.Verify.Check.PublicStandalone + +/-! +# Executed positive-fuel checker over a finite suffix model + +This fixture checks one eagerly loaded, pending sort axiom with recursion fuel +one. The production suffix model is the constructive singleton model for +closed eager states; the method schedule admits exactly the one sort +inference performed by the checker. +-/ + +namespace Ix.Tc.PositiveFuelSort.Checker + +open PositiveFuelSort + +def targetAddress : Address := + ⟨⟨Array.replicate 32 (37 : UInt8)⟩⟩ + +def targetId : KId .anon := ⟨targetAddress, ()⟩ +def targetName : Lean.Name := `Ix.Tc.Verify.positiveFuelSortAxiom + +def catalog : Catalog := fun id => + if id == targetId then some concreteAxiom else none + +@[simp] theorem catalog_target : catalog targetId = some concreteAxiom := by + simp [catalog] + +def world : VerifyWorld where + catalog := catalog + trusted := fun _ => False + venv := .empty + nameOf := fun addr => + if addr == targetAddress then some targetName else none + venvWF := ⟨[], .empty⟩ + trustedCatalogued := fun {_} h => False.elim h + +@[simp] theorem world_nameOf_target : + world.nameOf targetId.addr = some targetName := by + simp [world, targetId] + +def declaration : Lean4Lean.VDecl := + .axiom { name := targetName, uvars := 0, type := .sort .zero } + +theorem rawDeclaration : + RawDeclRel world.venv world.nameOf RawProjRel.none targetId + concreteAxiom declaration := by + apply RawDeclRel.axiom world_nameOf_target + exact .sort + +theorem pending : + PendingDecl RawProjRel.none world targetId declaration := by + refine ⟨concreteAxiom, catalog_target, rawDeclaration, ?_, ?_, ?_⟩ + · exact fun h => h + · intro id href + change source.References id at href + obtain ⟨u, info, hsource⟩ := supported_is_sort source_supported + rw [hsource] at href + simp [KExpr.References] at href + · intro name hname + change Lean4Lean.VEnv.empty.constants name = none + rfl + +def env : KEnv .anon := + ({} : KEnv .anon).insert targetId concreteAxiom + +/-- Positive recursion fuel is preserved by the per-constant reset because +the fixture's fuel budget is also one. -/ +def initialState : TcState .anon := + { TcState.ofEnvAnon env with + noAccel := true + recFuel := 1 + fuelBudget := 1 } + +theorem initialState_closed : ClosedContextState initialState := by + constructor <;> rfl + +theorem initialState_reset : + TcM.reset initialState = .ok () initialState := by + rfl + +theorem trustedCatalog : TrustedCatalogRel RawProjRel.none world := + TrustedCatalogLog.empty + +theorem loadedAgreement : LoadedAgrees world.catalog env := by + apply LoadedAgrees.insert (LoadedAgrees.empty world.catalog) + exact catalog_target + +theorem initialState_core : + TcStateWF RawProjRel.none initialState world := + ⟨trustedCatalog, loadedAgreement, InternTable.WF.empty⟩ + +def model : ScopedKernelSuffixModel RawProjRel.none world := + ClosedContextDigest.model RawProjRel.none world 0 + +theorem initialState_kernel : + KernelStateWF (kernelCacheSemantics model.keys RawProjRel.none) + RawProjRel.none world support initialState := by + apply KernelStateWF.of_no_cache_entries initialState_core + · constructor + · intro candidate hcandidate + obtain ⟨addr, haddr⟩ := hcandidate + simp [initialState, env, KEnv.insert, TcState.ofEnvAnon] at haddr + · intro candidate hcandidate + obtain ⟨addr, haddr⟩ := hcandidate + simp [initialState, env, KEnv.insert, TcState.ofEnvAnon] at haddr + · rfl + · intro entry hentry + cases hentry <;> + simp [initialState, env, KEnv.insert, TcState.ofEnvAnon] at * + +theorem initialState_baseInv : + WhnfStateInv .noAccel + (kernelCacheSemantics model.keys RawProjRel.none) + RawProjRel.none world support model.keys.uvars [] initialState := by + refine ⟨initialState_kernel, ?_, rfl, + Primitives.ofAnonAddrs_canonical⟩ + apply CtxRecon.empty <;> rfl + +theorem initialState_inv : + ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys RawProjRel.none) + support [] initialState := + ⟨initialState_baseInv, + ClosedContextDigest.model_stateInScope initialState_closed⟩ + +theorem sourceTranslation : + TrKExprS world.venv model.keys.uvars world.nameOf RawProjRel.none [] + source (.sort .zero) := by + unfold source sourceUniv + exact .sort (by trivial) + +def theory : WhnfTheory RawProjRel.none world model.keys.uvars where + literalWF := by + intro literal hliteral + cases literal <;> + simp [world, Lean4Lean.VEnv.ContainsLits, + Lean4Lean.VEnv.contains, Lean4Lean.VEnv.empty] at hliteral + projections := RawProjRel.none_ok world.venv model.keys.uvars + +theorem trustedReferences : RecM.TrustedReferences world support := by + intro candidate id hcandidate href + obtain ⟨u, info, hsort⟩ := supported_is_sort hcandidate + subst candidate + simp [KExpr.References] at href + +theorem schedule (separation : AddressSeparation) : + Methods.ScopedCallScheduleAt model .noAccel + (kernelCacheSemantics model.keys RawProjRel.none) support + (Methods.ScopedSortSchedule.calls source) 2 := + Methods.ScopedSortSchedule.two (support_collisionFree separation) + source_supported result_supported theory trustedReferences + +theorem methodContract (separation : AddressSeparation) : + Methods.ScopedWFAtOn model .noAccel + (kernelCacheSemantics model.keys RawProjRel.none) support + (.singletonInfer source) + (Methods.next (Ix.Tc.methodsN (m := .anon) 1)) := by + simpa [Methods.ScopedSortSchedule.calls] using + (schedule separation).nextSelected + +theorem fullInference (separation : AddressSeparation) : + Methods.ScopedFullInferenceWFAtOn model support + (.singletonInfer source) + (Methods.next (Ix.Tc.methodsN (m := .anon) 1)) := + Methods.ScopedFullInferenceWFAtOn.ofSingletonSort + (methodContract separation) + (Methods.next_preservesInferOnly _ + (Methods.methodsN_concrete_preservesInferOnly 1)) + +def pipelines (separation : AddressSeparation) : + ScopedStandalonePipelineResources model support + (.singletonInfer source) (Ix.Tc.methodsN (m := .anon) 1) := + ScopedStandalonePipelineResources.singletonSortAxiom + (fullInference separation) sortResources supported_is_sort + +theorem pipelines_cover (separation : AddressSeparation) : + (pipelines separation).Covers concreteAxiom := + .axiom rfl + +theorem validationCoverage : source.ValidationCoverage support := by + constructor + · intro candidate hcandidate + cases hcandidate + exact source_supported + · intro level hlevel + cases hlevel with + | sort hreach => + cases hreach + exact Or.inl rfl + +theorem validationResources : + StandaloneValidationResources support concreteAxiom := + .axiom validationCoverage (by + change 1 < UInt64.size + decide) + +/-! ## Exact production execution -/ + +def methods : Methods .anon := Ix.Tc.methodsN 1 + +theorem initial_loaded : + initialState.env.get? targetId = some concreteAxiom := by + simp [initialState, env, KEnv.get?, KEnv.insert, TcState.ofEnvAnon] + +theorem initial_tryGet : + TcM.tryGetConst targetId initialState = + .ok (some concreteAxiom) initialState := by + unfold TcM.tryGetConst + change EStateM.bind (get : TcM .anon (TcState .anon)) _ initialState = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) initialState = + .ok initialState initialState from rfl] + simp only + rw [initial_loaded] + rfl + +theorem initial_get : + TcM.getConst targetId initialState = + .ok concreteAxiom initialState := by + unfold TcM.getConst + change EStateM.bind (TcM.tryGetConst targetId) _ initialState = _ + unfold EStateM.bind + rw [initial_tryGet] + rfl + +theorem validation_execution : + (RecM.validateConstWellScoped concreteAxiom).run methods initialState = + .ok () initialState := by + unfold concreteAxiom RecM.validateConstWellScoped + rw [ReaderT.run_bind] + change EStateM.bind + ((RecM.validateExprWellScoped source 0 0).run methods) _ initialState = _ + have hvalidate : + (RecM.validateExprWellScoped source 0 0).run methods initialState = + .ok () initialState := by + unfold RecM.validateExprWellScoped + rw [RecM.validateExprWellScoped.go.eq_def] + simp only [Std.HashSet.contains_empty, Bool.false_eq_true, if_false] + have hsource : source = .sort sourceUniv source.info := by rfl + rw [hsource] + rw [ReaderT.run_bind] + change EStateM.bind + ((RecM.validateUnivParamsSeen sourceUniv 0 ∅).run methods) _ + initialState = _ + let seen : Std.HashSet Address := + ({} : Std.HashSet Address).insert sourceUniv.addr + have huniv : + (RecM.validateUnivParamsSeen sourceUniv 0 ∅).run methods initialState = + .ok seen initialState := by + unfold sourceUniv KUniv.mkZero RecM.validateUnivParamsSeen + rw [RecM.validateUnivParamsSeen.go.eq_def] + simp only [Std.HashSet.contains_empty, Bool.false_eq_true, if_false] + rw [RecM.validateUnivParamsSeen.go.eq_def] + rfl + unfold EStateM.bind + rw [huniv] + simp only + rw [RecM.validateExprWellScoped.go.eq_def] + rfl + unfold EStateM.bind + rw [hvalidate] + rfl + +def inferKey : Address × Address := (source.addr, emptyCtxAddr) + +theorem initial_inferKey : + TcM.inferKey source initialState = .ok inferKey initialState := by + simpa [inferKey, TcM.inferKey_eq_whnfKey] using + (TcM.whnfKey_closed (s := initialState) (source := source) (by rfl)) + +theorem initial_inferMiss : + initialState.env.inferCache[inferKey]? = none := by + simp [initialState, env, inferKey, KEnv.insert, TcState.ofEnvAnon] + +theorem publicInference_wf (separation : AddressSeparation) : + TcM.WF + (ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys RawProjRel.none) support []) + initialState (TcM.infer source) + (fun inferred _ => support inferred ∧ + InferPost RawProjRel.none world model.keys.uvars [] + (.sort .zero) inferred) := by + simpa [source, result, resultUniv] using + (TcM.infer.sort_scoped_wf_fuel_one + (initial := initialState) (model := model) + (u := sourceUniv) (info := source.info) + (Delta := []) (sourceV := .sort .zero) + (by rfl) (support_collisionFree separation) source_supported + result_supported theory trustedReferences sourceTranslation) + +/-- Exact operational witness for the positive-fuel inference used by the +axiom checker. It interns the successor sort and records the cache entry, +so this is not a pre-seeded-cache witness. This execution fact deliberately +does not depend on the semantic typing postcondition. -/ +theorem inference_run (separation : AddressSeparation) : + ∃ after, + (RecM.infer source).run methods initialState = .ok result after := by + obtain ⟨afterIntern, hintern, _hbaseAfter, _hframe⟩ := + TcM.intern_whnf_eval (support_collisionFree separation) + result_supported initialState_baseInv + have hbody : + (RecM.inferUncached RecM.inferCall false source).run methods + initialState = .ok result afterIntern := by + simpa [methods, source, result, resultUniv] using hintern + have hshell := RecM.inferWith_fullMiss_success + (inferRec := RecM.inferCall) (methods := methods) + (source := source) (ty := result) (key := inferKey) + (s := initialState) (sKey := initialState) (sBody := afterIntern) + (by rfl) initial_inferKey initial_inferMiss hbody + let after : TcState .anon := + { afterIntern with env := { afterIntern.env with + inferCache := afterIntern.env.inferCache.insert inferKey result } } + have hrun : + (RecM.infer source).run methods initialState = .ok result after := by + simpa [RecM.infer, after] using hshell + exact ⟨after, hrun⟩ + +/-- Exact positive-fuel inference together with its verified semantic +postcondition. The execution component is factored through `inference_run` +so request-trace certificates need not inherit the typing proof's axioms. -/ +theorem inference_execution (separation : AddressSeparation) : + ∃ after, + (RecM.infer source).run methods initialState = .ok result after ∧ + ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys RawProjRel.none) support [] after ∧ + support result ∧ + InferPost RawProjRel.none world model.keys.uvars [] + (.sort .zero) result := by + obtain ⟨after, hrun⟩ := inference_run separation + have hpublic : TcM.infer source initialState = .ok result after := by + simpa [TcM.infer, TcM.runRec, initialState, methods] using hrun + have hverified := (publicInference_wf separation) initialState_inv + rw [hpublic] at hverified + exact ⟨after, hrun, hverified.1, hverified.2⟩ + +theorem member_execution (separation : AddressSeparation) : + ∃ after, + (RecM.checkConstMember targetId concreteAxiom).run methods initialState = + .ok () after ∧ + ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys RawProjRel.none) support [] after := by + obtain ⟨after, hinfer, hafter, _⟩ := inference_execution separation + have hrun : + (RecM.checkConstMember targetId concreteAxiom).run methods initialState = + .ok () after := by + unfold RecM.checkConstMember + simp only [concreteAxiom, Mode.F.hasDups, Bool.false_eq_true, if_false, + ReaderT.run_bind] + change EStateM.bind + ((RecM.validateConstWellScoped concreteAxiom).run methods) _ + initialState = _ + unfold EStateM.bind + rw [validation_execution] + change EStateM.bind ((RecM.infer source).run methods) _ initialState = _ + unfold EStateM.bind + rw [hinfer] + have hresult : result = .sort resultUniv result.info := by rfl + rw [hresult] + rfl + exact ⟨after, hrun, hafter⟩ + +theorem fresh_execution (separation : AddressSeparation) : + ∃ after, + (RecM.checkConstMemberFresh targetId).run methods initialState = + .ok () after ∧ + ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys RawProjRel.none) support [] after := by + obtain ⟨after, hmember, hafter⟩ := member_execution separation + have hrun : + (RecM.checkConstMemberFresh targetId).run methods initialState = + .ok () after := by + unfold RecM.checkConstMemberFresh + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind TcM.reset _ initialState = _ + unfold EStateM.bind + rw [initialState_reset] + change EStateM.bind (TcM.getConst targetId) _ initialState = _ + unfold EStateM.bind + rw [initial_get] + exact hmember + exact ⟨after, hrun, hafter⟩ + +theorem route_execution : + (RecM.coordinatedBlockFor concreteAxiom).run methods initialState = + .ok none initialState := by + rfl + +theorem body_execution (separation : AddressSeparation) : + ∃ after, + (RecM.checkConst targetId).run methods initialState = .ok () after ∧ + ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys RawProjRel.none) support [] after := by + obtain ⟨after, hfresh, hafter⟩ := fresh_execution separation + have hrun : + (RecM.checkConst targetId).run methods initialState = .ok () after := by + unfold RecM.checkConst + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.getConst targetId) _ initialState = _ + unfold EStateM.bind + rw [initial_get] + change EStateM.bind + ((RecM.coordinatedBlockFor concreteAxiom).run methods) _ initialState = _ + unfold EStateM.bind + rw [route_execution] + exact hfresh + exact ⟨after, hrun, hafter⟩ + +theorem public_execution (separation : AddressSeparation) : + ∃ after, + TcM.checkConst targetId initialState = .ok () after ∧ + ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys RawProjRel.none) support [] after := by + obtain ⟨after, hbody, hafter⟩ := body_execution separation + have hrun : TcM.checkConst targetId initialState = .ok () after := by + apply TcM.isolateCheckErrors_ok + simpa [TcM.runRec, initialState, methods] using hbody + exact ⟨after, hrun, hafter⟩ + +theorem sourcePreTranslation : + PreTrKExprS world.venv model.keys.uvars world.nameOf RawProjRel.none [] + source (.sort .zero) := by + unfold source sourceUniv + exact .sort (by trivial) + +theorem declarationIngress : + PreDeclRel world.venv world.nameOf RawProjRel.none targetId + concreteAxiom declaration := by + apply PreDeclRel.axiom world_nameOf_target + exact sourcePreTranslation + +/-- The executed positive-fuel checker run produces semantic acceptance and +promotes the pending axiom into a trusted world while retaining membership +in the finite suffix-state domain. -/ +theorem checked_and_promoted (separation : AddressSeparation) : + ∃ after, + TcM.checkConst targetId initialState = .ok () after ∧ + StandaloneCheckResult RawProjRel.none world support targetId + concreteAxiom declaration ∧ + ∃ world', + Promotes world (fun target => target = targetId) world' ∧ + WhnfStateInv .noAccel + (kernelCacheSemantics model.keys RawProjRel.none) RawProjRel.none + world' support model.keys.uvars [] after ∧ + model.StateInScope after ∧ + TrustedDecl RawProjRel.none world' targetId declaration := by + obtain ⟨after, hmember, _hafter⟩ := member_execution separation + have hfresh : + (RecM.checkConstMemberFresh targetId).run methods initialState = + .ok () after := by + unfold RecM.checkConstMemberFresh + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind TcM.reset _ initialState = _ + unfold EStateM.bind + rw [initialState_reset] + change EStateM.bind (TcM.getConst targetId) _ initialState = _ + unfold EStateM.bind + rw [initial_get] + exact hmember + have hbody : + (RecM.checkConst targetId).run methods initialState = .ok () after := by + unfold RecM.checkConst + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + change EStateM.bind (TcM.getConst targetId) _ initialState = _ + unfold EStateM.bind + rw [initial_get] + change EStateM.bind + ((RecM.coordinatedBlockFor concreteAxiom).run methods) _ initialState = _ + unfold EStateM.bind + rw [route_execution] + exact hfresh + have hevidence := RecM.checkConstMember_scoped_sound + (pipelines separation) (methodContract separation) + (Methods.next_preservesInferOnly methods + (Methods.methodsN_concrete_preservesInferOnly 1)) + declarationIngress (pipelines_cover separation) validationResources + (by rfl) (by rfl) initialState_inv + ClosedContextDigest.model_lazyFaultPreserves hmember + obtain ⟨world', hpromotes, hcore, htrusted⟩ := + PendingDecl.promoteOfAccepted hevidence.1.1.1.core pending + hevidence.2.accepted + have hpublic : TcM.checkConst targetId initialState = .ok () after := by + apply TcM.isolateCheckErrors_ok + simpa [TcM.runRec, initialState, methods] using hbody + exact ⟨after, hpublic, ⟨declarationIngress, hevidence.2⟩, + world', hpromotes, + hevidence.1.1.rebaseWorld hpromotes.1 hcore, + hevidence.1.2, htrusted⟩ + +end Ix.Tc.PositiveFuelSort.Checker diff --git a/Ix/Tc/Verify/Check/ScopedPositiveFuelCertificate.lean b/Ix/Tc/Verify/Check/ScopedPositiveFuelCertificate.lean new file mode 100644 index 000000000..d1f1a4f53 --- /dev/null +++ b/Ix/Tc/Verify/Check/ScopedPositiveFuelCertificate.lean @@ -0,0 +1,316 @@ +import Ix.Tc.Verify.Check.ScopedPositiveFuelAxiom + +/-! +# Execution certificate for the scoped positive-fuel checker + +This module ties the finite request list to the actual public checker +program. The successful sort inference performs exactly one audited intern +operation; reset, validation, lookup, routing, and cache insertion are +certified silent steps. +-/ + +namespace Ix.Tc.PositiveFuelSort.Checker + +theorem tryGetConst_requests_of_loaded + {state : TcState .anon} {id : KId .anon} {constant : KConst .anon} + (hloaded : state.env.get? id = some constant) : + ExecutionRequests (TcM.tryGetConst id) state [] := by + unfold TcM.tryGetConst + apply ExecutionRequests.bind (ExecutionRequests.get state) + intro current after hget + cases hget + rw [hloaded] + exact .pure state (some constant) + +theorem getConst_requests_of_loaded + {state : TcState .anon} {id : KId .anon} {constant : KConst .anon} + (hloaded : state.env.get? id = some constant) : + ExecutionRequests (TcM.getConst id) state [] := by + unfold TcM.getConst + apply ExecutionRequests.bind + (tryGetConst_requests_of_loaded hloaded) + intro found after hrun + have hrun' : TcM.tryGetConst id state = .ok (some constant) state := by + unfold TcM.tryGetConst + change EStateM.bind (get : TcM .anon (TcState .anon)) _ state = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) state = + .ok state state from rfl] + simp only + rw [hloaded] + rfl + rw [hrun'] at hrun + cases hrun + exact .pure state constant + +theorem reset_requests : + ExecutionRequests TcM.reset initialState [] := by + unfold TcM.reset + exact ExecutionRequests.modify initialState _ rfl + +theorem validation_function : + (RecM.validateConstWellScoped concreteAxiom).run methods = + (pure () : TcM .anon Unit) := by + funext state + unfold concreteAxiom RecM.validateConstWellScoped + rw [ReaderT.run_bind] + change EStateM.bind + ((RecM.validateExprWellScoped source 0 0).run methods) _ state = _ + have hvalidate : + (RecM.validateExprWellScoped source 0 0).run methods state = + .ok () state := by + unfold RecM.validateExprWellScoped + rw [RecM.validateExprWellScoped.go.eq_def] + simp only [Std.HashSet.contains_empty, Bool.false_eq_true, if_false] + have hsource : source = .sort sourceUniv source.info := by rfl + rw [hsource] + rw [ReaderT.run_bind] + change EStateM.bind + ((RecM.validateUnivParamsSeen sourceUniv 0 ∅).run methods) _ state = _ + let seen : Std.HashSet Address := + ({} : Std.HashSet Address).insert sourceUniv.addr + have huniv : + (RecM.validateUnivParamsSeen sourceUniv 0 ∅).run methods state = + .ok seen state := by + unfold sourceUniv KUniv.mkZero RecM.validateUnivParamsSeen + rw [RecM.validateUnivParamsSeen.go.eq_def] + simp only [Std.HashSet.contains_empty, Bool.false_eq_true, if_false] + rw [RecM.validateUnivParamsSeen.go.eq_def] + rfl + unfold EStateM.bind + rw [huniv] + simp only + rw [RecM.validateExprWellScoped.go.eq_def] + rfl + unfold EStateM.bind + rw [hvalidate] + rfl + +theorem validation_requests : + ExecutionRequests + ((RecM.validateConstWellScoped concreteAxiom).run methods) + initialState [] := + .of_eq validation_function (.pure initialState ()) + +theorem inferKey_function : + TcM.inferKey source = + (pure inferKey : TcM .anon (Address × Address)) := by + funext state + unfold TcM.inferKey TcM.ctxAddrForLbr + change EStateM.bind (get : TcM .anon (TcState .anon)) + (fun _ => pure inferKey) state = _ + unfold EStateM.bind + rw [show (get : TcM .anon (TcState .anon)) state = + .ok state state from rfl] + +theorem inferKey_requests : + ExecutionRequests (TcM.inferKey source) initialState [] := + .of_eq inferKey_function (.pure initialState inferKey) + +theorem cacheInferResult_requests (state : TcState .anon) + (inferred : KExpr .anon) : + ExecutionRequests + ((RecM.cacheInferResult false inferKey inferred).run methods) + state [] := by + unfold RecM.cacheInferResult + simp only [Bool.not_false, if_true] + exact ExecutionRequests.modify state _ rfl + +theorem inferUncached_function : + (RecM.inferUncached RecM.inferCall false source).run methods = + TcM.intern result := by + funext state + have hsource : source = .sort sourceUniv source.info := by rfl + rw [hsource] + unfold RecM.inferUncached + rfl + +theorem inferUncached_requests (state : TcState .anon) : + ExecutionRequests + ((RecM.inferUncached RecM.inferCall false source).run methods) + state [.internExpr result] := + .of_eq inferUncached_function (.internExpr state result) + +theorem inference_requests : + ExecutionRequests ((RecM.infer source).run methods) initialState + [.internExpr result] := by + unfold RecM.infer RecM.inferWith + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + apply ExecutionRequests.bind (ExecutionRequests.get initialState) + intro current after hget + cases hget + apply ExecutionRequests.bind inferKey_requests + intro key after hkey + rw [initial_inferKey] at hkey + cases hkey + apply ExecutionRequests.bind (ExecutionRequests.get initialState) + intro current after hget + cases hget + rw [initial_inferMiss] + simp only + rw [ReaderT.run_bind, ReaderT.run_pure, pure_bind] + have hinferOnly : initialState.inferOnly = false := by rfl + rw [hinferOnly] + simp only [Bool.false_eq_true, if_false, ReaderT.run_pure, pure_bind, + ReaderT.run_bind] + apply ExecutionRequests.bind (inferUncached_requests initialState) + intro inferred after _hinfer + apply ExecutionRequests.bind + (cacheInferResult_requests after inferred) + intro _ afterCache _hcache + exact .pure afterCache inferred + +theorem ensureSort_function : + (RecM.ensureSortDirect result).run methods = + (pure resultUniv : TcM .anon (KUniv .anon)) := by + funext state + unfold RecM.ensureSortDirect result + rfl + +theorem ensureSort_requests (state : TcState .anon) : + ExecutionRequests ((RecM.ensureSortDirect result).run methods) + state [] := + .of_eq ensureSort_function (.pure state resultUniv) + +theorem member_requests (separation : AddressSeparation) : + ExecutionRequests + ((RecM.checkConstMember targetId concreteAxiom).run methods) + initialState [.internExpr result] := by + obtain ⟨afterInfer, hinfer⟩ := inference_run separation + unfold RecM.checkConstMember + simp only [concreteAxiom, Mode.F.hasDups, Bool.false_eq_true, if_false, + ReaderT.run_bind] + apply ExecutionRequests.bind validation_requests + intro _ afterValidation hvalidation + rw [validation_execution] at hvalidation + cases hvalidation + apply ExecutionRequests.bind inference_requests + intro inferred after hrun + rw [hinfer] at hrun + cases hrun + have hresult : result = .sort resultUniv result.info := by rfl + rw [hresult] + apply ExecutionRequests.bind (ensureSort_requests afterInfer) + intro _ afterSort hsort + have hsortRun : + (RecM.ensureSortDirect result).run methods afterInfer = + .ok resultUniv afterInfer := by + rw [ensureSort_function] + rfl + rw [hsortRun] at hsort + cases hsort + exact .pure afterInfer () + +theorem fresh_requests (separation : AddressSeparation) : + ExecutionRequests + ((RecM.checkConstMemberFresh targetId).run methods) + initialState [.internExpr result] := by + unfold RecM.checkConstMemberFresh + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + apply ExecutionRequests.bind reset_requests + intro _ afterReset hreset + rw [initialState_reset] at hreset + cases hreset + apply ExecutionRequests.bind + (getConst_requests_of_loaded initial_loaded) + intro constant afterGet hget + rw [initial_get] at hget + cases hget + exact member_requests separation + +theorem route_function : + (RecM.coordinatedBlockFor concreteAxiom).run methods = + (pure none : TcM .anon (Option (KId .anon))) := by + funext state + rfl + +theorem route_requests (state : TcState .anon) : + ExecutionRequests + ((RecM.coordinatedBlockFor concreteAxiom).run methods) state [] := + .of_eq route_function (.pure state none) + +theorem body_requests (separation : AddressSeparation) : + ExecutionRequests ((RecM.checkConst targetId).run methods) + initialState [.internExpr result] := by + unfold RecM.checkConst + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + apply ExecutionRequests.bind + (getConst_requests_of_loaded initial_loaded) + intro constant afterGet hget + rw [initial_get] at hget + cases hget + apply ExecutionRequests.bind (route_requests initialState) + intro route afterRoute hroute + have hrouteRun : + (RecM.coordinatedBlockFor concreteAxiom).run methods initialState = + .ok none initialState := by + rw [route_function] + rfl + rw [hrouteRun] at hroute + cases hroute + exact fresh_requests separation + +/-- The exact public checker trace. The successful run performs one and +only one audited interning request: construction of `Sort 1` while +inferring the pending `Sort 0` axiom's type. -/ +theorem public_requests (separation : AddressSeparation) : + ExecutionRequests (TcM.checkConst targetId) initialState + [.internExpr result] := by + unfold TcM.checkConst + apply ExecutionRequests.isolateCheckErrors + apply ExecutionRequests.runRec + simpa [initialState, methods] using body_requests separation + +def requests : List WalkerRequest := [.internExpr result] + +theorem result_constructed : KExpr.Constructed result := by + unfold result + exact .sort + +theorem request_coverage : + CheckConstSupport initialState.env.intern requests support := by + constructor + · constructor + · intro candidate hcandidate + obtain ⟨addr, haddr⟩ := hcandidate + simp [initialState, env, KEnv.insert, TcState.ofEnvAnon] at haddr + · intro candidate hcandidate + obtain ⟨addr, haddr⟩ := hcandidate + simp [initialState, env, KEnv.insert, TcState.ofEnvAnon] at haddr + · intro request hrequest + simp [requests] at hrequest + subst request + constructor + · intro candidate hcandidate + change candidate = result at hcandidate + subst candidate + exact result_supported + · intro candidate hcandidate + exact False.elim hcandidate + +theorem request_bounds : ResourceBounds requests := by + constructor + intro request hrequest + simp [requests] at hrequest + subst request + exact result_constructed + +theorem runAssumptions (separation : AddressSeparation) : + RunAssumptions initialState (TcM.checkConst targetId) requests support := + ⟨by simpa [requests] using public_requests separation, + support_collisionFree separation, request_coverage, request_bounds⟩ + +/-- The complete K2S public-run package for a real fuel-one checker +execution. Its method-call schedule and its suffix-state domain are both +finite, but deliberately separate: the call domain contains the source +sort, while the run support also contains the constructed successor sort. -/ +def publicContext (separation : AddressSeparation) : + ScopedRecursiveMethodRunContext initialState (TcM.checkConst targetId) + requests RawProjRel.none world support where + run := runAssumptions separation + model := model + calls := Methods.ScopedSortSchedule.calls source + schedule := by + simpa [initialState] using schedule separation + +end Ix.Tc.PositiveFuelSort.Checker diff --git a/Ix/Tc/Verify/Check/ScopedStandaloneDriver.lean b/Ix/Tc/Verify/Check/ScopedStandaloneDriver.lean new file mode 100644 index 000000000..adbeeccf0 --- /dev/null +++ b/Ix/Tc/Verify/Check/ScopedStandaloneDriver.lean @@ -0,0 +1,262 @@ +import Ix.Tc.Verify.Check.ScopedMemberEvidence +import Ix.Tc.Verify.Check.StandaloneDriver + +/-! +# Run-scoped standalone per-constant driver + +This module lifts the scoped member proof through the exact production +`checkConstMemberFresh` and standalone `checkConst` prefixes. Reset is the +only transition in those prefixes that is not already covered by a generic +frame theorem. Its effect on a suffix model's chosen state domain is +therefore exposed as a small, explicit contract. +-/ + +namespace Ix.Tc + +namespace RecM + +/-- Fixed-world form of the scoped fresh-member theorem. Atomic block +checking uses this form so that the enclosing block transaction, rather than +an individual member, owns the semantic commit point. Unlike the legacy +fixed-world theorem, the post-state retains the finite suffix-model domain. -/ +theorem checkConstMemberFresh_scoped_pending_evidence + {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {model : ScopedKernelSuffixModel trProj world} + {calls : Methods.CallDomain} {methods : Methods .anon} + (context : ScopedStandalonePipelineResources model support calls methods) + (hmethods : Methods.ScopedWFAtOn model .noAccel + (kernelCacheSemantics model.keys trProj) support calls + (Methods.next methods)) + (hmethodPolicy : (Methods.next methods).PreservesInferOnly) + {id : KId .anon} {concrete : KConst .anon} + {decl : Lean4Lean.VDecl} + (hprojection : trProj.SubstCompatible) + (hliterals : ∀ literal, world.venv.ContainsLits literal) + (hpending : PendingDecl trProj world id decl) + (hcatalog : world.catalog id = some concrete) + (hresources : StandaloneValidationResources support concrete) + (hcovers : context.Covers concrete) + (hcollision : support.CollisionFree) + (huvars : model.keys.uvars = concrete.lvls.toNat) + (hresetScope : model.ResetPreservesScope) + {before after : TcState .anon} + (hI : ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) support [] before) + (hfault : TcM.LazyFaultPreserves + (ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) support [])) + (hrun : (checkConstMemberFresh id).run methods before = .ok () after) : + StandaloneCheckResult trProj world support id concrete decl ∧ + ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) support [] after := by + unfold checkConstMemberFresh at hrun + simp only [ReaderT.run_bind, ReaderT.run_monadLift] at hrun + change EStateM.bind TcM.reset (fun _ => + EStateM.bind (TcM.getConst id) (fun concrete => + (checkConstMember id concrete).run methods)) before = + .ok () after at hrun + unfold EStateM.bind at hrun + cases hreset : TcM.reset before with + | error err failed => + rw [hreset] at hrun + contradiction + | ok resetValue afterReset => + rw [hreset] at hrun + have hresetPost := + TcM.reset_whnf_entry (uvars := model.keys.uvars) before hI.1.2.2 + hI.1.1 + rw [hreset] at hresetPost + have hIResetBase : WhnfStateInv .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars [] afterReset := + ⟨hresetPost.1, hresetPost.2.2.1, hresetPost.2.2.2.1⟩ + have hIReset : ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) support [] afterReset := + ⟨hIResetBase, hresetScope hI.2 hreset⟩ + cases hget : TcM.getConst id afterReset with + | error err failed => + simp only [hget] at hrun + contradiction + | ok found afterLookup => + simp only [hget] at hrun + have hgetPost := TcM.getConst_loaded_wf + (hfault.withInferOnly false) id afterReset + ⟨hIReset, hresetPost.2.1⟩ + rw [hget] at hgetPost + have hfoundCatalog : world.catalog id = some found := + hgetPost.1.1.1.1.core.loaded hgetPost.2 + have hfound : found = concrete := + Option.some.inj (hfoundCatalog.symm.trans hcatalog) + subst found + obtain ⟨afterValidation, hvalidation⟩ := + checkConstMember_validation_success hresources hrun + have hingress := hpending.toPre_of_validation hprojection hliterals + hcatalog hresources hcollision hvalidation + have hevidence := checkConstMember_scoped_sound context hmethods + hmethodPolicy hingress hcovers hresources huvars hgetPost.1.2 + hgetPost.1.1 hfault hrun + exact ⟨⟨hingress, hevidence.2⟩, hevidence.1⟩ + +/-- A successful scoped fresh-member run certifies the exact pending catalog +entry returned by production lookup. The state-domain witness is retained +through reset, eager/lazy lookup, validation, and the recursive checker +pipeline. -/ +theorem checkConstMemberFresh_scoped_pending_sound + {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {model : ScopedKernelSuffixModel trProj world} + {calls : Methods.CallDomain} {methods : Methods .anon} + (context : ScopedStandalonePipelineResources model support calls methods) + (hmethods : Methods.ScopedWFAtOn model .noAccel + (kernelCacheSemantics model.keys trProj) support calls + (Methods.next methods)) + (hmethodPolicy : (Methods.next methods).PreservesInferOnly) + {id : KId .anon} {concrete : KConst .anon} + {decl : Lean4Lean.VDecl} + (hprojection : trProj.SubstCompatible) + (hliterals : ∀ literal, world.venv.ContainsLits literal) + (hpending : PendingDecl trProj world id decl) + (hcatalog : world.catalog id = some concrete) + (hresources : StandaloneValidationResources support concrete) + (hcovers : context.Covers concrete) + (hcollision : support.CollisionFree) + (huvars : model.keys.uvars = concrete.lvls.toNat) + (hresetScope : model.ResetPreservesScope) + {before after : TcState .anon} + (hI : ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) support [] before) + (hfault : TcM.LazyFaultPreserves + (ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) support [])) + (hrun : (checkConstMemberFresh id).run methods before = .ok () after) : + StandaloneCheckResult trProj world support id concrete decl ∧ + ∃ world', + Promotes world (fun target => target = id) world' ∧ + WhnfStateInv .noAccel + (kernelCacheSemantics model.keys trProj) trProj world' support + model.keys.uvars [] after ∧ + model.StateInScope after ∧ + TrustedDecl trProj world' id decl := by + unfold checkConstMemberFresh at hrun + simp only [ReaderT.run_bind, ReaderT.run_monadLift] at hrun + change EStateM.bind TcM.reset (fun _ => + EStateM.bind (TcM.getConst id) (fun concrete => + (checkConstMember id concrete).run methods)) before = + .ok () after at hrun + unfold EStateM.bind at hrun + cases hreset : TcM.reset before with + | error err failed => + rw [hreset] at hrun + contradiction + | ok resetValue afterReset => + rw [hreset] at hrun + have hresetPost := + TcM.reset_whnf_entry (uvars := model.keys.uvars) before hI.1.2.2 + hI.1.1 + rw [hreset] at hresetPost + have hIResetBase : WhnfStateInv .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars [] afterReset := + ⟨hresetPost.1, hresetPost.2.2.1, hresetPost.2.2.2.1⟩ + have hIReset : ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) support [] afterReset := + ⟨hIResetBase, hresetScope hI.2 hreset⟩ + cases hget : TcM.getConst id afterReset with + | error err failed => + simp only [hget] at hrun + contradiction + | ok found afterLookup => + simp only [hget] at hrun + have hgetPost := TcM.getConst_loaded_wf + (hfault.withInferOnly false) id afterReset + ⟨hIReset, hresetPost.2.1⟩ + rw [hget] at hgetPost + have hfoundCatalog : world.catalog id = some found := + hgetPost.1.1.1.1.core.loaded hgetPost.2 + have hfound : found = concrete := + Option.some.inj (hfoundCatalog.symm.trans hcatalog) + subst found + exact checkConstMember_scoped_pending_sound context hmethods + hmethodPolicy hprojection hliterals hpending hcatalog hresources + hcovers hcollision huvars hgetPost.1.2 hgetPost.1.1 hfault hrun + +/-- Lift the scoped fresh-member theorem through the exact standalone branch +of `RecM.checkConst`. The router itself is checked against the scoped +invariant, so block selection cannot discard the finite-domain witness. -/ +theorem checkConst_standalone_scoped_pending_sound + {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {model : ScopedKernelSuffixModel trProj world} + {calls : Methods.CallDomain} {methods : Methods .anon} + (context : ScopedStandalonePipelineResources model support calls methods) + (hmethods : Methods.ScopedWFAtOn model .noAccel + (kernelCacheSemantics model.keys trProj) support calls + (Methods.next methods)) + (hmethodPolicy : (Methods.next methods).PreservesInferOnly) + {id : KId .anon} {concrete : KConst .anon} + {decl : Lean4Lean.VDecl} + (hprojection : trProj.SubstCompatible) + (hliterals : ∀ literal, world.venv.ContainsLits literal) + (hpending : PendingDecl trProj world id decl) + (hcatalog : world.catalog id = some concrete) + (hresources : StandaloneValidationResources support concrete) + (hcovers : context.Covers concrete) + (hcollision : support.CollisionFree) + (huvars : model.keys.uvars = concrete.lvls.toNat) + (hresetScope : model.ResetPreservesScope) + (hroute : StandaloneRoute + (ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) support []) methods concrete) + {before after : TcState .anon} + (hI : ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) support [] before) + (hfault : TcM.LazyFaultPreserves + (ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) support [])) + (hrun : (checkConst id).run methods before = .ok () after) : + StandaloneCheckResult trProj world support id concrete decl ∧ + ∃ world', + Promotes world (fun target => target = id) world' ∧ + WhnfStateInv .noAccel + (kernelCacheSemantics model.keys trProj) trProj world' support + model.keys.uvars [] after ∧ + model.StateInScope after ∧ + TrustedDecl trProj world' id decl := by + unfold checkConst at hrun + simp only [ReaderT.run_bind, ReaderT.run_monadLift] at hrun + change EStateM.bind (TcM.getConst id) _ before = .ok () after at hrun + unfold EStateM.bind at hrun + cases hget : TcM.getConst id before with + | error err failed => + rw [hget] at hrun + contradiction + | ok found afterLookup => + rw [hget] at hrun + have hgetPost := TcM.getConst_loaded_wf hfault id before hI + rw [hget] at hgetPost + have hfoundCatalog : world.catalog id = some found := + hgetPost.1.1.1.core.loaded hgetPost.2 + have hfound : found = concrete := + Option.some.inj (hfoundCatalog.symm.trans hcatalog) + subst found + change EStateM.bind ((coordinatedBlockFor concrete).run methods) _ + afterLookup = .ok () after at hrun + unfold EStateM.bind at hrun + cases hselected : (coordinatedBlockFor concrete).run methods afterLookup with + | error err failed => + rw [hselected] at hrun + contradiction + | ok selected afterRoute => + rw [hselected] at hrun + have hroutePost := hroute afterLookup hgetPost.1 + rw [hselected] at hroutePost + have hnone : selected = none := hroutePost.2 + subst selected + exact checkConstMemberFresh_scoped_pending_sound context hmethods + hmethodPolicy hprojection hliterals hpending hcatalog hresources + hcovers hcollision huvars hresetScope hroutePost.1 hfault hrun + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/SingletonInductive.lean b/Ix/Tc/Verify/Check/SingletonInductive.lean new file mode 100644 index 000000000..3e8f38327 --- /dev/null +++ b/Ix/Tc/Verify/Check/SingletonInductive.lean @@ -0,0 +1,297 @@ +import Ix.Tc.Verify.Check.BlockOracle +import Ix.Tc.Verify.Inductive.IngressExecution +import Ix.Tc.Verify.Inductive.SingletonIngress +import Ix.Tc.Verify.Inductive.SingletonOracle + +/-! +# Certificate-backed singleton family blocks + +E0 fixes the exact physical block, classifier, execution trace, and active +post-state. `SingletonFamilyCatalogLink` fixes the same member array and +constructs its semantic oracle from the E2a transaction. This module joins +those independently audited indices, so a successful production family block +does not need an additional ambient inductive oracle. + +The recursor remains a separate physical Ix block; the second adapter below +certifies that block with the enumeration oracle built from its registered +generated equations. +-/ + +namespace Ix.Tc + +namespace SingletonFamilyCatalogLink + +/-- The exact family/constructor link supplies all oracle-backed resources +for an E0 inductive-block trace. -/ +def blockResources + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {source : Lean4Lean.VInductDecl} {theoryAfter : Lean4Lean.VEnv} + {tx : CertifiedGenerationTransaction source world.venv theoryAfter} + (link : SingletonFamilyCatalogLink trProj world.catalog world.nameOf + world.trusted tx) + {after : TcState .anon} + (activePost : ActiveBlockStateWF semantics trProj world support + link.members after) : + OracleBackedBlockResources semantics trProj world support link.members + .inductive' after where + oracleBacked := by trivial + activePost := activePost + oracle := link.oracle + memberIff := link.oracle_members_iff + +end SingletonFamilyCatalogLink + +namespace SingletonRecursorCatalogLink + +/-- The enumeration link supplies all oracle-backed resources for the exact +one-member production recursor block. -/ +def blockResources + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {source : Lean4Lean.VInductDecl} {theoryAfter : Lean4Lean.VEnv} + {tx : CertifiedGenerationTransaction source world.venv theoryAfter} + {family : SingletonFamilyCatalogLink trProj world.catalog world.nameOf + world.trusted tx} + (link : SingletonRecursorCatalogLink trProj world.catalog world.nameOf + world.trusted tx family) + (shape : CertifiedSingletonGeneration.IsEnumeration + tx.certificate.generation) + {after : TcState .anon} + (activePost : ActiveBlockStateWF semantics trProj world support + link.members after) : + OracleBackedBlockResources semantics trProj world support link.members + .recursor after where + oracleBacked := by trivial + activePost := activePost + oracle := link.oracle shape + memberIff := link.oracle_members_iff shape + +end SingletonRecursorCatalogLink + +namespace RecM + +/-- Certify one actual successful singleton family/constructor block by +combining E0's exact trace with E2a/E2b's exact catalog link. -/ +theorem certifySingletonFamilyBlock + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {methods : Methods .anon} + {source : Lean4Lean.VInductDecl} {theoryAfter : Lean4Lean.VEnv} + {tx : CertifiedGenerationTransaction source world.venv theoryAfter} + (link : SingletonFamilyCatalogLink trProj world.catalog world.nameOf + world.trusted tx) + {block requested : KId .anon} {before after : TcState .anon} + (trace : ExactBlockBodySuccessTrace methods block requested link.members + .inductive' before after) + (hexact : ExactCheckBlock world block link.members .inductive') + (activePost : ActiveBlockStateWF semantics trProj world support + link.members after) : + CertifiedBlockBodySuccess semantics trProj world support methods block + requested link.members .inductive' before after := + certifyOracleBackedBlock trace hexact (link.blockResources activePost) + +/-- Certify one actual successful singleton enumeration recursor block by +combining E0's exact trace with E2a/E2b's generated-rule correspondence. -/ +theorem certifySingletonRecursorBlock + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {methods : Methods .anon} + {source : Lean4Lean.VInductDecl} {theoryAfter : Lean4Lean.VEnv} + {tx : CertifiedGenerationTransaction source world.venv theoryAfter} + {family : SingletonFamilyCatalogLink trProj world.catalog world.nameOf + world.trusted tx} + (link : SingletonRecursorCatalogLink trProj world.catalog world.nameOf + world.trusted tx family) + (shape : CertifiedSingletonGeneration.IsEnumeration + tx.certificate.generation) + {block requested : KId .anon} {before after : TcState .anon} + (trace : ExactBlockBodySuccessTrace methods block requested link.members + .recursor before after) + (hexact : ExactCheckBlock world block link.members .recursor) + (activePost : ActiveBlockStateWF semantics trProj world support + link.members after) : + CertifiedBlockBodySuccess semantics trProj world support methods block + requested link.members .recursor before after := + certifyOracleBackedBlock trace hexact + (link.blockResources shape activePost) + +/-! ## Atomic post-admission adapters -/ + +/-- Certify a family body whose generated memo entries are validated in the +exact world produced by admitting the family oracle. The pre-world trusted +log justifies the admission; no reduction cache is required to be meaningful +before the family exists semantically. -/ +theorem certifySingletonFamilyBlockPostAdmission + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {methods : Methods .anon} + {source : Lean4Lean.VInductDecl} {theoryAfter : Lean4Lean.VEnv} + {tx : CertifiedGenerationTransaction source world.venv theoryAfter} + (link : SingletonFamilyCatalogLink trProj world.catalog world.nameOf + world.trusted tx) + {block requested : KId .anon} {before after : TcState .anon} + (trace : ExactBlockBodySuccessTrace methods block requested link.members + .inductive' before after) + (hexact : ExactCheckBlock world block link.members .inductive') + (trustedCatalog : TrustedCatalogRel trProj world) + (post : KernelStateWF semantics trProj + (world.admitOracle link.oracle) support after) : + CertifiedAdmittedBlockBodySuccess semantics trProj world + (world.admitOracle link.oracle) support methods block requested + link.members .inductive' before after := + certifyOracleBackedAdmittedBlock trace hexact (by trivial) link.oracle + link.oracle_members_iff trustedCatalog post + +/-- Post-admission counterpart for the enumeration recursor block. -/ +theorem certifySingletonRecursorBlockPostAdmission + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {methods : Methods .anon} + {source : Lean4Lean.VInductDecl} {theoryAfter : Lean4Lean.VEnv} + {tx : CertifiedGenerationTransaction source world.venv theoryAfter} + {family : SingletonFamilyCatalogLink trProj world.catalog world.nameOf + world.trusted tx} + (link : SingletonRecursorCatalogLink trProj world.catalog world.nameOf + world.trusted tx family) + (shape : CertifiedSingletonGeneration.IsEnumeration + tx.certificate.generation) + {block requested : KId .anon} {before after : TcState .anon} + (trace : ExactBlockBodySuccessTrace methods block requested link.members + .recursor before after) + (hexact : ExactCheckBlock world block link.members .recursor) + (trustedCatalog : TrustedCatalogRel trProj world) + (post : KernelStateWF semantics trProj + (world.admitOracle (link.oracle shape)) support after) : + CertifiedAdmittedBlockBodySuccess semantics trProj world + (world.admitOracle (link.oracle shape)) support methods block requested + link.members .recursor before after := + certifyOracleBackedAdmittedBlock trace hexact (by trivial) + (link.oracle shape) (link.oracle_members_iff shape) trustedCatalog post + +/-! ## Loaded-ingress adapters -/ + +/-- Certify an actual successful family/constructor block from the entries +loaded in its production post-state. `LoadedAgrees` transports those entries +to the immutable catalog, while the trusted log and certified generation +trace prove that none of the linked addresses was already admitted. -/ +theorem certifySingletonFamilyIngressBlock + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {methods : Methods .anon} + {source : Lean4Lean.VInductDecl} {theoryAfter : Lean4Lean.VEnv} + {tx : CertifiedGenerationTransaction source world.venv theoryAfter} + {block requested : KId .anon} {before after : TcState .anon} + (view : SingletonFamilyIngressView trProj after.env world.nameOf tx) + (trace : ExactBlockBodySuccessTrace methods block requested view.members + .inductive' before after) + (hexact : ExactCheckBlock world block view.members .inductive') + (activePost : ActiveBlockStateWF semantics trProj world support + view.members after) : + CertifiedBlockBodySuccess semantics trProj world support methods block + requested view.members .inductive' before after := by + let link := view.toCatalogLink activePost.blockState.core.loaded + activePost.blockState.core.trustedCatalog + exact certifySingletonFamilyBlock link trace hexact activePost + +/-- Certify an actual successful singleton recursor block from the recursor +entry loaded in its production post-state. The preceding family link fixes +the constructor order used by both the Ix rule array and Lean4Lean's +generated equations. -/ +theorem certifySingletonRecursorIngressBlock + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {methods : Methods .anon} + {source : Lean4Lean.VInductDecl} {theoryAfter : Lean4Lean.VEnv} + {tx : CertifiedGenerationTransaction source world.venv theoryAfter} + {family : SingletonFamilyCatalogLink trProj world.catalog world.nameOf + world.trusted tx} + {block requested : KId .anon} {before after : TcState .anon} + (view : SingletonRecursorIngressView trProj after.env world.nameOf tx + family) + (shape : CertifiedSingletonGeneration.IsEnumeration + tx.certificate.generation) + (trace : ExactBlockBodySuccessTrace methods block requested view.members + .recursor before after) + (hexact : ExactCheckBlock world block view.members .recursor) + (activePost : ActiveBlockStateWF semantics trProj world support + view.members after) : + CertifiedBlockBodySuccess semantics trProj world support methods block + requested view.members .recursor before after := by + let link := view.toCatalogLink activePost.blockState.core.loaded + activePost.blockState.core.trustedCatalog + exact certifySingletonRecursorBlock link shape trace hexact activePost + +/-! ## Complete production-ingress/checker joins -/ + +/-- Join one actual anonymous family-block ingress execution to one actual +successful production checker-body execution. The semantic catalog link is +constructed internally from the conversion interpretation, publication +trace, loaded-catalog invariant, trusted log, and E2a transaction. -/ +theorem certifySingletonFamilyIngressExecution + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {methods : Methods .anon} + {source : Lean4Lean.VInductDecl} {theoryAfter : Lean4Lean.VEnv} + {tx : CertifiedGenerationTransaction source world.venv theoryAfter} + {ixonEnv : Ixon.Env} {blockConstant : Ixon.Constant} + {blockAddr : Address} {ingressBefore ingressAfter : AnonEnv} + {ingressResult : AnonBlockIngressTrace} + (interpretation : SingletonFamilyIngressInterpretation trProj + world.nameOf ingressResult tx) + (ingress : AnonBlockIngressSuccessTrace ixonEnv blockConstant blockAddr + ingressBefore ingressAfter ingressResult) + (loadedIngress : LoadedAgrees world.catalog ingressAfter) + {block requested : KId .anon} {before after : TcState .anon} + (trace : ExactBlockBodySuccessTrace methods block requested + (ingressResult.allEntries.map (·.1)) .inductive' before after) + (hexact : ExactCheckBlock world block + (ingressResult.allEntries.map (·.1)) .inductive') + (activePost : ActiveBlockStateWF semantics trProj world support + (ingressResult.allEntries.map (·.1)) after) : + CertifiedBlockBodySuccess semantics trProj world support methods block + requested (ingressResult.allEntries.map (·.1)) .inductive' before + after := by + let link := interpretation.toCatalogLink ingress loadedIngress + activePost.blockState.core.trustedCatalog + have hmembers : link.members = ingressResult.allEntries.map (·.1) := + interpretation.toCatalogLink_members ingress loadedIngress + activePost.blockState.core.trustedCatalog + rw [← hmembers] at trace hexact activePost ⊢ + exact certifySingletonFamilyBlock link trace hexact activePost + +/-- Join one actual anonymous recursor-block ingress execution to one actual +successful production recursor checker-body execution. Positional generated +equation and iota-pattern facts remain derived from the E2a certificate and +the supported enumeration shape. -/ +theorem certifySingletonRecursorIngressExecution + {semantics : CacheSemantics} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} {methods : Methods .anon} + {source : Lean4Lean.VInductDecl} {theoryAfter : Lean4Lean.VEnv} + {tx : CertifiedGenerationTransaction source world.venv theoryAfter} + {family : SingletonFamilyCatalogLink trProj world.catalog world.nameOf + world.trusted tx} + {ixonEnv : Ixon.Env} {blockConstant : Ixon.Constant} + {blockAddr : Address} {ingressBefore ingressAfter : AnonEnv} + {ingressResult : AnonBlockIngressTrace} + (interpretation : SingletonRecursorIngressInterpretation trProj + world.nameOf ingressResult tx family) + (ingress : AnonBlockIngressSuccessTrace ixonEnv blockConstant blockAddr + ingressBefore ingressAfter ingressResult) + (loadedIngress : LoadedAgrees world.catalog ingressAfter) + (shape : CertifiedSingletonGeneration.IsEnumeration + tx.certificate.generation) + {block requested : KId .anon} {before after : TcState .anon} + (trace : ExactBlockBodySuccessTrace methods block requested + (ingressResult.allEntries.map (·.1)) .recursor before after) + (hexact : ExactCheckBlock world block + (ingressResult.allEntries.map (·.1)) .recursor) + (activePost : ActiveBlockStateWF semantics trProj world support + (ingressResult.allEntries.map (·.1)) after) : + CertifiedBlockBodySuccess semantics trProj world support methods block + requested (ingressResult.allEntries.map (·.1)) .recursor before + after := by + let link := interpretation.toCatalogLink ingress loadedIngress + activePost.blockState.core.trustedCatalog + have hmembers : link.members = ingressResult.allEntries.map (·.1) := by + change #[interpretation.recursorId] = _ + exact interpretation.entryIds.symm + rw [← hmembers] at trace hexact activePost ⊢ + exact certifySingletonRecursorBlock link shape trace hexact activePost + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/StandaloneDriver.lean b/Ix/Tc/Verify/Check/StandaloneDriver.lean new file mode 100644 index 000000000..c47ac7633 --- /dev/null +++ b/Ix/Tc/Verify/Check/StandaloneDriver.lean @@ -0,0 +1,286 @@ +import Ix.Tc.Verify.Check.ResetFrame + +/-! +# Standalone per-constant driver + +This module lifts member-level acceptance through the exact production +`checkConstMemberFresh` prefix: reset the per-check state, perform the required +lazy constant lookup, and check the value returned by that lookup. The +catalog agreement proof prevents a successful lazy lookup from silently +changing which pending declaration is certified. +-/ + +namespace Ix.Tc + +/-- Operational boundary separating K3 standalone checking from E0 block +coordination. The exact production router must preserve the checker +invariant and select no coordinated block. This condition is definitionally +inhabited for axioms; definition-family instances are discharged when their +block lookup/classification is known to select the standalone path. -/ +def StandaloneRoute (I : TcState .anon → Prop) (methods : Methods .anon) + (concrete : KConst .anon) : Prop := + ∀ state, TcM.WF I state ((RecM.coordinatedBlockFor concrete).run methods) + (fun selected _ => selected = none) + +namespace StandaloneRoute + +/-- Axioms never enter block coordination. -/ +theorem axiomRoute + (I : TcState .anon → Prop) (methods : Methods .anon) + (name : Mode.anon.F Name) (levelParams : Mode.anon.F (Array Name)) + (isUnsafe : Bool) (levels : UInt64) (type : KExpr .anon) : + StandaloneRoute I methods + (.axio name levelParams isUnsafe levels type) := by + intro state hI + exact ⟨hI, rfl⟩ + +end StandaloneRoute + +namespace RecM + +/-- A successful standalone fresh-member run certifies the exact pending +catalog entry returned by production lookup. Reset establishes the empty +local context; required lookup preserves it on either eager or lazy ingress. +-/ +theorem checkConstMemberFresh_pending_sound + {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {model : KernelSuffixModel trProj world} + {calls : Methods.CallDomain} {methods : Methods .anon} + (context : StandalonePipelineResources + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars calls methods) + (hmethods : Methods.WFAtOn .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars calls (Methods.next methods)) + (hmethodPolicy : (Methods.next methods).PreservesInferOnly) + {id : KId .anon} {concrete : KConst .anon} + {decl : Lean4Lean.VDecl} + (hprojection : trProj.SubstCompatible) + (hliterals : ∀ literal, world.venv.ContainsLits literal) + (hpending : PendingDecl trProj world id decl) + (hcatalog : world.catalog id = some concrete) + (hresources : StandaloneValidationResources support concrete) + (hcovers : context.Covers concrete) + (hcollision : support.CollisionFree) + (huvars : model.keys.uvars = concrete.lvls.toNat) + {before after : TcState .anon} + (hkernel : KernelStateWF + (kernelCacheSemantics model.keys trProj) trProj world support before) + (hlayer : WhnfLayer.noAccel.StateOK before) + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv .noAccel (kernelCacheSemantics model.keys trProj) + trProj world support model.keys.uvars [])) + (hrun : (checkConstMemberFresh id).run methods before = .ok () after) : + StandaloneCheckResult trProj world support id concrete decl ∧ + ∃ world', + Promotes world (fun target => target = id) world' ∧ + WhnfStateInv .noAccel + (kernelCacheSemantics model.keys trProj) trProj world' support + model.keys.uvars [] after ∧ + TrustedDecl trProj world' id decl := by + unfold checkConstMemberFresh at hrun + simp only [ReaderT.run_bind, ReaderT.run_monadLift] at hrun + change EStateM.bind TcM.reset (fun _ => + EStateM.bind (TcM.getConst id) (fun concrete => + (checkConstMember id concrete).run methods)) before = + .ok () after at hrun + unfold EStateM.bind at hrun + cases hreset : TcM.reset before with + | error err failed => + rw [hreset] at hrun + contradiction + | ok resetValue afterReset => + rw [hreset] at hrun + have hresetPost := + TcM.reset_whnf_entry (uvars := model.keys.uvars) before hlayer hkernel + rw [hreset] at hresetPost + have hIReset : WhnfStateInv .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars [] afterReset := + ⟨hresetPost.1, hresetPost.2.2.1, hresetPost.2.2.2.1⟩ + cases hget : TcM.getConst id afterReset with + | error err failed => + simp only [hget] at hrun + contradiction + | ok found afterLookup => + simp only [hget] at hrun + have hgetPost := TcM.getConst_loaded_wf + (hfault.withInferOnly false) id afterReset + ⟨hIReset, hresetPost.2.1⟩ + rw [hget] at hgetPost + have hfoundCatalog : world.catalog id = some found := + hgetPost.1.1.1.core.loaded hgetPost.2 + have hfound : found = concrete := + Option.some.inj (hfoundCatalog.symm.trans hcatalog) + subst found + exact checkConstMember_pending_sound context hmethods hmethodPolicy + hprojection hliterals hpending hcatalog hresources hcovers + hcollision huvars hgetPost.1.2 hgetPost.1.1 hfault hrun + +/-- Fixed-world form of the fresh-member theorem. This stops immediately +after constructing the actual standalone checker result and deliberately +does not perform the standalone ghost promotion. Atomic block checking uses +this form so that the enclosing block transaction—not an individual member— +owns the semantic commit point. -/ +theorem checkConstMemberFresh_pending_evidence + {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {model : KernelSuffixModel trProj world} + {calls : Methods.CallDomain} {methods : Methods .anon} + (context : StandalonePipelineResources + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars calls methods) + (hmethods : Methods.WFAtOn .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars calls (Methods.next methods)) + (hmethodPolicy : (Methods.next methods).PreservesInferOnly) + {id : KId .anon} {concrete : KConst .anon} + {decl : Lean4Lean.VDecl} + (hprojection : trProj.SubstCompatible) + (hliterals : ∀ literal, world.venv.ContainsLits literal) + (hpending : PendingDecl trProj world id decl) + (hcatalog : world.catalog id = some concrete) + (hresources : StandaloneValidationResources support concrete) + (hcovers : context.Covers concrete) + (hcollision : support.CollisionFree) + (huvars : model.keys.uvars = concrete.lvls.toNat) + {before after : TcState .anon} + (hkernel : KernelStateWF + (kernelCacheSemantics model.keys trProj) trProj world support before) + (hlayer : WhnfLayer.noAccel.StateOK before) + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv .noAccel (kernelCacheSemantics model.keys trProj) + trProj world support model.keys.uvars [])) + (hrun : (checkConstMemberFresh id).run methods before = .ok () after) : + StandaloneCheckResult trProj world support id concrete decl ∧ + WhnfStateInv .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars [] after := by + unfold checkConstMemberFresh at hrun + simp only [ReaderT.run_bind, ReaderT.run_monadLift] at hrun + change EStateM.bind TcM.reset (fun _ => + EStateM.bind (TcM.getConst id) (fun concrete => + (checkConstMember id concrete).run methods)) before = + .ok () after at hrun + unfold EStateM.bind at hrun + cases hreset : TcM.reset before with + | error err failed => + rw [hreset] at hrun + contradiction + | ok resetValue afterReset => + rw [hreset] at hrun + have hresetPost := + TcM.reset_whnf_entry (uvars := model.keys.uvars) before hlayer hkernel + rw [hreset] at hresetPost + have hIReset : WhnfStateInv .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars [] afterReset := + ⟨hresetPost.1, hresetPost.2.2.1, hresetPost.2.2.2.1⟩ + cases hget : TcM.getConst id afterReset with + | error err failed => + simp only [hget] at hrun + contradiction + | ok found afterLookup => + simp only [hget] at hrun + have hgetPost := TcM.getConst_loaded_wf + (hfault.withInferOnly false) id afterReset + ⟨hIReset, hresetPost.2.1⟩ + rw [hget] at hgetPost + have hfoundCatalog : world.catalog id = some found := + hgetPost.1.1.1.core.loaded hgetPost.2 + have hfound : found = concrete := + Option.some.inj (hfoundCatalog.symm.trans hcatalog) + subst found + obtain ⟨afterValidation, hvalidation⟩ := + checkConstMember_validation_success hresources hrun + have hingress := hpending.toPre_of_validation hprojection hliterals + hcatalog hresources hcollision hvalidation + have hevidence := checkConstMember_sound context hmethods + hmethodPolicy hingress hcovers hresources huvars hgetPost.1.2 + hgetPost.1.1 hfault hrun + exact ⟨⟨hingress, hevidence.2⟩, hevidence.1⟩ + +/-- Lift the fresh-member theorem through the exact standalone branch of +`RecM.checkConst`. The first required lookup and router are both executed +before the production reset; `StandaloneRoute` makes the E0 boundary +explicit and rules out silently treating block acceptance as member +acceptance. -/ +theorem checkConst_standalone_pending_sound + {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {model : KernelSuffixModel trProj world} + {calls : Methods.CallDomain} {methods : Methods .anon} + (context : StandalonePipelineResources + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars calls methods) + (hmethods : Methods.WFAtOn .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars calls (Methods.next methods)) + (hmethodPolicy : (Methods.next methods).PreservesInferOnly) + {id : KId .anon} {concrete : KConst .anon} + {decl : Lean4Lean.VDecl} + (hprojection : trProj.SubstCompatible) + (hliterals : ∀ literal, world.venv.ContainsLits literal) + (hpending : PendingDecl trProj world id decl) + (hcatalog : world.catalog id = some concrete) + (hresources : StandaloneValidationResources support concrete) + (hcovers : context.Covers concrete) + (hcollision : support.CollisionFree) + (huvars : model.keys.uvars = concrete.lvls.toNat) + (hroute : StandaloneRoute + (WhnfStateInv .noAccel (kernelCacheSemantics model.keys trProj) + trProj world support model.keys.uvars []) methods concrete) + {before after : TcState .anon} + (hI : WhnfStateInv .noAccel + (kernelCacheSemantics model.keys trProj) trProj world support + model.keys.uvars [] before) + (hfault : TcM.LazyFaultPreserves + (WhnfStateInv .noAccel (kernelCacheSemantics model.keys trProj) + trProj world support model.keys.uvars [])) + (hrun : (checkConst id).run methods before = .ok () after) : + StandaloneCheckResult trProj world support id concrete decl ∧ + ∃ world', + Promotes world (fun target => target = id) world' ∧ + WhnfStateInv .noAccel + (kernelCacheSemantics model.keys trProj) trProj world' support + model.keys.uvars [] after ∧ + TrustedDecl trProj world' id decl := by + unfold checkConst at hrun + simp only [ReaderT.run_bind, ReaderT.run_monadLift] at hrun + change EStateM.bind (TcM.getConst id) _ before = .ok () after at hrun + unfold EStateM.bind at hrun + cases hget : TcM.getConst id before with + | error err failed => + rw [hget] at hrun + contradiction + | ok found afterLookup => + rw [hget] at hrun + have hgetPost := TcM.getConst_loaded_wf hfault id before hI + rw [hget] at hgetPost + have hfoundCatalog : world.catalog id = some found := + hgetPost.1.1.core.loaded hgetPost.2 + have hfound : found = concrete := + Option.some.inj (hfoundCatalog.symm.trans hcatalog) + subst found + change EStateM.bind ((coordinatedBlockFor concrete).run methods) _ + afterLookup = .ok () after at hrun + unfold EStateM.bind at hrun + cases hselected : (coordinatedBlockFor concrete).run methods afterLookup with + | error err failed => + rw [hselected] at hrun + contradiction + | ok selected afterRoute => + rw [hselected] at hrun + have hroutePost := hroute afterLookup hgetPost.1 + rw [hselected] at hroutePost + have hnone : selected = none := hroutePost.2 + subst selected + exact checkConstMemberFresh_pending_sound context hmethods + hmethodPolicy hprojection hliterals hpending hcatalog hresources + hcovers hcollision huvars hroutePost.1.1 hroutePost.1.2.2 hfault + hrun + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/UncachedInferencePolicy.lean b/Ix/Tc/Verify/Check/UncachedInferencePolicy.lean new file mode 100644 index 000000000..531141c0d --- /dev/null +++ b/Ix/Tc/Verify/Check/UncachedInferencePolicy.lean @@ -0,0 +1,289 @@ +import Ix.Tc.Verify.Check.UniverseInstantiationPolicy +import Ix.Tc.Verify.Check.FullInferenceProjections + +/-! +# Operational policy for uncached inference + +The production inference dispatcher temporarily mutates several checker +fields, opens local-context scopes, and delegates through the recursive +method table. This module proves independently of semantic typing that one +uncached dispatcher layer preserves the caller's `inferOnly` policy on both +success and partial error. + +The projection branch remains an explicit input because its helper contains +its own recursive WHNF and inference loops. Closing that helper supplies the +last premise needed to feed this theorem into the already verified inference +cache shell. +-/ + +namespace Ix.Tc + +namespace RecM + +private theorem prims_preservesInferOnly (methods : Methods .anon) : + ((prims : RecM .anon (Primitives .anon)).run methods).PreservesInferOnly := by + unfold prims + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind TcM.PreservesInferOnly.get + intro state + exact TcM.PreservesInferOnly.pure state.prims + +theorem inferUncached_preservesInferOnly + (methods : Methods .anon) + (hmethods : methods.PreservesInferOnly) + (hwhnf : ∀ source, + ((RecM.whnf source).run methods).PreservesInferOnly) + (hprojection : ProjectionInference.PreservesInferOnlyAt methods) + (inferOnly : Bool) (source : KExpr .anon) : + ((inferUncached inferCall inferOnly source).run methods).PreservesInferOnly := by + cases source with + | var idx name info => + simpa [inferUncached] using TcM.PreservesInferOnly.lookupVar idx + | fvar id name info => + unfold inferUncached + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind TcM.PreservesInferOnly.get + intro state + split + · exact TcM.PreservesInferOnly.pure _ + · exact TcM.PreservesInferOnly.throw _ + | sort u info => + simpa [inferUncached] using + (TcM.PreservesInferOnly.runIntern + (internExprM (KExpr.mkSort (KUniv.mkSucc u)))) + | const id levels info => + unfold inferUncached + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.getConst id) + intro concrete + split + · exact TcM.PreservesInferOnly.throw _ + · exact TcM.PreservesInferOnly.instantiateUnivParams + concrete.ty levels + | app f a info => + unfold inferUncached + simp only [ReaderT.run_bind, ReaderT.run_monadLift, inferCall, + isDefEqCall] + apply TcM.PreservesInferOnly.bind (hmethods.infer f) + intro fTy + apply TcM.PreservesInferOnly.bind + (ensureForallDirect_preservesInferOnly hwhnf) + intro domCod + rcases domCod with ⟨dom, cod⟩ + cases inferOnly with + | true => + exact TcM.PreservesInferOnly.runIntern (subst cod a 0) + | false => + apply TcM.PreservesInferOnly.bind (hmethods.infer a) + intro aTy + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.isEagerReduce a) + intro isEager + cases isEager with + | false => + simp only [Bool.false_eq_true, if_false, pure_bind] + apply TcM.PreservesInferOnly.bind (hmethods.isDefEq aTy dom) + intro equal + cases equal with + | false => + simp only [Bool.not_false, if_true] + apply TcM.PreservesInferOnly.bind + TcM.PreservesInferOnly.get + intro state + exact TcM.PreservesInferOnly.throw (alpha := KExpr .anon) + (.appTypeMismatch aTy dom state.ctx.size) + | true => + simp only [Bool.not_true] + exact TcM.PreservesInferOnly.runIntern (subst cod a 0) + | true => + simp only [if_true] + show ((do + modify fun state : TcState .anon => + { state with eagerReduce := true } + let equal ← isDefEqCall aTy dom + modify fun state : TcState .anon => + { state with eagerReduce := false } + if !equal then + throw (TcError.appTypeMismatch aTy dom (← get).ctx.size) + TcM.runIntern (subst cod a 0) : RecM .anon (KExpr .anon)).run + methods).PreservesInferOnly + simp only [ReaderT.run_bind, ReaderT.run_monadLift, + isDefEqCall] + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.modify + (f := fun state : TcState .anon => + { state with eagerReduce := true }) (fun _ => rfl)) + intro _ + apply TcM.PreservesInferOnly.bind (hmethods.isDefEq aTy dom) + intro equal + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.modify + (f := fun state : TcState .anon => + { state with eagerReduce := false }) (fun _ => rfl)) + intro _ + cases equal with + | false => + simp only [Bool.not_false, if_true] + apply TcM.PreservesInferOnly.bind + TcM.PreservesInferOnly.get + intro state + exact TcM.PreservesInferOnly.throw (alpha := KExpr .anon) + (.appTypeMismatch aTy dom state.ctx.size) + | true => + simp only [Bool.not_true, pure_bind] + exact TcM.PreservesInferOnly.runIntern (subst cod a 0) + | lam name bi ty body info => + unfold inferUncached + simp only [inferCall] + cases inferOnly with + | true => + simp only [Bool.not_true, pure_bind] + apply withLctxScope_preservesInferOnly + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.openBinder name bi ty body) + intro opened + rcases opened with ⟨bodyOpen, fvId⟩ + apply TcM.PreservesInferOnly.bind (hmethods.infer bodyOpen) + intro bodyTy + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.runIntern (cheapBetaReduce bodyTy)) + intro reduced + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.runIntern + (abstractFVars reduced #[fvId])) + intro abstracted + exact TcM.PreservesInferOnly.runIntern + (internExprM (.mkAll anonN anonBi ty abstracted)) + | false => + simp only [Bool.not_false, if_true] + apply TcM.PreservesInferOnly.bind (hmethods.infer ty) + intro tyTy + apply TcM.PreservesInferOnly.bind + (ensureSortDirect_preservesInferOnly hwhnf) + intro _ + apply withLctxScope_preservesInferOnly + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.openBinder name bi ty body) + intro opened + rcases opened with ⟨bodyOpen, fvId⟩ + apply TcM.PreservesInferOnly.bind (hmethods.infer bodyOpen) + intro bodyTy + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.runIntern (cheapBetaReduce bodyTy)) + intro reduced + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.runIntern + (abstractFVars reduced #[fvId])) + intro abstracted + exact TcM.PreservesInferOnly.runIntern + (internExprM (.mkAll anonN anonBi ty abstracted)) + | all name bi ty body info => + unfold inferUncached + simp only [ReaderT.run_bind, ReaderT.run_monadLift, inferCall] + apply TcM.PreservesInferOnly.bind (hmethods.infer ty) + intro tyTy + apply TcM.PreservesInferOnly.bind + (ensureSortDirect_preservesInferOnly hwhnf) + intro domainLevel + apply withLctxScope_preservesInferOnly + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.openBinder name bi ty body) + intro opened + rcases opened with ⟨bodyOpen, _⟩ + apply TcM.PreservesInferOnly.bind (hmethods.infer bodyOpen) + intro bodyTy + apply TcM.PreservesInferOnly.bind + (ensureSortDirect_preservesInferOnly hwhnf) + intro bodyLevel + exact TcM.PreservesInferOnly.runIntern + (internExprM (.mkSort (.mkIMax domainLevel bodyLevel))) + | letE name ty value body nondep info => + unfold inferUncached + simp only [inferCall, isDefEqCall] + cases inferOnly with + | true => + simp only [Bool.not_true, pure_bind] + apply withLctxScope_preservesInferOnly + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.openLet name ty value body) + intro opened + rcases opened with ⟨bodyOpen, fvId⟩ + apply TcM.PreservesInferOnly.bind (hmethods.infer bodyOpen) + intro bodyTy + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.runIntern + (abstractFVars bodyTy #[fvId])) + intro abstracted + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.runIntern + (subst abstracted value 0)) + intro substituted + exact TcM.PreservesInferOnly.runIntern + (cheapBetaReduce substituted) + | false => + simp only [Bool.not_false, if_true] + apply TcM.PreservesInferOnly.bind (hmethods.infer ty) + intro tyTy + apply TcM.PreservesInferOnly.bind + (ensureSortDirect_preservesInferOnly hwhnf) + intro _ + apply TcM.PreservesInferOnly.bind (hmethods.infer value) + intro valueTy + apply TcM.PreservesInferOnly.bind (hmethods.isDefEq valueTy ty) + intro equal + cases equal with + | false => + simp only [Bool.not_false, if_true] + exact TcM.PreservesInferOnly.throw (alpha := KExpr .anon) + .declTypeMismatch + | true => + simp only [Bool.not_true, pure_bind] + apply withLctxScope_preservesInferOnly + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.openLet name ty value body) + intro opened + rcases opened with ⟨bodyOpen, fvId⟩ + apply TcM.PreservesInferOnly.bind (hmethods.infer bodyOpen) + intro bodyTy + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.runIntern + (abstractFVars bodyTy #[fvId])) + intro abstracted + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.runIntern + (subst abstracted value 0)) + intro substituted + exact TcM.PreservesInferOnly.runIntern + (cheapBetaReduce substituted) + | prj id field value info => + unfold inferUncached + simp only [ReaderT.run_bind, ReaderT.run_monadLift, inferCall] + apply TcM.PreservesInferOnly.bind (hmethods.infer value) + intro valueTy + exact hprojection id field value valueTy + | nat value blob info => + unfold inferUncached + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.PreservesInferOnly.bind + (prims_preservesInferOnly methods) + intro primitives + exact TcM.PreservesInferOnly.runIntern + (internExprM (.mkConst primitives.nat #[])) + | str value blob info => + unfold inferUncached + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.PreservesInferOnly.bind + (prims_preservesInferOnly methods) + intro primitives + exact TcM.PreservesInferOnly.runIntern + (internExprM (.mkConst primitives.string #[])) + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/UniverseInstantiationPolicy.lean b/Ix/Tc/Verify/Check/UniverseInstantiationPolicy.lean new file mode 100644 index 000000000..a418ed365 --- /dev/null +++ b/Ix/Tc/Verify/Check/UniverseInstantiationPolicy.lean @@ -0,0 +1,296 @@ +import Ix.Tc.Verify.Check.InferencePolicy + +/-! +# Inference-policy frame for universe instantiation + +`TcM.instantiateUnivParams` is a memoized `StateT` walk over an expression +DAG. Its semantic verification needs collision and reachability resources, +but its operational noninterference fact does not: the walk can throw while +substituting a universe, and otherwise changes only its private memo table and +the kernel intern table. + +This module proves that unconditional operational fact directly over the +production walker. It covers memo hits, every expression constructor, the +constant-universe array loop, recursive child failures, interning, and memo +writes on both outcomes. +-/ + +namespace Ix.Tc + +namespace TcM.PreservesInferOnly + +theorem ofExcept (value : Except (TcError .anon) alpha) : + (TcM.ofExcept value).PreservesInferOnly := by + cases value with + | ok value => exact pure value + | error err => exact throw err + +theorem map {x : TcM .anon alpha} (hx : x.PreservesInferOnly) + (f : alpha → beta) : (f <$> x).PreservesInferOnly := by + rw [← bind_pure_comp] + exact bind hx fun value => pure (f value) + +private def StatePreservesInferOnly + (x : StateT sigma (TcM .anon) alpha) : Prop := + ∀ memo, (x.run memo).PreservesInferOnly + +private theorem statePure (value : alpha) : + StatePreservesInferOnly + (Pure.pure value : StateT sigma (TcM .anon) alpha) := by + intro memo + simp only [StateT.run_pure] + exact TcM.PreservesInferOnly.pure _ + +private theorem stateBind {x : StateT sigma (TcM .anon) alpha} + {f : alpha → StateT sigma (TcM .anon) beta} + (hx : StatePreservesInferOnly x) + (hf : ∀ value, StatePreservesInferOnly (f value)) : + StatePreservesInferOnly (x >>= f) := by + intro memo + simp only [StateT.run_bind] + apply TcM.PreservesInferOnly.bind (hx memo) + intro pair + exact hf pair.1 pair.2 + +private theorem stateGet : + StatePreservesInferOnly + (MonadState.get : StateT sigma (TcM .anon) sigma) := by + intro memo + simp only [StateT.run_get] + exact TcM.PreservesInferOnly.pure _ + +private theorem stateModify (f : sigma → sigma) : + StatePreservesInferOnly + (_root_.modify f : StateT sigma (TcM .anon) PUnit) := by + intro memo + simp only [StateT.run_modify] + exact TcM.PreservesInferOnly.pure _ + +private theorem stateLift {x : TcM .anon alpha} + (hx : x.PreservesInferOnly) : + StatePreservesInferOnly + (monadLift x : StateT sigma (TcM .anon) alpha) := by + intro memo + simp only [StateT.run_monadLift] + apply TcM.PreservesInferOnly.bind hx + intro value + exact TcM.PreservesInferOnly.pure _ + +private theorem stateForInArray + (items : Array alpha) (initial : beta) + (step : alpha → beta → + StateT sigma (TcM .anon) (ForInStep beta)) + (hstep : ∀ item state, + StatePreservesInferOnly (step item state)) : + StatePreservesInferOnly (forIn items initial step) := by + rcases items with ⟨items⟩ + simp only [List.forIn_toArray] + induction items generalizing initial with + | nil => + simp + exact statePure initial + | cons item rest ih => + rw [List.forIn_cons] + apply stateBind (hstep item initial) + intro action + cases action with + | done result => exact statePure result + | yield next => exact ih next + +private theorem stateInternMemo (key : Address) (result : KExpr .anon) : + StatePreservesInferOnly (do + let interned ← monadLift (TcM.intern result) + _root_.modify fun memo : Std.HashMap Address (KExpr .anon) => + memo.insert key interned + Pure.pure interned) := by + apply stateBind (stateLift (runIntern _)) + intro interned + apply stateBind (stateModify _) + intro _ + exact statePure interned + +/-- Universe instantiation cannot change the inference-policy bit. The +statement is unconditional because collision freedom is relevant to the +walker's semantic result, not to which `TcState` fields it can mutate. -/ +theorem instantiateUnivParams (e : KExpr .anon) + (us : Array (KUniv .anon)) : + (TcM.instantiateUnivParams e us).PreservesInferOnly := by + unfold TcM.instantiateUnivParams + split + · exact pure e + · have hinner : ∀ (source : KExpr .anon), + StatePreservesInferOnly (TcM.instUnivInner source us) := by + intro source + induction source with + | var idx name info => + simp only [TcM.instUnivInner] + apply stateBind stateGet + intro memo + split + · exact statePure _ + · apply stateBind (stateModify _) + intro _ + exact statePure (KExpr.var idx name info) + | fvar id name info => + simp only [TcM.instUnivInner] + apply stateBind stateGet + intro memo + split + · exact statePure _ + · apply stateBind (stateModify _) + intro _ + exact statePure (KExpr.fvar id name info) + | sort u info => + simp only [TcM.instUnivInner] + apply stateBind stateGet + intro memo + split + · exact statePure _ + · apply stateBind (statePure PUnit.unit) + intro _ + apply stateBind (stateLift (ofExcept (substUniv u us))) + intro resultUniv + apply stateBind (statePure (KExpr.mkSort resultUniv)) + intro result + exact stateInternMemo (KExpr.sort u info).addr result + | const id levels info => + rw [TcM.instUnivInner] + simp (config := { proj := false }) only [] + apply stateBind stateGet + intro memo + split + · exact statePure _ + · apply stateBind (statePure PUnit.unit) + intro _ + apply stateBind + (stateForInArray levels (Array.mkEmpty levels.size) + (fun level current => do + let instantiated ← + monadLift (TcM.ofExcept (substUniv level us)) + let next := current.push instantiated + Pure.pure PUnit.unit + Pure.pure (ForInStep.yield next)) + (by + intro level current + apply stateBind + (stateLift (ofExcept (substUniv level us))) + intro instantiated + apply stateBind (statePure PUnit.unit) + intro _ + exact statePure + (ForInStep.yield (current.push instantiated)))) + intro newLevels + apply stateBind (statePure (KExpr.mkConst id newLevels)) + intro result + exact stateInternMemo (KExpr.const id levels info).addr result + | app f a info ihf iha => + rw [TcM.instUnivInner] + simp (config := { proj := false }) only [] + apply stateBind stateGet + intro memo + split + · exact statePure _ + · apply stateBind (statePure PUnit.unit) + intro _ + apply stateBind ihf + intro resultF + apply stateBind iha + intro resultA + apply stateBind (statePure (KExpr.mkApp resultF resultA)) + intro result + exact stateInternMemo (KExpr.app f a info).addr result + | lam name bi ty body info ihty ihbody => + rw [TcM.instUnivInner] + simp (config := { proj := false }) only [] + apply stateBind stateGet + intro memo + split + · exact statePure _ + · apply stateBind (statePure PUnit.unit) + intro _ + apply stateBind ihty + intro resultTy + apply stateBind ihbody + intro resultBody + apply stateBind + (statePure (KExpr.mkLam name bi resultTy resultBody)) + intro result + exact stateInternMemo (KExpr.lam name bi ty body info).addr result + | all name bi ty body info ihty ihbody => + rw [TcM.instUnivInner] + simp (config := { proj := false }) only [] + apply stateBind stateGet + intro memo + split + · exact statePure _ + · apply stateBind (statePure PUnit.unit) + intro _ + apply stateBind ihty + intro resultTy + apply stateBind ihbody + intro resultBody + apply stateBind + (statePure (KExpr.mkAll name bi resultTy resultBody)) + intro result + exact stateInternMemo (KExpr.all name bi ty body info).addr result + | letE name ty value body nondep info ihty ihvalue ihbody => + rw [TcM.instUnivInner] + simp (config := { proj := false }) only [] + apply stateBind stateGet + intro memo + split + · exact statePure _ + · apply stateBind (statePure PUnit.unit) + intro _ + apply stateBind ihty + intro resultTy + apply stateBind ihvalue + intro resultValue + apply stateBind ihbody + intro resultBody + apply stateBind + (statePure + (KExpr.mkLet name resultTy resultValue resultBody nondep)) + intro result + exact stateInternMemo + (KExpr.letE name ty value body nondep info).addr result + | prj id field value info ih => + rw [TcM.instUnivInner] + simp (config := { proj := false }) only [] + apply stateBind stateGet + intro memo + split + · exact statePure _ + · apply stateBind (statePure PUnit.unit) + intro _ + apply stateBind ih + intro resultValue + apply stateBind + (statePure (KExpr.mkPrj id field resultValue)) + intro result + exact stateInternMemo (KExpr.prj id field value info).addr result + | nat value blob info => + simp only [TcM.instUnivInner] + apply stateBind stateGet + intro memo + split + · exact statePure _ + · apply stateBind (stateModify _) + intro _ + exact statePure (KExpr.nat value blob info) + | str value blob info => + simp only [TcM.instUnivInner] + apply stateBind stateGet + intro memo + split + · exact statePure _ + · apply stateBind (stateModify _) + intro _ + exact statePure (KExpr.str value blob info) + have hrun := hinner e ({} : Std.HashMap Address (KExpr .anon)) + unfold StateT.run' + exact map hrun Prod.fst + +end TcM.PreservesInferOnly + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/ValidationReach.lean b/Ix/Tc/Verify/Check/ValidationReach.lean new file mode 100644 index 000000000..23181e518 --- /dev/null +++ b/Ix/Tc/Verify/Check/ValidationReach.lean @@ -0,0 +1,407 @@ +import Ix.Tc.Verify.Check.Scoped +import Ix.Tc.Verify.Support + +/-! +# Finite syntax support for well-scopedness validation + +The production validators memoize by content address. Their soundness +therefore needs collision freedom on exactly the finite syntax they may +visit, rather than a global injectivity axiom. This module names that +syntax: expression descendants and the universe descendants embedded in +sort and constant nodes. + +The reach relations contain no validation or typing fact. `Coverage` only +connects their finite footprints to an existing `RunSupport`, whose separate +`CollisionFree` field is consumed by the operational proof. +-/ + +namespace Ix.Tc + +namespace KUniv + +/-- Direct worklist children in the production validator's LIFO order. -/ +def validationChildren : KUniv .anon → List (KUniv .anon) + | .succ child _ => [child] + | .max left right _ | .imax left right _ => [right, left] + | .zero _ | .param .. => [] + +/-- Reflexive structural descent through a universe expression. -/ +inductive ValidationReach : KUniv .anon → KUniv .anon → Prop + | refl (u : KUniv .anon) : ValidationReach u u + | succ {u child : KUniv .anon} {addr : Address} : + ValidationReach u child → + ValidationReach (.succ u addr) child + | maxLeft {left right child : KUniv .anon} {addr : Address} : + ValidationReach left child → + ValidationReach (.max left right addr) child + | maxRight {left right child : KUniv .anon} {addr : Address} : + ValidationReach right child → + ValidationReach (.max left right addr) child + | imaxLeft {left right child : KUniv .anon} {addr : Address} : + ValidationReach left child → + ValidationReach (.imax left right addr) child + | imaxRight {left right child : KUniv .anon} {addr : Address} : + ValidationReach right child → + ValidationReach (.imax left right addr) child + +namespace ValidationReach + +/-- Structural validation reach composes. -/ +theorem trans {root middle child : KUniv .anon} + (hroot : ValidationReach root middle) + (hmiddle : ValidationReach middle child) : + ValidationReach root child := by + induction hroot with + | refl => exact hmiddle + | succ _ ih => exact .succ (ih hmiddle) + | maxLeft _ ih => exact .maxLeft (ih hmiddle) + | maxRight _ ih => exact .maxRight (ih hmiddle) + | imaxLeft _ ih => exact .imaxLeft (ih hmiddle) + | imaxRight _ ih => exact .imaxRight (ih hmiddle) + +/-- A direct validator child is structurally reachable. -/ +theorem child {parent child : KUniv .anon} + (hchild : child ∈ parent.validationChildren) : + ValidationReach parent child := by + cases parent with + | zero => simp [validationChildren] at hchild + | succ parent addr => + simp only [validationChildren, List.mem_singleton] at hchild + subst child + exact .succ (.refl _) + | max left right addr => + simp [validationChildren] at hchild + rcases hchild with rfl | rfl + · exact .maxRight (.refl _) + · exact .maxLeft (.refl _) + | imax left right addr => + simp [validationChildren] at hchild + rcases hchild with rfl | rfl + · exact .imaxRight (.refl _) + · exact .imaxLeft (.refl _) + | param => simp [validationChildren] at hchild + +end ValidationReach + +/-- The local guard checked when a universe node is first inserted into the +memo set. Composite nodes have no local obligation; their children are +represented by the validation frontier. -/ +def ValidationLocal (bound : Nat) : KUniv .anon → Prop + | .param idx _ _ => idx.toNat < bound + | _ => True + +/-- A finite run support covers a universe domain, and that domain is closed +under exactly the child edges followed by the validator. -/ +structure ValidationDomain (support : RunSupport) + (domain : KUniv .anon → Prop) : Prop where + covered : ∀ ⦃level⦄, domain level → support.univ level + child : ∀ ⦃parent child⦄, domain parent → + child ∈ parent.validationChildren → domain child + +/-- Local guard validity at every reachable node implies full universe +scoping. -/ +theorem scoped_of_validationLocal + {root : KUniv .anon} {bound : Nat} + (hall : ∀ ⦃u⦄, ValidationReach root u → u.ValidationLocal bound) : + root.Scoped bound := by + induction root with + | zero => trivial + | succ child addr ih => + apply ih + intro u hu + exact hall (.succ hu) + | max left right addr ihLeft ihRight => + exact ⟨ihLeft (fun _ h => hall (.maxLeft h)), + ihRight (fun _ h => hall (.maxRight h))⟩ + | imax left right addr ihLeft ihRight => + exact ⟨ihLeft (fun _ h => hall (.imaxLeft h)), + ihRight (fun _ h => hall (.imaxRight h))⟩ + | param idx name addr => exact hall (.refl _) + +end KUniv + +namespace KExpr + +/-- Direct expression worklist children, including the exact depth attached +by the production validator. -/ +def validationChildrenAt (depth : UInt64) : + KExpr .anon → List (KExpr .anon × UInt64) + | .app fn arg _ => [(arg, depth), (fn, depth)] + | .lam _ _ type body _ | .all _ _ type body _ => + [(body, depth + 1), (type, depth)] + | .letE _ type value body _ _ => + [(body, depth + 1), (value, depth), (type, depth)] + | .prj _ _ value _ => [(value, depth)] + | _ => [] + +/-- Universe roots passed directly to `validateUnivParamsSeen` at one +expression node. -/ +def validationUnivRoots : KExpr .anon → List (KUniv .anon) + | .sort level _ => [level] + | .const _ levels _ => levels.toList + | _ => [] + +/-- Reflexive structural descent through expression children. Universes +are tracked by the separate `ValidationUnivReach` relation below. -/ +inductive ValidationReach : KExpr .anon → KExpr .anon → Prop + | refl (e : KExpr .anon) : ValidationReach e e + | appFn {fn arg child : KExpr .anon} {info : ExprInfo .anon} : + ValidationReach fn child → + ValidationReach (.app fn arg info) child + | appArg {fn arg child : KExpr .anon} {info : ExprInfo .anon} : + ValidationReach arg child → + ValidationReach (.app fn arg info) child + | lamType {type body child : KExpr .anon} + {name : Mode.anon.F Name} {bi : Mode.anon.F Lean.BinderInfo} + {info : ExprInfo .anon} : + ValidationReach type child → + ValidationReach (.lam name bi type body info) child + | lamBody {type body child : KExpr .anon} + {name : Mode.anon.F Name} {bi : Mode.anon.F Lean.BinderInfo} + {info : ExprInfo .anon} : + ValidationReach body child → + ValidationReach (.lam name bi type body info) child + | allType {type body child : KExpr .anon} + {name : Mode.anon.F Name} {bi : Mode.anon.F Lean.BinderInfo} + {info : ExprInfo .anon} : + ValidationReach type child → + ValidationReach (.all name bi type body info) child + | allBody {type body child : KExpr .anon} + {name : Mode.anon.F Name} {bi : Mode.anon.F Lean.BinderInfo} + {info : ExprInfo .anon} : + ValidationReach body child → + ValidationReach (.all name bi type body info) child + | letType {type value body child : KExpr .anon} + {name : Mode.anon.F Name} {nonDep : Bool} + {info : ExprInfo .anon} : + ValidationReach type child → + ValidationReach (.letE name type value body nonDep info) child + | letValue {type value body child : KExpr .anon} + {name : Mode.anon.F Name} {nonDep : Bool} + {info : ExprInfo .anon} : + ValidationReach value child → + ValidationReach (.letE name type value body nonDep info) child + | letBody {type value body child : KExpr .anon} + {name : Mode.anon.F Name} {nonDep : Bool} + {info : ExprInfo .anon} : + ValidationReach body child → + ValidationReach (.letE name type value body nonDep info) child + | projectionValue {value child : KExpr .anon} {id : KId .anon} + {field : UInt64} {info : ExprInfo .anon} : + ValidationReach value child → + ValidationReach (.prj id field value info) child + +namespace ValidationReach + +/-- Expression validation reach composes. -/ +theorem trans {root middle child : KExpr .anon} + (hroot : ValidationReach root middle) + (hmiddle : ValidationReach middle child) : + ValidationReach root child := by + induction hroot with + | refl => exact hmiddle + | appFn _ ih => exact .appFn (ih hmiddle) + | appArg _ ih => exact .appArg (ih hmiddle) + | lamType _ ih => exact .lamType (ih hmiddle) + | lamBody _ ih => exact .lamBody (ih hmiddle) + | allType _ ih => exact .allType (ih hmiddle) + | allBody _ ih => exact .allBody (ih hmiddle) + | letType _ ih => exact .letType (ih hmiddle) + | letValue _ ih => exact .letValue (ih hmiddle) + | letBody _ ih => exact .letBody (ih hmiddle) + | projectionValue _ ih => exact .projectionValue (ih hmiddle) + +/-- A direct expression-validator work item is structurally reachable. -/ +theorem childAt {parent child : KExpr .anon} {parentDepth childDepth : UInt64} + (hchild : (child, childDepth) ∈ + parent.validationChildrenAt parentDepth) : + ValidationReach parent child := by + cases parent with + | var | fvar | sort | const | nat | str => + simp [validationChildrenAt] at hchild + | app fn arg info => + simp [validationChildrenAt] at hchild + rcases hchild with ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ + · exact .appArg (.refl _) + · exact .appFn (.refl _) + | lam name bi type body info => + simp [validationChildrenAt] at hchild + rcases hchild with ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ + · exact .lamBody (.refl _) + · exact .lamType (.refl _) + | all name bi type body info => + simp [validationChildrenAt] at hchild + rcases hchild with ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ + · exact .allBody (.refl _) + · exact .allType (.refl _) + | letE name type value body nonDep info => + simp [validationChildrenAt] at hchild + rcases hchild with ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ + · exact .letBody (.refl _) + · exact .letValue (.refl _) + · exact .letType (.refl _) + | prj id field value info => + simp only [validationChildrenAt, List.mem_singleton, Prod.mk.injEq] + at hchild + rcases hchild with ⟨rfl, rfl⟩ + exact .projectionValue (.refl _) + +end ValidationReach + +/-- Universe nodes reachable from an expression, including every structural +descendant of each sort level or constant universe argument. -/ +inductive ValidationUnivReach : KExpr .anon → KUniv .anon → Prop + | sort {root child : KUniv .anon} {info : ExprInfo .anon} : + KUniv.ValidationReach root child → + ValidationUnivReach (.sort root info) child + | const {levels : Array (KUniv .anon)} {root child : KUniv .anon} + {id : KId .anon} {info : ExprInfo .anon} : + root ∈ levels → + KUniv.ValidationReach root child → + ValidationUnivReach (.const id levels info) child + | appFn {fn arg : KExpr .anon} {level : KUniv .anon} + {info : ExprInfo .anon} : + ValidationUnivReach fn level → + ValidationUnivReach (.app fn arg info) level + | appArg {fn arg : KExpr .anon} {level : KUniv .anon} + {info : ExprInfo .anon} : + ValidationUnivReach arg level → + ValidationUnivReach (.app fn arg info) level + | lamType {type body : KExpr .anon} {level : KUniv .anon} + {name : Mode.anon.F Name} {bi : Mode.anon.F Lean.BinderInfo} + {info : ExprInfo .anon} : + ValidationUnivReach type level → + ValidationUnivReach (.lam name bi type body info) level + | lamBody {type body : KExpr .anon} {level : KUniv .anon} + {name : Mode.anon.F Name} {bi : Mode.anon.F Lean.BinderInfo} + {info : ExprInfo .anon} : + ValidationUnivReach body level → + ValidationUnivReach (.lam name bi type body info) level + | allType {type body : KExpr .anon} {level : KUniv .anon} + {name : Mode.anon.F Name} {bi : Mode.anon.F Lean.BinderInfo} + {info : ExprInfo .anon} : + ValidationUnivReach type level → + ValidationUnivReach (.all name bi type body info) level + | allBody {type body : KExpr .anon} {level : KUniv .anon} + {name : Mode.anon.F Name} {bi : Mode.anon.F Lean.BinderInfo} + {info : ExprInfo .anon} : + ValidationUnivReach body level → + ValidationUnivReach (.all name bi type body info) level + | letType {type value body : KExpr .anon} {level : KUniv .anon} + {name : Mode.anon.F Name} {nonDep : Bool} + {info : ExprInfo .anon} : + ValidationUnivReach type level → + ValidationUnivReach (.letE name type value body nonDep info) level + | letValue {type value body : KExpr .anon} {level : KUniv .anon} + {name : Mode.anon.F Name} {nonDep : Bool} + {info : ExprInfo .anon} : + ValidationUnivReach value level → + ValidationUnivReach (.letE name type value body nonDep info) level + | letBody {type value body : KExpr .anon} {level : KUniv .anon} + {name : Mode.anon.F Name} {nonDep : Bool} + {info : ExprInfo .anon} : + ValidationUnivReach body level → + ValidationUnivReach (.letE name type value body nonDep info) level + | projectionValue {value : KExpr .anon} {level : KUniv .anon} + {id : KId .anon} {field : UInt64} {info : ExprInfo .anon} : + ValidationUnivReach value level → + ValidationUnivReach (.prj id field value info) level + +namespace ValidationUnivReach + +/-- Universe reach remains inside the expression footprint when descending +further through a universe node. -/ +theorem trans {root : KExpr .anon} {level child : KUniv .anon} + (hlevel : ValidationUnivReach root level) + (hchild : KUniv.ValidationReach level child) : + ValidationUnivReach root child := by + induction hlevel with + | sort hreach => exact .sort (hreach.trans hchild) + | const hmem hreach => exact .const hmem (hreach.trans hchild) + | appFn _ ih => exact .appFn (ih hchild) + | appArg _ ih => exact .appArg (ih hchild) + | lamType _ ih => exact .lamType (ih hchild) + | lamBody _ ih => exact .lamBody (ih hchild) + | allType _ ih => exact .allType (ih hchild) + | allBody _ ih => exact .allBody (ih hchild) + | letType _ ih => exact .letType (ih hchild) + | letValue _ ih => exact .letValue (ih hchild) + | letBody _ ih => exact .letBody (ih hchild) + | projectionValue _ ih => exact .projectionValue (ih hchild) + +end ValidationUnivReach + +namespace ValidationReach + +/-- Universe reach lifts through an expression-reach path. -/ +theorem validationUniv + {root nested : KExpr .anon} {level : KUniv .anon} + (hroot : ValidationReach root nested) + (hnested : ValidationUnivReach nested level) : + ValidationUnivReach root level := by + induction hroot with + | refl => exact hnested + | appFn _ ih => exact .appFn (ih hnested) + | appArg _ ih => exact .appArg (ih hnested) + | lamType _ ih => exact .lamType (ih hnested) + | lamBody _ ih => exact .lamBody (ih hnested) + | allType _ ih => exact .allType (ih hnested) + | allBody _ ih => exact .allBody (ih hnested) + | letType _ ih => exact .letType (ih hnested) + | letValue _ ih => exact .letValue (ih hnested) + | letBody _ ih => exact .letBody (ih hnested) + | projectionValue _ ih => exact .projectionValue (ih hnested) + +/-- A direct universe root at a reachable expression node belongs to the +root expression's universe footprint. -/ +theorem univRoot + {root nested : KExpr .anon} {level : KUniv .anon} + (hroot : ValidationReach root nested) + (hlevel : level ∈ nested.validationUnivRoots) : + ValidationUnivReach root level := by + apply hroot.validationUniv + cases nested with + | var | fvar | app | lam | all | letE | prj | nat | str => + simp [validationUnivRoots] at hlevel + | sort level info => + simp only [validationUnivRoots, List.mem_singleton] at hlevel + subst level + exact .sort (.refl _) + | const id levels info => + exact .const (by simpa [validationUnivRoots] using hlevel) (.refl _) + +end ValidationReach + +/-- The local expression guard checked when a `(node, depth)` key is first +inserted into the memo set. -/ +def ValidationLocal (depth : UInt64) : KExpr .anon → Prop + | .var idx _ _ => idx < depth + | _ => True + +/-- A finite run support covers the exact syntax footprint of one expression +validation. -/ +structure ValidationCoverage (support : RunSupport) + (root : KExpr .anon) : Prop where + expr : ∀ ⦃candidate⦄, ValidationReach root candidate → support candidate + univ : ∀ ⦃level⦄, ValidationUnivReach root level → support.univ level + +namespace ValidationCoverage + +theorem root {support : RunSupport} {root : KExpr .anon} + (h : ValidationCoverage support root) : support root := + h.expr (.refl root) + +/-- The universes embedded in an expression validation form a child-closed +domain covered by the same finite run support. -/ +theorem univDomain {support : RunSupport} {root : KExpr .anon} + (h : ValidationCoverage support root) : + KUniv.ValidationDomain support (ValidationUnivReach root) where + covered := h.univ + child := fun {_ _} hparent hchild => + hparent.trans (.child hchild) + +end ValidationCoverage + +end KExpr + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/ValidatorFrame.lean b/Ix/Tc/Verify/Check/ValidatorFrame.lean new file mode 100644 index 000000000..57c8e56f4 --- /dev/null +++ b/Ix/Tc/Verify/Check/ValidatorFrame.lean @@ -0,0 +1,319 @@ +import Ix.Tc.Verify.Check.DeclarationValidation +import Ix.Tc.Verify.Whnf.RuntimeContracts + +/-! +# State framing for the scoping validators + +The validator's memo sets are local worklist arguments, but constant and +projection nodes may invoke lazy ingress. Scoping soundness therefore does +not by itself show that the checker invariant is available when inference +starts. This module proves that every validator outcome preserves an +arbitrary state invariant whose installed lazy-fault hook preserves it. +-/ + +namespace Ix.Tc + +namespace RecM + +/-- The universe validator is state-pure on every successful and exceptional +path. Its seen set is an explicit result rather than checker state. -/ +theorem validateUnivParamsSeen_go_frame : + ∀ (bound : Nat) (stack : List (KUniv .anon)) + (seen : Std.HashSet Address) (methods : Methods .anon) + (I : TcState .anon → Prop) (state : TcState .anon), + TcM.WF I state + ((RecM.validateUnivParamsSeen.go bound stack seen).run methods) + (fun _ _ => True) + | bound, [], seen, methods, I, state => by + rw [RecM.validateUnivParamsSeen.go] + exact TcM.WF.pure fun _ => trivial + | bound, level :: stack, seen, methods, I, state => by + rw [RecM.validateUnivParamsSeen.go] + split + · simp only [bind_pure] + exact validateUnivParamsSeen_go_frame bound stack seen methods I state + · cases level with + | zero addr => + simp only [pure_bind] + exact validateUnivParamsSeen_go_frame bound stack + (seen.insert addr) methods I state + | succ child addr => + simp only [pure_bind] + exact validateUnivParamsSeen_go_frame bound (child :: stack) + (seen.insert addr) methods I state + | max left right addr => + simp only [pure_bind] + exact validateUnivParamsSeen_go_frame bound + (right :: left :: stack) (seen.insert addr) methods I state + | imax left right addr => + simp only [pure_bind] + exact validateUnivParamsSeen_go_frame bound + (right :: left :: stack) (seen.insert addr) methods I state + | param idx name addr => + simp only [pure_bind] + split + · exact TcM.WF.throw fun _ => trivial + · exact validateUnivParamsSeen_go_frame bound stack + (seen.insert addr) methods I state +termination_by _ stack _ _ _ _ => RecM.univWorkSize stack +decreasing_by + all_goals simp_all [RecM.univWorkSize, KUniv.size] + all_goals try omega + all_goals exact KUniv.size_pos _ + +/-- Public universe-validation framing. -/ +theorem validateUnivParamsSeen_frame + (bound : Nat) (root : KUniv .anon) (seen : Std.HashSet Address) + (methods : Methods .anon) (I : TcState .anon → Prop) + (state : TcState .anon) : + TcM.WF I state + ((RecM.validateUnivParamsSeen root bound seen).run methods) + (fun _ _ => True) := by + rw [RecM.validateUnivParamsSeen_equation] + exact validateUnivParamsSeen_go_frame bound [root] seen methods I state + +/-- List-normalized framing for the constant-universe `for` loop. -/ +theorem validateUnivRootsList_frame + (bound : Nat) : + ∀ (roots : List (KUniv .anon)) (seen : Std.HashSet Address) + (methods : Methods .anon) (I : TcState .anon → Prop) + (state : TcState .anon), + TcM.WF I state + ((forIn (m := RecM .anon) roots seen (fun level current => do + let next ← validateUnivParamsSeen level bound current + pure (.yield next))).run methods) + (fun _ _ => True) + | [], seen, methods, I, state => by + rw [List.forIn_nil] + exact TcM.WF.pure fun _ => trivial + | level :: roots, seen, methods, I, state => by + rw [List.forIn_cons, ReaderT.run_bind, ReaderT.run_bind, bind_assoc] + apply TcM.WF.bind + (validateUnivParamsSeen_frame bound level seen methods I state) + intro nextSeen nextState _ + exact validateUnivRootsList_frame bound roots nextSeen methods I + nextState + +/-- Array-level framing in the exact shape used by constant validation. -/ +theorem validateUnivRootsArray_frame + (bound : Nat) (roots : Array (KUniv .anon)) + (seen : Std.HashSet Address) (methods : Methods .anon) + (I : TcState .anon → Prop) (state : TcState .anon) : + TcM.WF I state + ((forIn (m := RecM .anon) roots seen (fun level current => do + let next ← validateUnivParamsSeen level bound current + pure (.yield next))).run methods) + (fun _ _ => True) := by + rw [← Array.forIn_toList] + exact validateUnivRootsList_frame bound roots.toList seen methods I state + +end RecM + +namespace TcM + +namespace LazyFaultPreserves + +/-- Lazy ingress never writes the checker policy bit. Any semantic hook +frame can therefore be strengthened with a fixed `inferOnly` value on both +successful and partial-error outcomes. -/ +theorem withInferOnly + {I : TcState .anon → Prop} (hfault : LazyFaultPreserves I) + (policy : Bool) : + LazyFaultPreserves (fun state => I state ∧ state.inferOnly = policy) := by + intro state fault addr hlazy hstate + have hpost := hfault (addr := addr) hlazy hstate.1 + cases hrun : fault addr state.env with + | ok found after => + rw [hrun] at hpost + exact ⟨hpost, by simpa [lazyIngressPost] using hstate.2⟩ + | error err after => + rw [hrun] at hpost + exact ⟨hpost, by simpa [lazyIngressPost] using hstate.2⟩ + +end LazyFaultPreserves + +/-- Required constant lookup preserves the invariant through hits, lazy +ingress, retry, miss conversion, and hook errors. -/ +theorem getConst_frame + {I : TcState .anon → Prop} (hfault : LazyFaultPreserves I) + (id : KId .anon) (state : TcState .anon) : + WF I state (getConst id) (fun _ _ => True) := by + unfold getConst + apply WF.bind (tryGetConst_wf hfault id state) + intro found nextState _ + cases found with + | none => exact WF.throw fun _ => trivial + | some _ => exact WF.pure fun _ => trivial + +/-- Projection-head existence has the same lazy-ingress frame as optional +constant lookup. -/ +theorem hasConst_frame + {I : TcState .anon → Prop} (hfault : LazyFaultPreserves I) + (id : KId .anon) (state : TcState .anon) : + WF I state (hasConst id) (fun _ _ => True) := by + unfold hasConst + apply WF.bind (tryGetConst_wf hfault id state) + intro _ _ _ + exact WF.pure fun _ => trivial + +end TcM + +namespace RecM + +/-- Every expression-validator branch preserves the supplied invariant. +The only non-pure branches are required/optional constant lookups, both of +which are routed through the explicit lazy-fault contract. -/ +theorem validateExprWellScoped_go_frame : + ∀ (bound : Nat) (stack : List (KExpr .anon × UInt64)) + (seenExprs : Std.HashSet (Address × UInt64)) + (seenUnivs : Std.HashSet Address) (methods : Methods .anon) + (I : TcState .anon → Prop), + TcM.LazyFaultPreserves I → + ∀ (state : TcState .anon), + TcM.WF I state + ((RecM.validateExprWellScoped.go bound stack seenExprs seenUnivs).run + methods) + (fun _ _ => True) + | bound, [], seenExprs, seenUnivs, methods, I, hfault, state => by + rw [RecM.validateExprWellScoped.go] + exact TcM.WF.pure fun _ => trivial + | bound, (expr, depth) :: stack, seenExprs, seenUnivs, methods, I, + hfault, state => by + rw [RecM.validateExprWellScoped.go] + split + · simp only [bind_pure] + exact validateExprWellScoped_go_frame bound stack seenExprs seenUnivs + methods I hfault state + · cases expr with + | var idx name info => + simp only [pure_bind] + split + · exact TcM.WF.throw fun _ => trivial + · exact validateExprWellScoped_go_frame bound stack + (seenExprs.insert ((KExpr.var idx name info).addr, depth)) + seenUnivs methods I hfault state + | fvar id name info => + simp only [pure_bind] + exact validateExprWellScoped_go_frame bound stack + (seenExprs.insert ((KExpr.fvar id name info).addr, depth)) + seenUnivs methods I hfault state + | sort level info => + simp only [pure_bind, ReaderT.run_bind] + apply TcM.WF.bind + (validateUnivParamsSeen_frame bound level seenUnivs methods I + state) + intro nextUnivs nextState _ + exact validateExprWellScoped_go_frame bound stack + (seenExprs.insert ((KExpr.sort level info).addr, depth)) + nextUnivs methods I hfault nextState + | const id levels info => + simp only [pure_bind, ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.WF.bind (TcM.getConst_frame hfault id state) + intro declaration lookupState _ + split + · exact TcM.WF.throw fun _ => trivial + · apply TcM.WF.bind + (validateUnivRootsArray_frame bound levels seenUnivs methods I + lookupState) + intro nextUnivs nextState _ + exact validateExprWellScoped_go_frame bound stack + (seenExprs.insert + ((KExpr.const id levels info).addr, depth)) nextUnivs + methods I hfault nextState + | app fn arg info => + simp only [pure_bind] + exact validateExprWellScoped_go_frame bound + ((arg, depth) :: (fn, depth) :: stack) + (seenExprs.insert ((KExpr.app fn arg info).addr, depth)) + seenUnivs methods I hfault state + | lam name bi type body info => + simp only [pure_bind] + exact validateExprWellScoped_go_frame bound + ((body, depth + 1) :: (type, depth) :: stack) + (seenExprs.insert + ((KExpr.lam name bi type body info).addr, depth)) + seenUnivs methods I hfault state + | all name bi type body info => + simp only [pure_bind] + exact validateExprWellScoped_go_frame bound + ((body, depth + 1) :: (type, depth) :: stack) + (seenExprs.insert + ((KExpr.all name bi type body info).addr, depth)) + seenUnivs methods I hfault state + | letE name type value body nonDep info => + simp only [pure_bind] + exact validateExprWellScoped_go_frame bound + ((body, depth + 1) :: (value, depth) :: (type, depth) :: stack) + (seenExprs.insert + ((KExpr.letE name type value body nonDep info).addr, depth)) + seenUnivs methods I hfault state + | prj id field value info => + simp only [pure_bind, ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.WF.bind (TcM.hasConst_frame hfault id state) + intro found nextState _ + cases found with + | false => exact TcM.WF.throw fun _ => trivial + | true => + exact validateExprWellScoped_go_frame bound + ((value, depth) :: stack) + (seenExprs.insert + ((KExpr.prj id field value info).addr, depth)) + seenUnivs methods I hfault nextState + | nat value blob info => + simp only [pure_bind] + exact validateExprWellScoped_go_frame bound stack + (seenExprs.insert ((KExpr.nat value blob info).addr, depth)) + seenUnivs methods I hfault state + | str value blob info => + simp only [pure_bind] + exact validateExprWellScoped_go_frame bound stack + (seenExprs.insert ((KExpr.str value blob info).addr, depth)) + seenUnivs methods I hfault state +termination_by _ stack _ _ _ _ _ _ => RecM.scopedExprWorkSize stack +decreasing_by + all_goals simp_all [RecM.scopedExprWorkSize, KExpr.treeSize] + all_goals try omega + +/-- Public expression-validator framing from the production empty memo sets. -/ +theorem validateExprWellScoped_frame + (root : KExpr .anon) (rootDepth : UInt64) (bound : Nat) + (methods : Methods .anon) {I : TcState .anon → Prop} + (hfault : TcM.LazyFaultPreserves I) (state : TcState .anon) : + TcM.WF I state + ((RecM.validateExprWellScoped root rootDepth bound).run methods) + (fun _ _ => True) := by + rw [RecM.validateExprWellScoped_equation] + exact validateExprWellScoped_go_frame bound [(root, rootDepth)] {} {} + methods I hfault state + +/-- Standalone declaration validation preserves the checker invariant on +both outcomes. The resource witness restricts this theorem to the axiom and +definition shapes owned by K3. -/ +theorem validateConstWellScoped_frame + {support : RunSupport} {c : KConst .anon} + (hresources : StandaloneValidationResources support c) + (methods : Methods .anon) {I : TcState .anon → Prop} + (hfault : TcM.LazyFaultPreserves I) (state : TcState .anon) : + TcM.WF I state ((RecM.validateConstWellScoped c).run methods) + (fun _ _ => True) := by + cases hresources with + | @«axiom» name levelParams isUnsafe levels type _ _ => + unfold RecM.validateConstWellScoped + simp only [ReaderT.run_bind, KConst.ty, KConst.lvls] + apply TcM.WF.bind + (validateExprWellScoped_frame type 0 levels.toNat methods hfault state) + intro _ _ _ + exact TcM.WF.pure fun _ => trivial + | @defn name levelParams kind safety hints levels type value leanAll block + _ _ _ _ => + unfold RecM.validateConstWellScoped + simp only [ReaderT.run_bind, KConst.ty, KConst.lvls] + apply TcM.WF.bind + (validateExprWellScoped_frame type 0 levels.toNat methods hfault state) + intro _ afterType _ + exact validateExprWellScoped_frame value 0 levels.toNat methods hfault + afterType + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/ValidatorSoundness.lean b/Ix/Tc/Verify/Check/ValidatorSoundness.lean new file mode 100644 index 000000000..0f4bb5e7b --- /dev/null +++ b/Ix/Tc/Verify/Check/ValidatorSoundness.lean @@ -0,0 +1,1225 @@ +import Ix.Tc.Verify.Check.ValidationReach + +/-! +# Soundness of the address-memoized scoping validators + +The validator inserts a node into its seen set before visiting the node's +children. Consequently, “every seen node is already fully scoped” is not a +valid loop invariant. The invariant used here separates: + +* the local guard already checked for every seen node; and +* a frontier condition saying that each direct child is either seen or still + present on the worklist. + +When the worklist becomes empty, the frontier is transitively closed and the +local guards imply full structural scoping. Address equality is converted +to syntax equality only through finite-run collision freedom. +-/ + +namespace Ix.Tc + +open Std (HashSet) + +/-- Inclusion expressed using the exact Boolean membership operation used by +the production hash sets. -/ +def AddressSetLE {α : Type} [BEq α] [Hashable α] + (before after : HashSet α) : Prop := + ∀ key, before.contains key = true → after.contains key = true + +namespace AddressSetLE + +variable {α : Type} [BEq α] [Hashable α] [EquivBEq α] + [LawfulHashable α] [ReflBEq α] + +omit [EquivBEq α] [LawfulHashable α] [ReflBEq α] in +theorem refl (set : HashSet α) : AddressSetLE set set := + fun _ h => h + +omit [EquivBEq α] [LawfulHashable α] [ReflBEq α] in +theorem trans {a b c : HashSet α} + (hab : AddressSetLE a b) (hbc : AddressSetLE b c) : + AddressSetLE a c := + fun key h => hbc key (hab key h) + +omit [ReflBEq α] in +theorem insert (set : HashSet α) (key : α) : + AddressSetLE set (set.insert key) := by + intro candidate hcandidate + rw [Std.HashSet.contains_insert, Bool.or_eq_true] + exact .inr hcandidate + +theorem insert_self (set : HashSet α) (key : α) : + (set.insert key).contains key = true := by + rw [Std.HashSet.contains_insert, Bool.or_eq_true] + exact .inl (beq_self_eq_true key) + +end AddressSetLE + +/-! ## Universe-worklist invariant -/ + +def UnivStackInDomain (domain : KUniv .anon → Prop) + (stack : List (KUniv .anon)) : Prop := + ∀ ⦃level⦄, level ∈ stack → domain level + +def UnivSeenLocal (domain : KUniv .anon → Prop) (bound : Nat) + (seen : HashSet Address) : Prop := + ∀ ⦃level⦄, domain level → seen.contains level.addr = true → + level.ValidationLocal bound + +def UnivSeenFrontier (domain : KUniv .anon → Prop) + (stack : List (KUniv .anon)) (seen : HashSet Address) : Prop := + ∀ ⦃parent⦄, domain parent → seen.contains parent.addr = true → + ∀ ⦃child⦄, child ∈ parent.validationChildren → + seen.contains child.addr = true ∨ child ∈ stack + +def UnivStackCovered (stack : List (KUniv .anon)) + (seen : HashSet Address) : Prop := + ∀ ⦃level⦄, level ∈ stack → seen.contains level.addr = true + +/-- Ghost result of a successful universe worklist run. -/ +structure UnivValidationPost (domain : KUniv .anon → Prop) (bound : Nat) + (initialStack : List (KUniv .anon)) (initialSeen finalSeen : + HashSet Address) : Prop where + locals : UnivSeenLocal domain bound finalSeen + frontier : UnivSeenFrontier domain [] finalSeen + monotone : AddressSetLE initialSeen finalSeen + covered : UnivStackCovered initialStack finalSeen + +namespace UnivValidationPost + +/-- Reattach a memo-hit head to the recursive tail result. -/ +theorem ofHit + {domain : KUniv .anon → Prop} {bound : Nat} + {level : KUniv .anon} {stack : List (KUniv .anon)} + {seen finalSeen : HashSet Address} + (hhit : seen.contains level.addr = true) + (hpost : UnivValidationPost domain bound stack seen finalSeen) : + UnivValidationPost domain bound (level :: stack) seen finalSeen where + locals := hpost.locals + frontier := hpost.frontier + monotone := hpost.monotone + covered := by + intro candidate hmem + rcases List.mem_cons.mp hmem with rfl | hmem + · exact hpost.monotone _ hhit + · exact hpost.covered hmem + +/-- Reattach a freshly inserted head to a recursive result over its expanded +children and the old tail. -/ +theorem ofExpanded + {domain : KUniv .anon → Prop} {bound : Nat} + {level : KUniv .anon} {stack expanded : List (KUniv .anon)} + {seen finalSeen : HashSet Address} + (hexpanded : expanded = level.validationChildren ++ stack) + (hpost : UnivValidationPost domain bound expanded + (seen.insert level.addr) finalSeen) : + UnivValidationPost domain bound (level :: stack) seen finalSeen where + locals := hpost.locals + frontier := hpost.frontier + monotone := (AddressSetLE.insert seen level.addr).trans hpost.monotone + covered := by + intro candidate hmem + rcases List.mem_cons.mp hmem with rfl | hmem + · exact hpost.monotone _ + (AddressSetLE.insert_self seen candidate.addr) + · apply hpost.covered + rw [hexpanded] + exact List.mem_append.mpr (.inr hmem) + +end UnivValidationPost + +namespace UnivSeenLocal + +/-- Insert a locally valid node. Collision freedom is what makes the local +fact valid for every supported syntax node that shares the new address. -/ +theorem insert + {support : RunSupport} {domain : KUniv .anon → Prop} + (hdomain : KUniv.ValidationDomain support domain) + (hcollision : support.CollisionFree) + {bound : Nat} {seen : HashSet Address} {level : KUniv .anon} + (hbefore : UnivSeenLocal domain bound seen) + (hlevel : domain level) (hlocal : level.ValidationLocal bound) : + UnivSeenLocal domain bound (seen.insert level.addr) := by + intro candidate hcandidate hmem + rw [Std.HashSet.contains_insert, Bool.or_eq_true] at hmem + rcases hmem with hsame | hold + · have herase := hcollision.univ.addrFaithful + (hdomain.covered hlevel) (hdomain.covered hcandidate) hsame + have heq : level = candidate := by + simpa only [KUniv.eraseMeta_anon] using herase + subst candidate + exact hlocal + · exact hbefore hcandidate hold + +end UnivSeenLocal + +namespace UnivSeenFrontier + +/-- Adding pending work can only weaken the frontier obligation. -/ +theorem weakenStack + {domain : KUniv .anon → Prop} {small large : List (KUniv .anon)} + {seen : HashSet Address} + (hfrontier : UnivSeenFrontier domain small seen) + (hsub : ∀ ⦃level⦄, level ∈ small → level ∈ large) : + UnivSeenFrontier domain large seen := by + intro parent hparent hseen child hchild + rcases hfrontier hparent hseen hchild with hcovered | hpending + · exact .inl hcovered + · exact .inr (hsub hpending) + +/-- Dropping a memo hit from the stack preserves the frontier: a reference +to the dropped node is discharged by its existing seen membership. -/ +theorem dropHit + {domain : KUniv .anon → Prop} {level : KUniv .anon} + {stack : List (KUniv .anon)} {seen : HashSet Address} + (hfrontier : UnivSeenFrontier domain (level :: stack) seen) + (hhit : seen.contains level.addr = true) : + UnivSeenFrontier domain stack seen := by + intro parent hparent hseen child hchild + rcases hfrontier hparent hseen hchild with hcovered | hpending + · exact .inl hcovered + · rcases List.mem_cons.mp hpending with rfl | hpending + · exact .inl hhit + · exact .inr hpending + +/-- Inserting a fresh node and replacing it by its direct children preserves +the frontier. -/ +theorem insertAndExpand + {support : RunSupport} {domain : KUniv .anon → Prop} + (hdomain : KUniv.ValidationDomain support domain) + (hcollision : support.CollisionFree) + {level : KUniv .anon} {stack : List (KUniv .anon)} + {seen : HashSet Address} + (hfrontier : UnivSeenFrontier domain (level :: stack) seen) + (hlevel : domain level) : + UnivSeenFrontier domain + (level.validationChildren ++ stack) (seen.insert level.addr) := by + intro parent hparent hseen child hchild + rw [Std.HashSet.contains_insert, Bool.or_eq_true] at hseen + rcases hseen with hsame | hold + · have herase := hcollision.univ.addrFaithful + (hdomain.covered hlevel) (hdomain.covered hparent) hsame + have heq : level = parent := by + simpa only [KUniv.eraseMeta_anon] using herase + subst parent + exact .inr (List.mem_append.mpr (.inl hchild)) + · rcases hfrontier hparent hold hchild with hcovered | hpending + · exact .inl (AddressSetLE.insert seen level.addr child.addr hcovered) + · rcases List.mem_cons.mp hpending with heq | hpending + · subst child + exact .inl (AddressSetLE.insert_self seen level.addr) + · exact .inr (List.mem_append.mpr (.inr hpending)) + +/-- At an empty frontier, local validity recursively implies full scoping. -/ +theorem fullyScoped + {support : RunSupport} {domain : KUniv .anon → Prop} + (hdomain : KUniv.ValidationDomain support domain) + {bound : Nat} {seen : HashSet Address} {root : KUniv .anon} + (hlocal : UnivSeenLocal domain bound seen) + (hfrontier : UnivSeenFrontier domain [] seen) + (hroot : domain root) (hseen : seen.contains root.addr = true) : + root.Scoped bound := by + cases root with + | zero => trivial + | succ child addr => + have hchildDomain : domain child := + hdomain.child hroot (by simp [KUniv.validationChildren]) + have hchildSeen : seen.contains child.addr = true := by + rcases hfrontier hroot hseen + (by simp [KUniv.validationChildren] : + child ∈ (KUniv.succ child addr).validationChildren) with + h | h + · exact h + · simp at h + exact fullyScoped (root := child) hdomain hlocal hfrontier + hchildDomain hchildSeen + | max left right addr => + have hleftDomain : domain left := + hdomain.child hroot (by simp [KUniv.validationChildren]) + have hrightDomain : domain right := + hdomain.child hroot (by simp [KUniv.validationChildren]) + have hleftSeen : seen.contains left.addr = true := by + rcases hfrontier hroot hseen + (by simp [KUniv.validationChildren] : + left ∈ (KUniv.max left right addr).validationChildren) with + h | h + · exact h + · simp at h + have hrightSeen : seen.contains right.addr = true := by + rcases hfrontier hroot hseen + (by simp [KUniv.validationChildren] : + right ∈ (KUniv.max left right addr).validationChildren) with + h | h + · exact h + · simp at h + exact ⟨fullyScoped (root := left) hdomain hlocal hfrontier + hleftDomain hleftSeen, + fullyScoped (root := right) hdomain hlocal hfrontier + hrightDomain hrightSeen⟩ + | imax left right addr => + have hleftDomain : domain left := + hdomain.child hroot (by simp [KUniv.validationChildren]) + have hrightDomain : domain right := + hdomain.child hroot (by simp [KUniv.validationChildren]) + have hleftSeen : seen.contains left.addr = true := by + rcases hfrontier hroot hseen + (by simp [KUniv.validationChildren] : + left ∈ (KUniv.imax left right addr).validationChildren) with + h | h + · exact h + · simp at h + have hrightSeen : seen.contains right.addr = true := by + rcases hfrontier hroot hseen + (by simp [KUniv.validationChildren] : + right ∈ (KUniv.imax left right addr).validationChildren) with + h | h + · exact h + · simp at h + exact ⟨fullyScoped (root := left) hdomain hlocal hfrontier + hleftDomain hleftSeen, + fullyScoped (root := right) hdomain hlocal hfrontier + hrightDomain hrightSeen⟩ + | param idx name addr => exact hlocal hroot hseen +termination_by root.size +decreasing_by + all_goals simp_all [KUniv.size] <;> omega + +end UnivSeenFrontier + +/-! ## Production universe validator -/ + +namespace RecM + +/-- Successful execution of the exact memoized universe worklist establishes +the local/frontier certificate. The theorem is generic over a child-closed +finite domain so one expression validation can share its universe seen set +across every sort and constant argument it encounters. -/ +theorem validateUnivParamsSeen_go_sound : + ∀ {support : RunSupport} {domain : KUniv .anon → Prop}, + KUniv.ValidationDomain support domain → + support.CollisionFree → + ∀ (bound : Nat) (stack : List (KUniv .anon)) + (seen : HashSet Address), + UnivStackInDomain domain stack → + UnivSeenLocal domain bound seen → + UnivSeenFrontier domain stack seen → + ∀ (methods : Methods .anon) (state : TcState .anon) + (finalSeen : HashSet Address) (after : TcState .anon), + (RecM.validateUnivParamsSeen.go bound stack seen).run methods state = + .ok finalSeen after → + UnivValidationPost domain bound stack seen finalSeen + | support, domain, hdomain, hcollision, bound, [], seen, + hstack, hlocal, hfrontier, methods, state, finalSeen, after, hrun => by + rw [RecM.validateUnivParamsSeen.go] at hrun + cases hrun + exact ⟨hlocal, hfrontier, AddressSetLE.refl seen, + fun _ h => by simp at h⟩ + | support, domain, hdomain, hcollision, bound, level :: stack, seen, + hstack, hlocal, hfrontier, methods, state, finalSeen, after, hrun => by + rw [RecM.validateUnivParamsSeen.go] at hrun + split at hrun + · rename_i hhit + simp only [bind_pure] at hrun + have htailDomain : UnivStackInDomain domain stack := by + intro candidate hmem + exact hstack (List.mem_cons.mpr (.inr hmem)) + have htailFrontier := hfrontier.dropHit hhit + exact UnivValidationPost.ofHit hhit <| + validateUnivParamsSeen_go_sound hdomain hcollision bound stack seen + htailDomain hlocal htailFrontier methods state finalSeen after hrun + · rename_i hmiss + have hlevelDomain : domain level := + hstack (List.mem_cons.mpr (.inl rfl)) + have hchildrenDomain : + UnivStackInDomain domain + (level.validationChildren ++ stack) := by + intro candidate hmem + rcases List.mem_append.mp hmem with hchild | htail + · exact hdomain.child hlevelDomain hchild + · exact hstack (List.mem_cons.mpr (.inr htail)) + have hexpandedFrontier := + hfrontier.insertAndExpand hdomain hcollision hlevelDomain + cases level with + | zero addr => + simp only [pure_bind] at hrun + have hlocal' := hlocal.insert hdomain hcollision hlevelDomain + (by trivial) + exact UnivValidationPost.ofExpanded rfl <| + validateUnivParamsSeen_go_sound hdomain hcollision bound stack + (seen.insert addr) (by simpa [KUniv.validationChildren] using + hchildrenDomain) hlocal' + (by simpa [KUniv.validationChildren] using hexpandedFrontier) + methods state finalSeen after hrun + | succ child addr => + simp only [pure_bind] at hrun + have hlocal' := hlocal.insert hdomain hcollision hlevelDomain + (by trivial) + exact UnivValidationPost.ofExpanded rfl <| + validateUnivParamsSeen_go_sound hdomain hcollision bound + (child :: stack) (seen.insert addr) + (by simpa [KUniv.validationChildren] using hchildrenDomain) + hlocal' + (by simpa [KUniv.validationChildren] using hexpandedFrontier) + methods state finalSeen after hrun + | max left right addr => + simp only [pure_bind] at hrun + have hlocal' := hlocal.insert hdomain hcollision hlevelDomain + (by trivial) + exact UnivValidationPost.ofExpanded rfl <| + validateUnivParamsSeen_go_sound hdomain hcollision bound + (right :: left :: stack) (seen.insert addr) + (by simpa [KUniv.validationChildren] using hchildrenDomain) + hlocal' + (by simpa [KUniv.validationChildren] using hexpandedFrontier) + methods state finalSeen after hrun + | imax left right addr => + simp only [pure_bind] at hrun + have hlocal' := hlocal.insert hdomain hcollision hlevelDomain + (by trivial) + exact UnivValidationPost.ofExpanded rfl <| + validateUnivParamsSeen_go_sound hdomain hcollision bound + (right :: left :: stack) (seen.insert addr) + (by simpa [KUniv.validationChildren] using hchildrenDomain) + hlocal' + (by simpa [KUniv.validationChildren] using hexpandedFrontier) + methods state finalSeen after hrun + | param idx name addr => + simp only [pure_bind] at hrun + split at hrun + · contradiction + · rename_i hinRange + have hidx : idx.toNat < bound := by omega + have hlocal' := hlocal.insert hdomain hcollision hlevelDomain + hidx + exact UnivValidationPost.ofExpanded rfl <| + validateUnivParamsSeen_go_sound hdomain hcollision bound stack + (seen.insert addr) + (by simpa [KUniv.validationChildren] using hchildrenDomain) + hlocal' + (by simpa [KUniv.validationChildren] using hexpandedFrontier) + methods state finalSeen after hrun +termination_by _ _ _ _ _ stack _ _ _ _ _ _ _ _ _ => + RecM.univWorkSize stack +decreasing_by + all_goals simp_all [RecM.univWorkSize, KUniv.validationChildren, KUniv.size] + all_goals try omega + all_goals exact KUniv.size_pos _ + +/-- Public universe-validator soundness from an already closed memo set. +The returned memo set remains locally valid and closed, and the requested +root is fully scoped. -/ +theorem validateUnivParamsSeen_sound + {support : RunSupport} {domain : KUniv .anon → Prop} + (hdomain : KUniv.ValidationDomain support domain) + (hcollision : support.CollisionFree) + {bound : Nat} {root : KUniv .anon} {seen finalSeen : HashSet Address} + {methods : Methods .anon} {state after : TcState .anon} + (hroot : domain root) + (hlocal : UnivSeenLocal domain bound seen) + (hfrontier : UnivSeenFrontier domain [] seen) + (hrun : (validateUnivParamsSeen root bound seen).run methods state = + .ok finalSeen after) : + UnivValidationPost domain bound [root] seen finalSeen ∧ + root.Scoped bound := by + rw [RecM.validateUnivParamsSeen_equation] at hrun + have hpost := validateUnivParamsSeen_go_sound hdomain hcollision bound + [root] seen (by simpa [UnivStackInDomain]) hlocal + (hfrontier.weakenStack (by simp)) methods state finalSeen after hrun + exact ⟨hpost, + hpost.frontier.fullyScoped hdomain hpost.locals hroot + (hpost.covered (by simp))⟩ + +end RecM + +/-! ## Expression-worklist invariant -/ + +def ExprStackInReach (root : KExpr .anon) + (stack : List (KExpr .anon × UInt64)) : Prop := + ∀ ⦃item⦄, item ∈ stack → root.ValidationReach item.1 + +def ExprSeenLocal (root : KExpr .anon) + (seen : HashSet (Address × UInt64)) : Prop := + ∀ ⦃expr : KExpr .anon⦄ ⦃depth : UInt64⦄, + root.ValidationReach expr → + seen.contains (expr.addr, depth) = true → + expr.ValidationLocal depth + +def ExprSeenFrontier (root : KExpr .anon) + (stack : List (KExpr .anon × UInt64)) + (seen : HashSet (Address × UInt64)) : Prop := + ∀ ⦃expr : KExpr .anon⦄ ⦃depth : UInt64⦄, + root.ValidationReach expr → + seen.contains (expr.addr, depth) = true → + ∀ ⦃child : KExpr .anon × UInt64⦄, + child ∈ expr.validationChildrenAt depth → + seen.contains (child.1.addr, child.2) = true ∨ child ∈ stack + +/-- Every universe root attached to a seen expression node has completed its +universe validation. -/ +def ExprSeenUnivs (root : KExpr .anon) + (seenExprs : HashSet (Address × UInt64)) + (seenUnivs : HashSet Address) : Prop := + ∀ ⦃expr : KExpr .anon⦄ ⦃depth : UInt64⦄, + root.ValidationReach expr → + seenExprs.contains (expr.addr, depth) = true → + ∀ ⦃level : KUniv .anon⦄, level ∈ expr.validationUnivRoots → + seenUnivs.contains level.addr = true + +def ExprStackCovered (stack : List (KExpr .anon × UInt64)) + (seen : HashSet (Address × UInt64)) : Prop := + ∀ ⦃item⦄, item ∈ stack → + seen.contains (item.1.addr, item.2) = true + +/-- Ghost result of a successful expression worklist run. The production +validator returns only `Unit`; the two final memo sets are existential ghost +state retained by the soundness proof. -/ +structure ExprValidationPost (root : KExpr .anon) (bound : Nat) + (initialStack : List (KExpr .anon × UInt64)) + (initialExprs finalExprs : HashSet (Address × UInt64)) + (initialUnivs finalUnivs : HashSet Address) : Prop where + exprLocals : ExprSeenLocal root finalExprs + exprFrontier : ExprSeenFrontier root [] finalExprs + exprUnivs : ExprSeenUnivs root finalExprs finalUnivs + univLocals : UnivSeenLocal (KExpr.ValidationUnivReach root) + bound finalUnivs + univFrontier : UnivSeenFrontier (KExpr.ValidationUnivReach root) + [] finalUnivs + exprMonotone : AddressSetLE initialExprs finalExprs + univMonotone : AddressSetLE initialUnivs finalUnivs + covered : ExprStackCovered initialStack finalExprs + + +namespace ExprSeenLocal + +theorem insert + {support : RunSupport} {root expr : KExpr .anon} {depth : UInt64} + (hcoverage : root.ValidationCoverage support) + (hcollision : support.CollisionFree) + {seen : HashSet (Address × UInt64)} + (hbefore : ExprSeenLocal root seen) + (hexpr : root.ValidationReach expr) + (hlocal : expr.ValidationLocal depth) : + ExprSeenLocal root (seen.insert (expr.addr, depth)) := by + intro candidate candidateDepth hcandidate hmem + rw [Std.HashSet.contains_insert, Bool.or_eq_true] at hmem + rcases hmem with hsame | hold + · have hkey : (expr.addr, depth) = (candidate.addr, candidateDepth) := + eq_of_beq hsame + have haddr : expr.addr = candidate.addr := congrArg Prod.fst hkey + have hdepth : depth = candidateDepth := congrArg Prod.snd hkey + have herase := hcollision.expr + (hcoverage.expr hexpr) (hcoverage.expr hcandidate) haddr + have heq : expr = candidate := by + simpa only [KExpr.eraseMeta_anon] using herase + subst candidate + subst candidateDepth + exact hlocal + · exact hbefore hcandidate hold + +end ExprSeenLocal + +namespace ExprSeenFrontier + +theorem weakenStack + {root : KExpr .anon} {small large : List (KExpr .anon × UInt64)} + {seen : HashSet (Address × UInt64)} + (hfrontier : ExprSeenFrontier root small seen) + (hsub : ∀ ⦃item⦄, item ∈ small → item ∈ large) : + ExprSeenFrontier root large seen := by + intro expr depth hexpr hseen child hchild + rcases hfrontier hexpr hseen hchild with hcovered | hpending + · exact .inl hcovered + · exact .inr (hsub hpending) + +theorem dropHit + {root expr : KExpr .anon} {depth : UInt64} + {stack : List (KExpr .anon × UInt64)} + {seen : HashSet (Address × UInt64)} + (hfrontier : ExprSeenFrontier root ((expr, depth) :: stack) seen) + (hhit : seen.contains (expr.addr, depth) = true) : + ExprSeenFrontier root stack seen := by + intro parent parentDepth hparent hseen child hchild + rcases hfrontier hparent hseen hchild with hcovered | hpending + · exact .inl hcovered + · rcases List.mem_cons.mp hpending with heq | hpending + · cases heq + exact .inl hhit + · exact .inr hpending + +theorem insertAndExpand + {support : RunSupport} {root expr : KExpr .anon} {depth : UInt64} + (hcoverage : root.ValidationCoverage support) + (hcollision : support.CollisionFree) + {stack : List (KExpr .anon × UInt64)} + {seen : HashSet (Address × UInt64)} + (hfrontier : ExprSeenFrontier root ((expr, depth) :: stack) seen) + (hexpr : root.ValidationReach expr) : + ExprSeenFrontier root + (expr.validationChildrenAt depth ++ stack) + (seen.insert (expr.addr, depth)) := by + intro parent parentDepth hparent hseen child hchild + rw [Std.HashSet.contains_insert, Bool.or_eq_true] at hseen + rcases hseen with hsame | hold + · have hkey : (expr.addr, depth) = (parent.addr, parentDepth) := + eq_of_beq hsame + have haddr : expr.addr = parent.addr := congrArg Prod.fst hkey + have hdepth : depth = parentDepth := congrArg Prod.snd hkey + have herase := hcollision.expr + (hcoverage.expr hexpr) (hcoverage.expr hparent) haddr + have heq : expr = parent := by + simpa only [KExpr.eraseMeta_anon] using herase + subst parent + subst parentDepth + exact .inr (List.mem_append.mpr (.inl hchild)) + · rcases hfrontier hparent hold hchild with hcovered | hpending + · exact .inl + (AddressSetLE.insert seen (expr.addr, depth) + (child.1.addr, child.2) hcovered) + · rcases List.mem_cons.mp hpending with heq | hpending + · cases heq + exact .inl (AddressSetLE.insert_self seen (expr.addr, depth)) + · exact .inr (List.mem_append.mpr (.inr hpending)) + +/-- At empty expression and universe frontiers, the local certificates imply +the full recursive `KExpr.Scoped` predicate. -/ +theorem fullyScoped + {support : RunSupport} {root : KExpr .anon} + (hcoverage : root.ValidationCoverage support) + {bound : Nat} + {seenExprs : HashSet (Address × UInt64)} + {seenUnivs : HashSet Address} + (hexprLocal : ExprSeenLocal root seenExprs) + (hexprFrontier : ExprSeenFrontier root [] seenExprs) + (hexprUnivs : ExprSeenUnivs root seenExprs seenUnivs) + (hunivLocal : UnivSeenLocal (KExpr.ValidationUnivReach root) + bound seenUnivs) + (hunivFrontier : UnivSeenFrontier (KExpr.ValidationUnivReach root) + [] seenUnivs) + {expr : KExpr .anon} {depth : UInt64} + (hexpr : root.ValidationReach expr) + (hseen : seenExprs.contains (expr.addr, depth) = true) : + expr.Scoped depth bound := by + have childSeen : ∀ ⦃child : KExpr .anon × UInt64⦄, + child ∈ expr.validationChildrenAt depth → + seenExprs.contains (child.1.addr, child.2) = true := by + intro child hchild + rcases hexprFrontier hexpr hseen hchild with h | h + · exact h + · simp at h + have childReach : ∀ ⦃child : KExpr .anon × UInt64⦄, + child ∈ expr.validationChildrenAt depth → + root.ValidationReach child.1 := by + intro child hchild + exact hexpr.trans (.childAt hchild) + have univScoped : ∀ ⦃level : KUniv .anon⦄, + level ∈ expr.validationUnivRoots → level.Scoped bound := by + intro level hlevel + have hlevelDomain := hexpr.univRoot hlevel + exact hunivFrontier.fullyScoped hcoverage.univDomain hunivLocal + hlevelDomain (hexprUnivs hexpr hseen hlevel) + cases expr with + | var => exact hexprLocal hexpr hseen + | fvar => trivial + | sort level info => + exact univScoped (by simp [KExpr.validationUnivRoots]) + | const id levels info => + intro level hlevel + exact univScoped (by simpa [KExpr.validationUnivRoots] using hlevel) + | app fn arg info => + have hargMem : (arg, depth) ∈ + (KExpr.app fn arg info).validationChildrenAt depth := by + simp [KExpr.validationChildrenAt] + have hfnMem : (fn, depth) ∈ + (KExpr.app fn arg info).validationChildrenAt depth := by + simp [KExpr.validationChildrenAt] + exact ⟨fullyScoped (expr := fn) (depth := depth) hcoverage + hexprLocal hexprFrontier hexprUnivs + hunivLocal hunivFrontier (childReach hfnMem) (childSeen hfnMem), + fullyScoped (expr := arg) (depth := depth) hcoverage + hexprLocal hexprFrontier hexprUnivs + hunivLocal hunivFrontier (childReach hargMem) (childSeen hargMem)⟩ + | lam name bi type body info => + have hbodyMem : (body, depth + 1) ∈ + (KExpr.lam name bi type body info).validationChildrenAt depth := by + simp [KExpr.validationChildrenAt] + have htypeMem : (type, depth) ∈ + (KExpr.lam name bi type body info).validationChildrenAt depth := by + simp [KExpr.validationChildrenAt] + exact ⟨fullyScoped (expr := type) (depth := depth) hcoverage + hexprLocal hexprFrontier hexprUnivs + hunivLocal hunivFrontier (childReach htypeMem) (childSeen htypeMem), + fullyScoped (expr := body) (depth := depth + 1) hcoverage + hexprLocal hexprFrontier hexprUnivs + hunivLocal hunivFrontier (childReach hbodyMem) + (childSeen hbodyMem)⟩ + | all name bi type body info => + have hbodyMem : (body, depth + 1) ∈ + (KExpr.all name bi type body info).validationChildrenAt depth := by + simp [KExpr.validationChildrenAt] + have htypeMem : (type, depth) ∈ + (KExpr.all name bi type body info).validationChildrenAt depth := by + simp [KExpr.validationChildrenAt] + exact ⟨fullyScoped (expr := type) (depth := depth) hcoverage + hexprLocal hexprFrontier hexprUnivs + hunivLocal hunivFrontier (childReach htypeMem) (childSeen htypeMem), + fullyScoped (expr := body) (depth := depth + 1) hcoverage + hexprLocal hexprFrontier hexprUnivs + hunivLocal hunivFrontier (childReach hbodyMem) + (childSeen hbodyMem)⟩ + | letE name type value body nonDep info => + have hbodyMem : (body, depth + 1) ∈ + (KExpr.letE name type value body nonDep info).validationChildrenAt + depth := by + simp [KExpr.validationChildrenAt] + have hvalueMem : (value, depth) ∈ + (KExpr.letE name type value body nonDep info).validationChildrenAt + depth := by + simp [KExpr.validationChildrenAt] + have htypeMem : (type, depth) ∈ + (KExpr.letE name type value body nonDep info).validationChildrenAt + depth := by + simp [KExpr.validationChildrenAt] + exact ⟨fullyScoped (expr := type) (depth := depth) hcoverage + hexprLocal hexprFrontier hexprUnivs + hunivLocal hunivFrontier (childReach htypeMem) (childSeen htypeMem), + fullyScoped (expr := value) (depth := depth) hcoverage + hexprLocal hexprFrontier hexprUnivs + hunivLocal hunivFrontier (childReach hvalueMem) + (childSeen hvalueMem), + fullyScoped (expr := body) (depth := depth + 1) hcoverage + hexprLocal hexprFrontier hexprUnivs + hunivLocal hunivFrontier (childReach hbodyMem) + (childSeen hbodyMem)⟩ + | prj id field value info => + have hvalueMem : (value, depth) ∈ + (KExpr.prj id field value info).validationChildrenAt depth := by + simp [KExpr.validationChildrenAt] + exact fullyScoped (expr := value) (depth := depth) hcoverage + hexprLocal hexprFrontier hexprUnivs + hunivLocal hunivFrontier (childReach hvalueMem) (childSeen hvalueMem) + | nat | str => trivial +termination_by expr.treeSize +decreasing_by + all_goals simp_all [KExpr.treeSize] + all_goals try omega + +end ExprSeenFrontier + +namespace ExprSeenUnivs + +theorem insert + {support : RunSupport} {root expr : KExpr .anon} {depth : UInt64} + (hcoverage : root.ValidationCoverage support) + (hcollision : support.CollisionFree) + {seenExprs : HashSet (Address × UInt64)} + {beforeUnivs afterUnivs : HashSet Address} + (hbefore : ExprSeenUnivs root seenExprs beforeUnivs) + (hmono : AddressSetLE beforeUnivs afterUnivs) + (hexpr : root.ValidationReach expr) + (hroots : ∀ ⦃level⦄, level ∈ expr.validationUnivRoots → + afterUnivs.contains level.addr = true) : + ExprSeenUnivs root (seenExprs.insert (expr.addr, depth)) afterUnivs := by + intro candidate candidateDepth hcandidate hmem level hlevel + rw [Std.HashSet.contains_insert, Bool.or_eq_true] at hmem + rcases hmem with hsame | hold + · have hkey : (expr.addr, depth) = (candidate.addr, candidateDepth) := + eq_of_beq hsame + have haddr : expr.addr = candidate.addr := congrArg Prod.fst hkey + have herase := hcollision.expr + (hcoverage.expr hexpr) (hcoverage.expr hcandidate) haddr + have heq : expr = candidate := by + simpa only [KExpr.eraseMeta_anon] using herase + subst candidate + exact hroots hlevel + · exact hmono _ (hbefore hcandidate hold hlevel) + +end ExprSeenUnivs + +namespace ExprValidationPost + +/-- Reattach a memo-hit head to the recursive tail result. -/ +theorem ofHit + {root expr : KExpr .anon} {bound : Nat} {depth : UInt64} + {stack : List (KExpr .anon × UInt64)} + {seenExprs finalExprs : HashSet (Address × UInt64)} + {seenUnivs finalUnivs : HashSet Address} + (hhit : seenExprs.contains (expr.addr, depth) = true) + (hpost : ExprValidationPost root bound stack seenExprs finalExprs + seenUnivs finalUnivs) : + ExprValidationPost root bound ((expr, depth) :: stack) + seenExprs finalExprs seenUnivs finalUnivs where + exprLocals := hpost.exprLocals + exprFrontier := hpost.exprFrontier + exprUnivs := hpost.exprUnivs + univLocals := hpost.univLocals + univFrontier := hpost.univFrontier + exprMonotone := hpost.exprMonotone + univMonotone := hpost.univMonotone + covered := by + intro item hmem + rcases List.mem_cons.mp hmem with rfl | hmem + · exact hpost.exprMonotone _ hhit + · exact hpost.covered hmem + +/-- Reattach a freshly inserted head after the recursive run over its exact +expanded worklist. Universe validation may have advanced independently +before expression recursion resumes. -/ +theorem ofExpanded + {root expr : KExpr .anon} {bound : Nat} {depth : UInt64} + {stack expanded : List (KExpr .anon × UInt64)} + {seenExprs finalExprs : HashSet (Address × UInt64)} + {beforeUnivs afterUnivs finalUnivs : HashSet Address} + (hexpanded : expanded = expr.validationChildrenAt depth ++ stack) + (hunivMono : AddressSetLE beforeUnivs afterUnivs) + (hpost : ExprValidationPost root bound expanded + (seenExprs.insert (expr.addr, depth)) finalExprs + afterUnivs finalUnivs) : + ExprValidationPost root bound ((expr, depth) :: stack) + seenExprs finalExprs beforeUnivs finalUnivs where + exprLocals := hpost.exprLocals + exprFrontier := hpost.exprFrontier + exprUnivs := hpost.exprUnivs + univLocals := hpost.univLocals + univFrontier := hpost.univFrontier + exprMonotone := + (AddressSetLE.insert seenExprs (expr.addr, depth)).trans + hpost.exprMonotone + univMonotone := hunivMono.trans hpost.univMonotone + covered := by + intro item hmem + rcases List.mem_cons.mp hmem with rfl | hmem + · exact hpost.exprMonotone _ + (AddressSetLE.insert_self seenExprs (expr.addr, depth)) + · apply hpost.covered + rw [hexpanded] + exact List.mem_append.mpr (.inr hmem) + +end ExprValidationPost + +/-! ## Sequential universe-root validation -/ + +/-- Ghost result of validating several direct universe roots while sharing +the production memo set. -/ +structure UnivRootsPost (domain : KUniv .anon → Prop) (bound : Nat) + (roots : List (KUniv .anon)) + (initialSeen finalSeen : HashSet Address) : Prop where + locals : UnivSeenLocal domain bound finalSeen + frontier : UnivSeenFrontier domain [] finalSeen + monotone : AddressSetLE initialSeen finalSeen + covered : ∀ ⦃level⦄, level ∈ roots → + finalSeen.contains level.addr = true + +namespace RecM + +/-- Expose one `TcM` bind at a concrete starting state. -/ +private theorem runTcBind {α β : Type} + (x : TcM .anon α) (k : α → TcM .anon β) + (state : TcState .anon) : + (x >>= k) state = match x state with + | .ok value after => k value after + | .error err after => .error err after := by + show EStateM.bind x k state = _ + unfold EStateM.bind + cases x state <;> rfl + +/-- Soundness of the exact list-normalized `for` loop used by constant +universe arguments. Every iteration receives the preceding iteration's +memo set and preserves the closed universe frontier. -/ +theorem validateUnivRootsList_sound + {support : RunSupport} {domain : KUniv .anon → Prop} + (hdomain : KUniv.ValidationDomain support domain) + (hcollision : support.CollisionFree) (bound : Nat) : + ∀ (roots : List (KUniv .anon)) (seen : HashSet Address) + (methods : Methods .anon) (state : TcState .anon) + (finalSeen : HashSet Address) (after : TcState .anon), + (∀ ⦃level⦄, level ∈ roots → domain level) → + UnivSeenLocal domain bound seen → + UnivSeenFrontier domain [] seen → + ((forIn (m := RecM .anon) roots seen (fun level current => do + let next ← validateUnivParamsSeen level bound current + pure (.yield next))).run methods state = .ok finalSeen after) → + UnivRootsPost domain bound roots seen finalSeen + | [], seen, methods, state, finalSeen, after, + hroots, hlocal, hfrontier, hrun => by + rw [List.forIn_nil] at hrun + cases hrun + exact ⟨hlocal, hfrontier, AddressSetLE.refl seen, + fun _ h => by simp at h⟩ + | level :: roots, seen, methods, state, finalSeen, after, + hroots, hlocal, hfrontier, hrun => by + rw [List.forIn_cons, ReaderT.run_bind] at hrun + rw [ReaderT.run_bind] at hrun + rw [bind_assoc] at hrun + rw [runTcBind] at hrun + cases hhead : + (validateUnivParamsSeen level bound seen).run methods state with + | error err failed => + rw [hhead] at hrun + contradiction + | ok nextSeen nextState => + rw [hhead] at hrun + have hlevel : domain level := hroots (by simp) + have hvalidated := validateUnivParamsSeen_sound hdomain hcollision + hlevel hlocal hfrontier hhead + have htailRoots : ∀ ⦃candidate⦄, candidate ∈ roots → + domain candidate := by + intro candidate hmem + exact hroots (List.mem_cons.mpr (.inr hmem)) + have htail := validateUnivRootsList_sound hdomain hcollision bound + roots nextSeen methods nextState finalSeen after htailRoots + hvalidated.1.locals hvalidated.1.frontier hrun + exact ⟨htail.locals, htail.frontier, + hvalidated.1.monotone.trans htail.monotone, by + intro candidate hmem + rcases List.mem_cons.mp hmem with rfl | hmem + · exact htail.monotone _ + (hvalidated.1.covered (by simp)) + · exact htail.covered hmem⟩ + +/-- Array-level bridge in the exact shape exposed by the production +constant branch. -/ +theorem validateUnivRootsArray_sound + {support : RunSupport} {domain : KUniv .anon → Prop} + (hdomain : KUniv.ValidationDomain support domain) + (hcollision : support.CollisionFree) (bound : Nat) + (roots : Array (KUniv .anon)) (seen : HashSet Address) + (methods : Methods .anon) (state : TcState .anon) + (finalSeen : HashSet Address) (after : TcState .anon) + (hroots : ∀ ⦃level⦄, level ∈ roots → domain level) + (hlocal : UnivSeenLocal domain bound seen) + (hfrontier : UnivSeenFrontier domain [] seen) + (hrun : ((forIn (m := RecM .anon) roots seen + (fun level current => do + let next ← validateUnivParamsSeen level bound current + pure (.yield next))).run methods state = .ok finalSeen after)) : + UnivRootsPost domain bound roots.toList seen finalSeen := by + rw [← Array.forIn_toList] at hrun + exact validateUnivRootsList_sound hdomain hcollision bound roots.toList seen + methods state finalSeen after (by simpa using hroots) hlocal hfrontier hrun + +/-! ## Production expression validator -/ + +/-- Successful execution of the exact address-memoized expression worklist +produces ghost final memo sets satisfying the local/frontier certificate. +Lookup effects are intentionally unconstrained: they can affect checker +state, but not the finite syntax footprint being validated. -/ +theorem validateExprWellScoped_go_sound : + ∀ {support : RunSupport} {root : KExpr .anon}, + root.ValidationCoverage support → + support.CollisionFree → + ∀ (bound : Nat) (stack : List (KExpr .anon × UInt64)) + (seenExprs : HashSet (Address × UInt64)) + (seenUnivs : HashSet Address), + ExprStackInReach root stack → + ExprSeenLocal root seenExprs → + ExprSeenFrontier root stack seenExprs → + ExprSeenUnivs root seenExprs seenUnivs → + UnivSeenLocal (KExpr.ValidationUnivReach root) bound seenUnivs → + UnivSeenFrontier (KExpr.ValidationUnivReach root) [] seenUnivs → + ∀ (methods : Methods .anon) (state after : TcState .anon), + (RecM.validateExprWellScoped.go bound stack seenExprs seenUnivs).run + methods state = .ok () after → + ∃ finalExprs finalUnivs, + ExprValidationPost root bound stack seenExprs finalExprs + seenUnivs finalUnivs + | support, root, hcoverage, hcollision, bound, [], seenExprs, + seenUnivs, hstack, hlocal, hfrontier, hunivs, hulocal, + hufrontier, methods, state, after, hrun => by + rw [RecM.validateExprWellScoped.go] at hrun + cases hrun + exact ⟨seenExprs, seenUnivs, hlocal, hfrontier, hunivs, + hulocal, hufrontier, AddressSetLE.refl seenExprs, + AddressSetLE.refl seenUnivs, fun _ h => by simp at h⟩ + | support, root, hcoverage, hcollision, bound, (expr, depth) :: stack, + seenExprs, seenUnivs, hstack, hlocal, hfrontier, hunivs, + hulocal, hufrontier, methods, state, after, hrun => by + rw [RecM.validateExprWellScoped.go] at hrun + split at hrun + · rename_i hhit + simp only [bind_pure] at hrun + have htailReach : ExprStackInReach root stack := by + intro item hmem + exact hstack (List.mem_cons.mpr (.inr hmem)) + have htailFrontier := hfrontier.dropHit hhit + obtain ⟨finalExprs, finalUnivs, hpost⟩ := + validateExprWellScoped_go_sound hcoverage hcollision bound stack + seenExprs seenUnivs htailReach hlocal htailFrontier hunivs + hulocal hufrontier methods state after hrun + exact ⟨finalExprs, finalUnivs, + ExprValidationPost.ofHit hhit hpost⟩ + · rename_i hmiss + have hexpr : root.ValidationReach expr := + hstack (List.mem_cons.mpr (.inl rfl)) + have htailReach : ExprStackInReach root stack := by + intro item hmem + exact hstack (List.mem_cons.mpr (.inr hmem)) + have hchildrenReach : ExprStackInReach root + (expr.validationChildrenAt depth ++ stack) := by + intro item hmem + rcases List.mem_append.mp hmem with hchild | htail + · exact hexpr.trans (.childAt hchild) + · exact htailReach htail + have hfrontier' := + hfrontier.insertAndExpand hcoverage hcollision hexpr + have finishFresh + {afterUnivs : HashSet Address} {nextState : TcState .anon} + (hlocalNow : expr.ValidationLocal depth) + (hunivMono : AddressSetLE seenUnivs afterUnivs) + (hrootsCovered : ∀ ⦃level⦄, + level ∈ expr.validationUnivRoots → + afterUnivs.contains level.addr = true) + (hulocalAfter : UnivSeenLocal + (KExpr.ValidationUnivReach root) bound afterUnivs) + (hufrontierAfter : UnivSeenFrontier + (KExpr.ValidationUnivReach root) [] afterUnivs) + (hdecrease : RecM.scopedExprWorkSize + (expr.validationChildrenAt depth ++ stack) < + RecM.scopedExprWorkSize ((expr, depth) :: stack)) + (hrun' : + (RecM.validateExprWellScoped.go bound + (expr.validationChildrenAt depth ++ stack) + (seenExprs.insert (expr.addr, depth)) afterUnivs).run + methods nextState = .ok () after) : + ∃ finalExprs finalUnivs, + ExprValidationPost root bound ((expr, depth) :: stack) + seenExprs finalExprs seenUnivs finalUnivs := by + have hlocal' := hlocal.insert (depth := depth) + hcoverage hcollision hexpr hlocalNow + have hunivs' := hunivs.insert (depth := depth) + hcoverage hcollision hunivMono hexpr hrootsCovered + obtain ⟨finalExprs, finalUnivs, hpost⟩ := + validateExprWellScoped_go_sound hcoverage hcollision bound + (expr.validationChildrenAt depth ++ stack) + (seenExprs.insert (expr.addr, depth)) afterUnivs + hchildrenReach hlocal' hfrontier' hunivs' + hulocalAfter hufrontierAfter methods nextState after hrun' + exact ⟨finalExprs, finalUnivs, + ExprValidationPost.ofExpanded rfl hunivMono hpost⟩ + cases expr with + | var idx name info => + simp only [pure_bind] at hrun + split at hrun + · contradiction + · rename_i hinRange + apply finishFresh (afterUnivs := seenUnivs) + (nextState := state) (by + simp only [KExpr.ValidationLocal] + exact UInt64.not_le.mp hinRange) + (AddressSetLE.refl seenUnivs) + (by simp [KExpr.validationUnivRoots]) hulocal hufrontier + · simp [RecM.scopedExprWorkSize, + KExpr.validationChildrenAt, KExpr.treeSize] + · simpa [KExpr.validationChildrenAt] using hrun + | fvar id name info => + simp only [pure_bind] at hrun + apply finishFresh (afterUnivs := seenUnivs) + (nextState := state) (by trivial) + (AddressSetLE.refl seenUnivs) + (by simp [KExpr.validationUnivRoots]) hulocal hufrontier + · simp [RecM.scopedExprWorkSize, + KExpr.validationChildrenAt, KExpr.treeSize] + · simpa [KExpr.validationChildrenAt] using hrun + | sort level info => + simp only [pure_bind] at hrun + rw [ReaderT.run_bind, runTcBind] at hrun + cases hvalidate : + (validateUnivParamsSeen level bound seenUnivs).run + methods state with + | error err failed => + rw [hvalidate] at hrun + contradiction + | ok nextUnivs nextState => + rw [hvalidate] at hrun + have hlevel : KExpr.ValidationUnivReach root level := + hexpr.univRoot (by simp [KExpr.validationUnivRoots]) + have hvalidated := validateUnivParamsSeen_sound + hcoverage.univDomain hcollision hlevel hulocal hufrontier + hvalidate + apply finishFresh (afterUnivs := nextUnivs) + (nextState := nextState) (by trivial) + hvalidated.1.monotone + (by + intro candidate hmem + simpa [KExpr.validationUnivRoots] using + hvalidated.1.covered hmem) + hvalidated.1.locals hvalidated.1.frontier + · simp [RecM.scopedExprWorkSize, + KExpr.validationChildrenAt, KExpr.treeSize] + · simpa [KExpr.validationChildrenAt] using hrun + | const id levels info => + simp only [pure_bind] at hrun + rw [ReaderT.run_bind, ReaderT.run_monadLift, runTcBind] at hrun + cases hget : + (monadLift (TcM.getConst id) : TcM .anon (KConst .anon)) + state with + | error err failed => + simp only [hget] at hrun + contradiction + | ok declaration lookupState => + simp only [hget] at hrun + split at hrun + · contradiction + · rw [ReaderT.run_bind, runTcBind] at hrun + cases hloop : + ((forIn (m := RecM .anon) levels seenUnivs + (fun level current => do + let next ← validateUnivParamsSeen level bound current + pure (.yield next))).run methods lookupState) with + | error err failed => + rw [hloop] at hrun + contradiction + | ok nextUnivs nextState => + rw [hloop] at hrun + have hlevels : ∀ ⦃level⦄, level ∈ levels → + KExpr.ValidationUnivReach root level := by + intro level hmem + exact hexpr.univRoot (by + simpa [KExpr.validationUnivRoots] using hmem) + have hvalidated := validateUnivRootsArray_sound + hcoverage.univDomain hcollision bound levels seenUnivs + methods lookupState nextUnivs nextState hlevels + hulocal hufrontier hloop + apply finishFresh (afterUnivs := nextUnivs) + (nextState := nextState) (by trivial) + hvalidated.monotone + (by + intro candidate hmem + exact hvalidated.covered (by + simpa [KExpr.validationUnivRoots] using hmem)) + hvalidated.locals hvalidated.frontier + · simp [RecM.scopedExprWorkSize, + KExpr.validationChildrenAt, KExpr.treeSize] + · simpa [KExpr.validationChildrenAt] using hrun + | app fn arg info => + simp only [pure_bind] at hrun + apply finishFresh (afterUnivs := seenUnivs) + (nextState := state) (by trivial) + (AddressSetLE.refl seenUnivs) + (by simp [KExpr.validationUnivRoots]) hulocal hufrontier + · simp [RecM.scopedExprWorkSize, + KExpr.validationChildrenAt, KExpr.treeSize] + omega + · simpa [KExpr.validationChildrenAt] using hrun + | lam name bi type body info => + simp only [pure_bind] at hrun + apply finishFresh (afterUnivs := seenUnivs) + (nextState := state) (by trivial) + (AddressSetLE.refl seenUnivs) + (by simp [KExpr.validationUnivRoots]) hulocal hufrontier + · simp [RecM.scopedExprWorkSize, + KExpr.validationChildrenAt, KExpr.treeSize] + omega + · simpa [KExpr.validationChildrenAt] using hrun + | all name bi type body info => + simp only [pure_bind] at hrun + apply finishFresh (afterUnivs := seenUnivs) + (nextState := state) (by trivial) + (AddressSetLE.refl seenUnivs) + (by simp [KExpr.validationUnivRoots]) hulocal hufrontier + · simp [RecM.scopedExprWorkSize, + KExpr.validationChildrenAt, KExpr.treeSize] + omega + · simpa [KExpr.validationChildrenAt] using hrun + | letE name type value body nonDep info => + simp only [pure_bind] at hrun + apply finishFresh (afterUnivs := seenUnivs) + (nextState := state) (by trivial) + (AddressSetLE.refl seenUnivs) + (by simp [KExpr.validationUnivRoots]) hulocal hufrontier + · simp [RecM.scopedExprWorkSize, + KExpr.validationChildrenAt, KExpr.treeSize] + omega + · simpa [KExpr.validationChildrenAt] using hrun + | prj id field value info => + simp only [pure_bind] at hrun + rw [ReaderT.run_bind, ReaderT.run_monadLift, runTcBind] at hrun + cases hhas : + (monadLift (TcM.hasConst id) : TcM .anon Bool) state with + | error err failed => + simp only [hhas] at hrun + contradiction + | ok found nextState => + simp only [hhas] at hrun + split at hrun + · contradiction + · apply finishFresh (afterUnivs := seenUnivs) + (nextState := nextState) (by trivial) + (AddressSetLE.refl seenUnivs) + (by simp [KExpr.validationUnivRoots]) hulocal hufrontier + · simp [RecM.scopedExprWorkSize, + KExpr.validationChildrenAt, KExpr.treeSize] + · simpa [KExpr.validationChildrenAt] using hrun + | nat value blob info => + simp only [pure_bind] at hrun + apply finishFresh (afterUnivs := seenUnivs) + (nextState := state) (by trivial) + (AddressSetLE.refl seenUnivs) + (by simp [KExpr.validationUnivRoots]) hulocal hufrontier + · simp [RecM.scopedExprWorkSize, + KExpr.validationChildrenAt, KExpr.treeSize] + · simpa [KExpr.validationChildrenAt] using hrun + | str value blob info => + simp only [pure_bind] at hrun + apply finishFresh (afterUnivs := seenUnivs) + (nextState := state) (by trivial) + (AddressSetLE.refl seenUnivs) + (by simp [KExpr.validationUnivRoots]) hulocal hufrontier + · simp [RecM.scopedExprWorkSize, + KExpr.validationChildrenAt, KExpr.treeSize] + · simpa [KExpr.validationChildrenAt] using hrun +termination_by _ _ _ _ _ stack _ _ _ _ _ _ _ _ _ _ _ _ => + RecM.scopedExprWorkSize stack +decreasing_by + all_goals simp_all [RecM.scopedExprWorkSize, KExpr.validationChildrenAt] + +/-- Public expression-validator soundness. Starting from the production +empty memo sets, successful validation proves the requested root is fully +scoped at its exact binder depth and universe bound. -/ +theorem validateExprWellScoped_sound + {support : RunSupport} {root : KExpr .anon} + (hcoverage : root.ValidationCoverage support) + (hcollision : support.CollisionFree) + {depth : UInt64} {bound : Nat} + {methods : Methods .anon} {state after : TcState .anon} + (hrun : (validateExprWellScoped root depth bound).run methods state = + .ok () after) : + ∃ finalExprs finalUnivs, + ExprValidationPost root bound [(root, depth)] + ({} : HashSet (Address × UInt64)) finalExprs + ({} : HashSet Address) finalUnivs ∧ + root.Scoped depth bound := by + rw [RecM.validateExprWellScoped_equation] at hrun + obtain ⟨finalExprs, finalUnivs, hpost⟩ := + validateExprWellScoped_go_sound hcoverage hcollision bound + [(root, depth)] ({} : HashSet (Address × UInt64)) + ({} : HashSet Address) + (by + intro item hmem + rcases List.mem_singleton.mp hmem with rfl + exact .refl root) + (by + intro expr exprDepth hexpr hmem + simp at hmem) + (by + intro expr exprDepth hexpr hmem + simp at hmem) + (by + intro expr exprDepth hexpr hmem + simp at hmem) + (by + intro level hlevel hmem + simp at hmem) + (by + intro level hlevel hmem + simp at hmem) + methods state after hrun + have hseen : finalExprs.contains (root.addr, depth) = true := + hpost.covered (item := (root, depth)) (by simp) + have hscoped := hpost.exprFrontier.fullyScoped hcoverage + hpost.exprLocals hpost.exprUnivs hpost.univLocals hpost.univFrontier + (.refl root) hseen + exact ⟨finalExprs, finalUnivs, hpost, hscoped⟩ + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/WhnfBasicHelperPolicy.lean b/Ix/Tc/Verify/Check/WhnfBasicHelperPolicy.lean new file mode 100644 index 000000000..7b79519ee --- /dev/null +++ b/Ix/Tc/Verify/Check/WhnfBasicHelperPolicy.lean @@ -0,0 +1,458 @@ +import Ix.Tc.Verify.Check.WhnfReductionPolicy + +/-! +# Operational policy for non-recursive WHNF helpers + +This module discharges the inference-policy frame for the shared application +finisher, cached delta unfolding, projection definitions, String primitives, +and quotient reduction. Projection applications are derived in +`WhnfReductionPolicy` from their ordinary projection, WHNF callback, and +application-finisher components rather than retained as an independent +assumption. +-/ + +namespace Ix.Tc + +namespace RecM + +/-- Lift an already established checker-state policy through the recursive +method reader. -/ +theorem liftTcM_preservesInferOnly + {methods : Methods .anon} {x : TcM .anon alpha} + (hx : x.PreservesInferOnly) : + ((liftM x : RecM .anon alpha).run methods).PreservesInferOnly := by + simpa only [ReaderT.run_monadLift] using hx + +/-- Compose two recursive-method actions without exposing the reader +implementation at each helper proof. -/ +theorem bind_preservesInferOnly + {methods : Methods .anon} {x : RecM .anon alpha} + {next : alpha → RecM .anon beta} + (hx : (x.run methods).PreservesInferOnly) + (hnext : ∀ value, ((next value).run methods).PreservesInferOnly) : + ((do let value ← x; next value).run methods).PreservesInferOnly := by + simp only [ReaderT.run_bind] + exact TcM.PreservesInferOnly.bind hx hnext + +/-- Compose one checker action with a recursive-method continuation. -/ +theorem bindTcM_preservesInferOnly + {methods : Methods .anon} {x : TcM .anon alpha} + {next : alpha → RecM .anon beta} + (hx : x.PreservesInferOnly) + (hnext : ∀ value, ((next value).run methods).PreservesInferOnly) : + TcM.PreservesInferOnly + ((do + let value ← x + next value : RecM .anon beta).run methods) := by + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + change TcM.PreservesInferOnly + (x >>= fun value => ReaderT.run (next value) methods) + exact TcM.PreservesInferOnly.bind hx hnext + +/-- Interning changes only the intern table. -/ +theorem intern_preservesInferOnly (request : KExpr .anon) : + (TcM.intern request).PreservesInferOnly := by + exact TcM.PreservesInferOnly.runIntern (internExprM request) + +/-- Common one-intern recursive-method prefix. -/ +theorem bindIntern_preservesInferOnly + {methods : Methods .anon} (request : KExpr .anon) + {next : KExpr .anon → RecM .anon alpha} + (hnext : ∀ result, ((next result).run methods).PreservesInferOnly) : + TcM.PreservesInferOnly + ((do + let result ← TcM.intern request + next result : RecM .anon alpha).run methods) := by + exact bindTcM_preservesInferOnly + (intern_preservesInferOnly request) hnext + +/-- Reify a recursive-method exception as a value without changing the +inference-policy frame. -/ +theorem captureErrors_preservesInferOnly + {methods : Methods .anon} {x : RecM .anon alpha} + (hx : (x.run methods).PreservesInferOnly) : + TcM.PreservesInferOnly + ((try + let value ← x + pure (Except.ok value) + catch error => + pure (Except.error error) : + RecM .anon (Except (TcError .anon) alpha)).run methods) := by + exact TcM.PreservesInferOnly.tryCatch + (TcM.PreservesInferOnly.bind hx fun value => + TcM.PreservesInferOnly.pure (Except.ok value)) + (fun error => TcM.PreservesInferOnly.pure (Except.error error)) + +private theorem prims_preservesInferOnly (methods : Methods .anon) : + ((prims : RecM .anon (Primitives .anon)).run methods).PreservesInferOnly := by + unfold prims + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind TcM.PreservesInferOnly.get + intro state + exact TcM.PreservesInferOnly.pure state.prims + + +theorem finishAppResult_preservesInferOnly + {methods : Methods .anon} (base : KExpr .anon) + (args : Array (KExpr .anon)) (consumed : Nat) : + ((finishAppResult base args consumed).run methods).PreservesInferOnly := by + rw [finishAppResult_eq_foldlM, ← Array.foldlM_toList] + generalize hitems : (args.extract consumed args.size).toList = items + clear hitems + induction items generalizing base with + | nil => exact TcM.PreservesInferOnly.pure base + | cons arg rest ih => + rw [List.foldlM_cons, ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.runIntern + (internExprM (KExpr.mkApp base arg))) + intro result + exact ih result + +theorem unfoldConstValue_preservesInferOnly + {methods : Methods .anon} (head value : KExpr .anon) + (levels : Array (KUniv .anon)) : + ((unfoldConstValue head value levels).run methods).PreservesInferOnly := by + unfold unfoldConstValue + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind TcM.PreservesInferOnly.get + intro state + split + · exact TcM.PreservesInferOnly.pure _ + · apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.instantiateUnivParams value levels) + intro result + show ((do + modify fun state : TcState .anon => { state with env := { state.env with + unfoldCache := state.env.unfoldCache.insert head.addr result } } + pure result : RecM .anon (KExpr .anon)).run methods).PreservesInferOnly + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.modify + (f := fun state : TcState .anon => { state with env := { state.env with + unfoldCache := state.env.unfoldCache.insert head.addr result } }) + (fun _ => rfl)) + intro _ + exact TcM.PreservesInferOnly.pure result + +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] + +theorem tryDeltaUnfold_preservesInferOnly + {methods : Methods .anon} (source : KExpr .anon) : + ((tryDeltaUnfold source).run methods).PreservesInferOnly := by + unfold tryDeltaUnfold + rcases hspine : source.collectSpine with ⟨head, args⟩ + cases head with + | const id levels info => + simp only [pure_bind, ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.tryGetConst id) + intro found + cases found with + | none => exact TcM.PreservesInferOnly.pure none + | some declaration => + cases declaration + case defn name levelParams kind safety hints lvls ty value leanAll + block => + cases kind with + | opaq => exact TcM.PreservesInferOnly.pure none + | defn | thm => + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind + (unfoldConstValue_preservesInferOnly + (.const id levels info) value levels) + intro base + rw [deltaFinish_eq] + apply TcM.PreservesInferOnly.bind + (finishAppResult_preservesInferOnly base args 0) + intro result + exact TcM.PreservesInferOnly.pure (some result) + all_goals exact TcM.PreservesInferOnly.pure none + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + exact TcM.PreservesInferOnly.pure none + +theorem deltaUnfoldOne_preservesInferOnly + {methods : Methods .anon} (source : KExpr .anon) : + ((deltaUnfoldOne source).run methods).PreservesInferOnly := by + unfold deltaUnfoldOne + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind + (tryDeltaUnfold_preservesInferOnly source) + intro unfolded + cases unfolded with + | some result => exact TcM.PreservesInferOnly.pure (some result) + | none => + cases source with + | const id levels info => + simp only [pure_bind, ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.tryGetConst id) + intro found + cases found with + | none => exact TcM.PreservesInferOnly.pure none + | some declaration => + cases declaration + case defn name levelParams kind safety hints lvls ty value + leanAll block => + cases kind with + | opaq => exact TcM.PreservesInferOnly.pure none + | defn | thm => + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind + (unfoldConstValue_preservesInferOnly + (.const id levels info) value levels) + intro result + exact TcM.PreservesInferOnly.pure (some result) + all_goals exact TcM.PreservesInferOnly.pure none + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + exact TcM.PreservesInferOnly.pure none + +theorem tryReduceProjectionDefinition_preservesInferOnly + {methods : Methods .anon} (source : KExpr .anon) : + ((tryReduceProjectionDefinition source).run methods).PreservesInferOnly := by + unfold tryReduceProjectionDefinition + rcases hspine : source.collectSpine with ⟨head, args⟩ + cases head with + | const id levels info => + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.tryGetConst id) + intro found + cases found with + | none => exact TcM.PreservesInferOnly.pure none + | some declaration => + cases declaration + case defn name levelParams kind safety hints lvls ty value leanAll block => + cases kind with + | opaq => + simp only + exact TcM.PreservesInferOnly.pure none + | thm => + simp only + exact TcM.PreservesInferOnly.pure none + | defn => + simp only [pure_bind] + cases hinfo : projectionDefinitionInfo value with + | none => + simp only [] + exact TcM.PreservesInferOnly.pure none + | some projection => + rcases projection with ⟨arity, structId, field, + structArgIdx⟩ + simp only [] + split + · exact TcM.PreservesInferOnly.pure none + · simp only [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.runIntern + (internExprM (KExpr.mkPrj structId field + args[structArgIdx]!))) + intro base + simp only [projectionDefinitionFinish_eq] + apply TcM.PreservesInferOnly.bind + (finishAppResult_preservesInferOnly base args arity) + intro result + exact TcM.PreservesInferOnly.pure (some result) + all_goals exact TcM.PreservesInferOnly.pure none + | var idx name info => exact TcM.PreservesInferOnly.pure none + | fvar id name info => exact TcM.PreservesInferOnly.pure none + | sort u info => exact TcM.PreservesInferOnly.pure none + | app f a info => exact TcM.PreservesInferOnly.pure none + | lam name bi ty body info => exact TcM.PreservesInferOnly.pure none + | all name bi ty body info => exact TcM.PreservesInferOnly.pure none + | letE name ty value body nondep info => + exact TcM.PreservesInferOnly.pure none + | prj id field value info => exact TcM.PreservesInferOnly.pure none + | nat value blob info => exact TcM.PreservesInferOnly.pure none + | str value blob info => exact TcM.PreservesInferOnly.pure none + +theorem charOfNatExpr_preservesInferOnly + {methods : Methods .anon} (value : Nat) : + ((charOfNatExpr value).run methods).PreservesInferOnly := by + unfold charOfNatExpr + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.PreservesInferOnly.bind (prims_preservesInferOnly methods) + intro p + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.runIntern + (internExprM (KExpr.mkConst p.charOfNat #[]))) + intro charOfNat + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.runIntern + (internExprM (natExprFromValue value : KExpr .anon))) + intro natLiteral + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.runIntern + (internExprM (KExpr.mkApp charOfNat natLiteral))) + intro result + exact TcM.PreservesInferOnly.pure (some result) + +theorem tryReduceStringLiteral_preservesInferOnly + {methods : Methods .anon} (p : Primitives .anon) (id : KId .anon) + (value : String) : + ((tryReduceStringLiteral p id value).run methods).PreservesInferOnly := by + unfold tryReduceStringLiteral + cases hutf8 : id.addr == p.stringUtf8ByteSize.addr with + | true => + simp only [if_true] + change (TcM.runIntern + (internExprM + (natExprFromValue value.utf8ByteSize : KExpr .anon)) >>= fun result => + pure (some result)).PreservesInferOnly + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.runIntern + (internExprM + (natExprFromValue value.utf8ByteSize : KExpr .anon))) + intro result + exact TcM.PreservesInferOnly.pure (some result) + | false => + simp only [Bool.false_eq_true, if_false, pure_bind] + cases hbytes : id.addr == p.stringToByteArray.addr with + | true => + simp only [if_true] + cases hempty : value.isEmpty with + | true => + simp only [if_true] + change (TcM.runIntern + (internExprM (KExpr.mkConst p.byteArrayEmpty #[])) >>= + fun result => pure (some result)).PreservesInferOnly + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.runIntern + (internExprM (KExpr.mkConst p.byteArrayEmpty #[]))) + intro result + exact TcM.PreservesInferOnly.pure (some result) + | false => + simp only [Bool.false_eq_true, if_false] + exact TcM.PreservesInferOnly.pure none + | false => + simp only [Bool.false_eq_true, if_false] + exact charOfNatExpr_preservesInferOnly (methods := methods) _ + +theorem tryReduceString_preservesInferOnly + {methods : Methods .anon} (source : KExpr .anon) : + ((tryReduceString source).run methods).PreservesInferOnly := by + unfold tryReduceString + rcases hspine : source.collectSpine with ⟨head, args⟩ + cases hsize : args.size != 1 with + | true => + simp only [hsize, if_true] + exact TcM.PreservesInferOnly.pure none + | false => + simp only [hsize, Bool.false_eq_true, if_false] + cases head with + | const id levels info => + simp only [pure_bind, ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind + (prims_preservesInferOnly methods) + intro p + cases hguard : + (!(id.addr == p.stringBack.addr || + id.addr == p.stringLegacyBack.addr) && + !(id.addr == p.stringUtf8ByteSize.addr) && + !(id.addr == p.stringToByteArray.addr)) with + | true => + simp only [if_true] + exact TcM.PreservesInferOnly.pure none + | false => + simp only [Bool.false_eq_true, if_false] + cases args[0]! with + | str value blob info => + exact tryReduceStringLiteral_preservesInferOnly + (methods := methods) p id value + | var | fvar | sort | const | app | lam | all | letE | prj | + nat => + exact TcM.PreservesInferOnly.pure none + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + simp only [pure_bind] + exact TcM.PreservesInferOnly.pure none + +theorem tryQuotReduceSelected_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (p : Primitives .anon) (args : Array (KExpr .anon)) + (functionIndex majorIndex : Nat) : + TcM.PreservesInferOnly + ((tryQuotReduceSelected p args functionIndex majorIndex).run methods) := by + unfold tryQuotReduceSelected + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind + (whnfRec_preservesInferOnly hmethods args[majorIndex]!) + intro major + rcases hspine : major.collectSpine with ⟨head, majorArgs⟩ + cases head with + | const id levels info => + cases hctor : id.addr != p.quotCtor.addr with + | true => + simp only [hctor, if_true] + exact TcM.PreservesInferOnly.pure none + | false => + simp only [hctor, Bool.false_eq_true, if_false] + cases hsize : majorArgs.size != 3 with + | true => + simp only [if_true] + exact TcM.PreservesInferOnly.pure none + | false => + simp only [Bool.false_eq_true, if_false, pure_bind, + ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.runIntern + (internExprM + (KExpr.mkApp args[functionIndex]! majorArgs[2]!))) + intro base + rw [projectionDefinitionFinish_eq] + apply TcM.PreservesInferOnly.bind + (finishAppResult_preservesInferOnly base args + (majorIndex + 1)) + intro result + exact TcM.PreservesInferOnly.pure (some result) + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + simp only + exact TcM.PreservesInferOnly.pure none + +theorem tryQuotReduce_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (source : KExpr .anon) : + ((tryQuotReduce source).run methods).PreservesInferOnly := by + unfold tryQuotReduce + rcases hspine : source.collectSpine with ⟨head, args⟩ + cases head with + | const id levels info => + simp only [pure_bind, ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind (prims_preservesInferOnly methods) + intro p + cases hlift : id.addr == p.quotLift.addr with + | true => + simp only [if_true] + by_cases hsize : args.size < 6 + · simp only [hsize, if_pos] + exact TcM.PreservesInferOnly.pure none + · simp only [hsize, if_false] + simpa only [tryQuotReduceSelected] using + tryQuotReduceSelected_preservesInferOnly hmethods p args 3 5 + | false => + simp only [Bool.false_eq_true, if_false] + cases hind : id.addr == p.quotInd.addr with + | true => + simp only [if_true] + by_cases hsize : args.size < 5 + · simp only [hsize, if_pos] + exact TcM.PreservesInferOnly.pure none + · simp only [hsize, if_false] + simpa only [tryQuotReduceSelected] using + tryQuotReduceSelected_preservesInferOnly hmethods p args 3 4 + | false => + simp only [Bool.false_eq_true, if_false] + exact TcM.PreservesInferOnly.pure none + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + simp only + exact TcM.PreservesInferOnly.pure none + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/WhnfBitVecPolicy.lean b/Ix/Tc/Verify/Check/WhnfBitVecPolicy.lean new file mode 100644 index 000000000..2856c8a5a --- /dev/null +++ b/Ix/Tc/Verify/Check/WhnfBitVecPolicy.lean @@ -0,0 +1,493 @@ +import Ix.Tc.Verify.Check.WhnfNatPolicy + +/-! +# Operational inference-policy frame for BitVec reduction + +This module verifies the bounded Nat evaluator used by BitVec predicates and +the complete `BitVec.toNat`, `BitVec.ult`, and `Decidable.decide` accelerator +pipeline. All recursive WHNF calls, fallback paths, and rebuilt applications +restore the caller's inference policy. +-/ + +namespace Ix.Tc + +namespace RecM + + +private theorem prims_preservesInferOnly (methods : Methods .anon) : + ((prims : RecM .anon (Primitives .anon)).run methods).PreservesInferOnly := by + unfold prims + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind TcM.PreservesInferOnly.get + intro state + exact TcM.PreservesInferOnly.pure state.prims + +theorem mkNatSucc_preservesInferOnly + {methods : Methods .anon} (pred : KExpr .anon) : + ((mkNatSucc pred).run methods).PreservesInferOnly := by + unfold mkNatSucc + refine bind_preservesInferOnly (prims_preservesInferOnly methods) ?_ + intro p + exact TcM.PreservesInferOnly.pure _ + +theorem boolLitValue_preservesInferOnly + {methods : Methods .anon} (source : KExpr .anon) : + ((boolLitValue source).run methods).PreservesInferOnly := by + unfold boolLitValue + refine bind_preservesInferOnly (prims_preservesInferOnly methods) ?_ + intro p + cases source with + | const id levels info => + simp only [] + cases htrue : id.addr == p.boolTrue.addr with + | true => + simp only [if_true] + exact TcM.PreservesInferOnly.pure (some true) + | false => + simp only [Bool.false_eq_true, if_false] + split <;> exact TcM.PreservesInferOnly.pure _ + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + exact TcM.PreservesInferOnly.pure none + +theorem isNatStuckRecursorAddr_preservesInferOnly + {methods : Methods .anon} (addr : Address) : + ((isNatStuckRecursorAddr addr).run methods).PreservesInferOnly := by + unfold isNatStuckRecursorAddr + refine bind_preservesInferOnly (prims_preservesInferOnly methods) ?_ + intro p + exact TcM.PreservesInferOnly.pure _ + +theorem isStuckNatPredicateProbe_preservesInferOnly + {methods : Methods .anon} (source : KExpr .anon) : + ((isStuckNatPredicateProbe source).run methods).PreservesInferOnly := by + unfold isStuckNatPredicateProbe + rcases hspine : source.collectSpine with ⟨head, args⟩ + cases head with + | const id levels info => + refine bind_preservesInferOnly + (isNatBinPredAddr_preservesInferOnly id.addr) ?_ + intro isPredicate + refine bind_preservesInferOnly + (isNatStuckRecursorAddr_preservesInferOnly id.addr) ?_ + intro isStuck + exact TcM.PreservesInferOnly.pure (isPredicate || isStuck) + | prj id field value info => + simp only [] + refine bind_preservesInferOnly (prims_preservesInferOnly methods) ?_ + intro p + split + · exact TcM.PreservesInferOnly.pure true + · rcases hvalueSpine : value.collectSpine with ⟨valueHead, valueArgs⟩ + cases valueHead with + | const valueId levels valueInfo => + exact isNatStuckRecursorAddr_preservesInferOnly valueId.addr + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + exact TcM.PreservesInferOnly.pure false + | var | fvar | sort | app | lam | all | letE | nat | str => + simp only [] + exact TcM.PreservesInferOnly.pure false + +theorem bitvecOfNatArgs_preservesInferOnly + {methods : Methods .anon} (source : KExpr .anon) : + ((bitvecOfNatArgs source).run methods).PreservesInferOnly := by + unfold bitvecOfNatArgs + refine bind_preservesInferOnly (prims_preservesInferOnly methods) ?_ + intro p + rcases hspine : source.collectSpine with ⟨head, args⟩ + cases head with + | const id levels info => + simp only [] + split + · exact TcM.PreservesInferOnly.pure _ + · split + · exact TcM.PreservesInferOnly.pure none + · rcases htypeSpine : args[0]!.collectSpine with + ⟨typeHead, typeArgs⟩ + cases typeHead with + | const typeId typeLevels typeInfo => + simp only [pure_bind] + split <;> exact TcM.PreservesInferOnly.pure _ + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + exact TcM.PreservesInferOnly.pure none + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + simp only [] + exact TcM.PreservesInferOnly.pure none + +private theorem tryEvalNatValueForPredFallback_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hrec : ∀ source, + ((tryEvalNatValueForPredFuel fuel source).run methods).PreservesInferOnly) + (p : Primitives .anon) (source : KExpr .anon) : + ((do + let normalized ← whnfRec source + if let some value := extractNatValue normalized p then + return some value + if normalized.addr == source.addr then + return none + tryEvalNatValueForPredFuel fuel normalized).run methods).PreservesInferOnly := by + refine bind_preservesInferOnly + (whnfRec_preservesInferOnly hmethods source) ?_ + intro normalized + cases hvalue : extractNatValue normalized p with + | some value => + simp only [] + exact TcM.PreservesInferOnly.pure (some value) + | none => + simp only [pure_bind] + split + · exact TcM.PreservesInferOnly.pure none + · exact hrec normalized + +theorem tryEvalNatValueForPredFuel_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) : + ∀ fuel source, + ((tryEvalNatValueForPredFuel fuel source).run methods).PreservesInferOnly + | 0, source => by + rw [tryEvalNatValueForPredFuel] + exact TcM.PreservesInferOnly.pure none + | fuel + 1, source => by + rw [tryEvalNatValueForPredFuel] + refine bind_preservesInferOnly (prims_preservesInferOnly methods) ?_ + intro p + cases hliteral : extractNatLit source p with + | some value => + simp only [] + exact TcM.PreservesInferOnly.pure (some value) + | none => + simp only [pure_bind] + refine bind_preservesInferOnly + (isStuckNatPredicateProbe_preservesInferOnly source) ?_ + intro isStuck + cases hstuck : isStuck with + | true => + simp only [if_true] + exact TcM.PreservesInferOnly.pure none + | false => + simp only [Bool.false_eq_true, if_false] + rcases hspine : source.collectSpine with ⟨head, args⟩ + cases head with + | const id levels info => + simp only [] + cases hsucc : + id.addr == p.natSucc.addr && args.size == 1 with + | true => + simp only [if_true] + refine bind_preservesInferOnly + (tryEvalNatValueForPredFuel_preservesInferOnly hmethods + fuel args[0]!) ?_ + intro predResult + cases predResult with + | none => exact TcM.PreservesInferOnly.pure none + | some pred => + exact TcM.PreservesInferOnly.pure (some (pred + 1)) + | false => + simp only [Bool.false_eq_true, if_false] + cases hpred : + id.addr == p.natPred.addr && args.size == 1 with + | true => + simp only [if_true] + refine bind_preservesInferOnly + (tryEvalNatValueForPredFuel_preservesInferOnly + hmethods fuel args[0]!) ?_ + intro predResult + cases predResult with + | none => exact TcM.PreservesInferOnly.pure none + | some value => + exact TcM.PreservesInferOnly.pure + (some (value - 1)) + | false => + simp only [Bool.false_eq_true, if_false] + refine bind_preservesInferOnly + (isNatBinArithAddr_preservesInferOnly id.addr) ?_ + intro isArith + cases hbinary : isArith && args.size == 2 with + | true => + simp only [if_true] + refine bind_preservesInferOnly + (tryEvalNatValueForPredFuel_preservesInferOnly + hmethods fuel args[0]!) ?_ + intro leftResult + cases leftResult with + | none => + exact TcM.PreservesInferOnly.pure none + | some left => + simp only [] + refine bind_preservesInferOnly + (tryEvalNatValueForPredFuel_preservesInferOnly + hmethods fuel args[1]!) ?_ + intro rightResult + cases rightResult with + | none => + exact TcM.PreservesInferOnly.pure none + | some right => + exact TcM.PreservesInferOnly.pure + (computeNatBin id.addr + PrimAddrs.canonical left right) + | false => + simp only [Bool.false_eq_true, if_false] + exact + tryEvalNatValueForPredFallback_preservesInferOnly + hmethods + (tryEvalNatValueForPredFuel_preservesInferOnly + hmethods fuel) + p source + | app f a info | letE _ _ _ _ _ info | prj _ _ _ info => + simp only [] + exact tryEvalNatValueForPredFallback_preservesInferOnly + hmethods + (tryEvalNatValueForPredFuel_preservesInferOnly hmethods + fuel) + p source + | var | fvar | sort | lam | all | nat | str => + exact TcM.PreservesInferOnly.pure none + +theorem tryEvalNatValueForPred_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (source : KExpr .anon) (depth : Nat := 0) : + ((tryEvalNatValueForPred source depth).run methods).PreservesInferOnly := by + unfold tryEvalNatValueForPred + exact tryEvalNatValueForPredFuel_preservesInferOnly hmethods _ source + +theorem tryReduceBitvecToNat_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (value : KExpr .anon) : + ((tryReduceBitvecToNat value).run methods).PreservesInferOnly := by + unfold tryReduceBitvecToNat + refine bind_preservesInferOnly + (bitvecOfNatArgs_preservesInferOnly value) ?_ + intro parts + cases parts with + | none => exact TcM.PreservesInferOnly.pure none + | some pair => + rcases pair with ⟨width, natExpr⟩ + simp only [] + refine bind_preservesInferOnly + (whnfRec_preservesInferOnly hmethods natExpr) ?_ + intro normalized + refine bind_preservesInferOnly (prims_preservesInferOnly methods) ?_ + intro p + cases hvalue : extractNatValue normalized p with + | none => exact TcM.PreservesInferOnly.pure none + | some natValue => + simp only [] + cases hzero : natValue == 0 with + | true => + simp only [if_true] + exact TcM.PreservesInferOnly.pure _ + | false => + simp only [Bool.false_eq_true, if_false, pure_bind] + refine bind_preservesInferOnly + (tryEvalNatValueForPred_preservesInferOnly hmethods width) ?_ + intro widthResult + cases widthResult with + | none => exact TcM.PreservesInferOnly.pure none + | some widthValue => + by_cases hlarge : widthValue > (1 <<< 24) + · simp only [hlarge, if_pos] + exact TcM.PreservesInferOnly.pure none + · simp only [hlarge] + exact TcM.PreservesInferOnly.pure _ + +theorem bitvecToNatExpr_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (width value : KExpr .anon) : + ((bitvecToNatExpr width value).run methods).PreservesInferOnly := by + unfold bitvecToNatExpr + refine bind_preservesInferOnly + (tryReduceBitvecToNat_preservesInferOnly hmethods value) ?_ + intro direct + cases direct with + | some result => exact TcM.PreservesInferOnly.pure result + | none => + simp only [pure_bind] + refine bind_preservesInferOnly (prims_preservesInferOnly methods) ?_ + intro p + refine bindIntern_preservesInferOnly (.mkConst p.bitVecToNat #[]) ?_ + intro head + refine bindIntern_preservesInferOnly (.mkApp head width) ?_ + intro withWidth + exact intern_preservesInferOnly (.mkApp withWidth value) + +private theorem tryReduceBitvecUltFallback_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (p : Primitives .anon) (leftNat rightNat : KExpr .anon) : + ((do + let leftSucc ← mkNatSucc leftNat + let ble ← TcM.intern (.mkConst p.natBle #[]) + let cmpLeft ← TcM.intern (.mkApp ble leftSucc) + let cmp ← TcM.intern (.mkApp cmpLeft rightNat) + let result ← whnfRec cmp + if (← boolLitValue result).isSome then + return some result + return none).run methods).PreservesInferOnly := by + refine bind_preservesInferOnly + (mkNatSucc_preservesInferOnly leftNat) ?_ + intro leftSucc + refine bindIntern_preservesInferOnly (.mkConst p.natBle #[]) ?_ + intro ble + refine bindIntern_preservesInferOnly (.mkApp ble leftSucc) ?_ + intro cmpLeft + refine bindIntern_preservesInferOnly (.mkApp cmpLeft rightNat) ?_ + intro cmp + refine bind_preservesInferOnly + (whnfRec_preservesInferOnly hmethods cmp) ?_ + intro result + refine bind_preservesInferOnly + (boolLitValue_preservesInferOnly result) ?_ + intro literal + split <;> exact TcM.PreservesInferOnly.pure _ + +theorem tryReduceBitvecUlt_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (width left right : KExpr .anon) : + ((tryReduceBitvecUlt width left right).run methods).PreservesInferOnly := by + unfold tryReduceBitvecUlt + refine bind_preservesInferOnly (prims_preservesInferOnly methods) ?_ + intro p + refine bind_preservesInferOnly + (bitvecToNatExpr_preservesInferOnly hmethods width left) ?_ + intro leftNat + refine bind_preservesInferOnly + (bitvecToNatExpr_preservesInferOnly hmethods width right) ?_ + intro rightNat + refine bind_preservesInferOnly + (whnfRec_preservesInferOnly hmethods rightNat) ?_ + intro rightNormalized + cases hright : extractNatValue rightNormalized p with + | none => + simp only [pure_bind] + exact tryReduceBitvecUltFallback_preservesInferOnly hmethods p leftNat + rightNat + | some rightValue => + simp only [] + cases hzero : rightValue == 0 with + | true => + simp only [if_true] + refine bindIntern_preservesInferOnly + (.mkConst p.boolFalse #[]) ?_ + intro result + exact TcM.PreservesInferOnly.pure (some result) + | false => + simp only [Bool.false_eq_true, if_false, pure_bind] + refine bind_preservesInferOnly + (whnfRec_preservesInferOnly hmethods leftNat) ?_ + intro leftNormalized + cases hleft : extractNatValue leftNormalized p with + | some leftValue => + simp only [] + refine bindIntern_preservesInferOnly + (.mkConst (if leftValue < rightValue then p.boolTrue + else p.boolFalse) #[]) ?_ + intro result + exact TcM.PreservesInferOnly.pure (some result) + | none => + simp only [] + exact tryReduceBitvecUltFallback_preservesInferOnly hmethods p + leftNat rightNat + +theorem tryReduceBitvecLtProp_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (prop : KExpr .anon) : + ((tryReduceBitvecLtProp prop).run methods).PreservesInferOnly := by + unfold tryReduceBitvecLtProp + refine bind_preservesInferOnly (prims_preservesInferOnly methods) ?_ + intro p + rcases hspine : prop.collectSpine with ⟨head, args⟩ + cases head with + | const id levels info => + simp only [] + split + · exact TcM.PreservesInferOnly.pure none + · simp only [pure_bind] + rcases htypeSpine : args[0]!.collectSpine with + ⟨typeHead, typeArgs⟩ + cases typeHead with + | const typeId typeLevels typeInfo => + simp only [] + split + · exact TcM.PreservesInferOnly.pure none + · exact tryReduceBitvecUlt_preservesInferOnly hmethods typeArgs[0]! + args[2]! args[3]! + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + exact TcM.PreservesInferOnly.pure none + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + simp only [] + exact TcM.PreservesInferOnly.pure none + +theorem tryReduceBitvec_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (source : KExpr .anon) : + ((tryReduceBitvec source).run methods).PreservesInferOnly := by + unfold tryReduceBitvec + refine bindTcM_preservesInferOnly TcM.PreservesInferOnly.get ?_ + intro state + cases hnoAccel : state.noAccel with + | true => + simp only [if_true] + exact TcM.PreservesInferOnly.pure none + | false => + simp only [Bool.false_eq_true, if_false, pure_bind] + refine bind_preservesInferOnly (prims_preservesInferOnly methods) ?_ + intro p + rcases hspine : source.collectSpine with ⟨head, args⟩ + cases head with + | const id levels info => + simp only [] + cases htoNat : + id.addr == p.bitVecToNat.addr && decide (args.size ≥ 2) with + | true => + simp only [if_true] + refine bind_preservesInferOnly + (tryReduceBitvecToNat_preservesInferOnly hmethods args[1]!) ?_ + intro direct + cases direct with + | none => exact TcM.PreservesInferOnly.pure none + | some result => + refine bind_preservesInferOnly + (finishAppResult_preservesInferOnly result args 2) ?_ + intro finished + exact TcM.PreservesInferOnly.pure (some finished) + | false => + simp only [Bool.false_eq_true, if_false] + cases hult : + id.addr == p.bitVecUlt.addr && decide (args.size ≥ 3) with + | true => + simp only [if_true] + refine bind_preservesInferOnly + (tryReduceBitvecUlt_preservesInferOnly hmethods args[0]! + args[1]! args[2]!) ?_ + intro direct + cases direct with + | none => exact TcM.PreservesInferOnly.pure none + | some result => + refine bind_preservesInferOnly + (finishAppResult_preservesInferOnly result args 3) ?_ + intro finished + exact TcM.PreservesInferOnly.pure (some finished) + | false => + simp only [Bool.false_eq_true, if_false] + cases hdecide : + id.addr == p.decidableDecide.addr && + decide (args.size ≥ 2) with + | true => + simp only [if_true] + refine bind_preservesInferOnly + (tryReduceBitvecLtProp_preservesInferOnly hmethods + args[0]!) ?_ + intro direct + cases direct with + | none => exact TcM.PreservesInferOnly.pure none + | some result => + refine bind_preservesInferOnly + (finishAppResult_preservesInferOnly result args 2) ?_ + intro finished + exact TcM.PreservesInferOnly.pure (some finished) + | false => + simp only [Bool.false_eq_true, if_false] + exact TcM.PreservesInferOnly.pure none + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + exact TcM.PreservesInferOnly.pure none + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/WhnfDecidablePolicy.lean b/Ix/Tc/Verify/Check/WhnfDecidablePolicy.lean new file mode 100644 index 000000000..8aa52f2c8 --- /dev/null +++ b/Ix/Tc/Verify/Check/WhnfDecidablePolicy.lean @@ -0,0 +1,354 @@ +import Ix.Tc.Verify.Check.WhnfBitVecPolicy + +/-! +# Operational inference-policy frame for decidability reduction + +This module verifies native Nat decidability and Int-literal normalization. +It covers validation-only proposition inference, caught inference misses, +recursive type normalization, canonical proof-term interning, application +rebuilding, and every accelerator fallback. +-/ + +namespace Ix.Tc + +namespace RecM + + +private theorem prims_preservesInferOnly (methods : Methods .anon) : + ((prims : RecM .anon (Primitives .anon)).run methods).PreservesInferOnly := by + unfold prims + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind TcM.PreservesInferOnly.get + intro state + exact TcM.PreservesInferOnly.pure state.prims + +theorem internIntLit_preservesInferOnly + {methods : Methods .anon} (value : _root_.Int) : + ((internIntLit value).run methods).PreservesInferOnly := by + unfold internIntLit + refine bind_preservesInferOnly (prims_preservesInferOnly methods) ?_ + intro p + by_cases hnegative : value < 0 + · simp only [hnegative, if_pos] + refine bindIntern_preservesInferOnly + (natExprFromValue ((-value).toNat - 1) : KExpr .anon) ?_ + intro natExpr + refine bindIntern_preservesInferOnly (.mkConst p.intNegSucc #[]) ?_ + intro ctor + exact intern_preservesInferOnly (.mkApp ctor natExpr) + · simp only [hnegative] + refine bindIntern_preservesInferOnly + (natExprFromValue value.toNat : KExpr .anon) ?_ + intro natExpr + refine bindIntern_preservesInferOnly (.mkConst p.intOfNat #[]) ?_ + intro ctor + exact intern_preservesInferOnly (.mkApp ctor natExpr) + +attribute [local irreducible] internIntLit + +theorem tryNormalizeIntDecidable_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (addr : Address) (args : Array (KExpr .anon)) : + ((tryNormalizeIntDecidable addr args).run methods).PreservesInferOnly := by + unfold tryNormalizeIntDecidable + by_cases hsmall : args.size < 2 + · simp only [hsmall, if_pos] + exact TcM.PreservesInferOnly.pure none + · simp only [hsmall, if_false, pure_bind] + refine bind_preservesInferOnly + (whnfRec_preservesInferOnly hmethods args[0]!) ?_ + intro leftNormalized + refine bind_preservesInferOnly + (whnfRec_preservesInferOnly hmethods args[1]!) ?_ + intro rightNormalized + refine bind_preservesInferOnly (prims_preservesInferOnly methods) ?_ + intro p + cases hleft : extractIntLit leftNormalized p with + | none => exact TcM.PreservesInferOnly.pure none + | some leftValue => + simp only [] + cases hright : extractIntLit rightNormalized p with + | none => exact TcM.PreservesInferOnly.pure none + | some rightValue => + simp only [] + refine bind_preservesInferOnly + (internIntLit_preservesInferOnly leftValue) ?_ + intro left + refine bind_preservesInferOnly + (internIntLit_preservesInferOnly rightValue) ?_ + intro right + cases hsame : left.addr == args[0]!.addr && + right.addr == args[1]!.addr with + | true => + simp only [if_true] + exact TcM.PreservesInferOnly.pure none + | false => + simp only [Bool.false_eq_true, if_false] + let headId := if addr == p.intDecEq.addr then p.intDecEq + else if addr == p.intDecLe.addr then p.intDecLe + else p.intDecLt + refine bindIntern_preservesInferOnly (.mkConst headId #[]) ?_ + intro head + refine bindIntern_preservesInferOnly (.mkApp head left) ?_ + intro withLeft + refine bindIntern_preservesInferOnly (.mkApp withLeft right) ?_ + intro applied + refine bind_preservesInferOnly + (finishAppResult_preservesInferOnly applied args 2) ?_ + intro finished + exact TcM.PreservesInferOnly.pure (some finished) + +attribute [local irreducible] tryNormalizeIntDecidable + +private theorem tryInferDecidableProp_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (source : KExpr .anon) : + ((inferDecidableProp source).run methods).PreservesInferOnly := by + unfold inferDecidableProp + refine bind_preservesInferOnly + (x := (read : RecM .anon (Methods .anon))) + (TcM.PreservesInferOnly.pure methods) ?_ + intro callbackMethods + refine bind_preservesInferOnly + (tryOptional_preservesInferOnly + (liftTcM_preservesInferOnly + (TcM.PreservesInferOnly.withInferOnly + (callbackMethods.infer source)))) ?_ + intro inferred + cases inferred with + | none => exact TcM.PreservesInferOnly.pure none + | some sourceType => + simp only [] + refine bind_preservesInferOnly + (whnfRec_preservesInferOnly hmethods sourceType) ?_ + intro normalizedType + exact TcM.PreservesInferOnly.pure normalizedType.collectSpine.2[0]? + +attribute [local irreducible] inferDecidableProp + +private theorem buildNatDecidableTrue_preservesInferOnly + {methods : Methods .anon} (p : Primitives .anon) + (prop : KExpr .anon) (args : Array (KExpr .anon)) + (proofTrueFn : KId .anon) (u1 : KUniv .anon) : + ((buildNatDecidableTrue p prop args proofTrueFn u1).run + methods).PreservesInferOnly := by + unfold buildNatDecidableTrue + refine bindIntern_preservesInferOnly (.mkConst p.eqRefl #[u1]) ?_ + intro eqRefl + refine bindIntern_preservesInferOnly (.mkConst p.boolType #[]) ?_ + intro boolTy + refine bindIntern_preservesInferOnly (.mkConst p.boolTrue #[]) ?_ + intro boolTrue + refine bindIntern_preservesInferOnly (.mkApp eqRefl boolTy) ?_ + intro reflHead + refine bindIntern_preservesInferOnly (.mkApp reflHead boolTrue) ?_ + intro reflProof + refine bindIntern_preservesInferOnly (.mkConst proofTrueFn #[]) ?_ + intro proofConst + refine bindIntern_preservesInferOnly (.mkApp proofConst args[0]!) ?_ + intro proofLeft + refine bindIntern_preservesInferOnly (.mkApp proofLeft args[1]!) ?_ + intro proofArgs + refine bindIntern_preservesInferOnly (.mkApp proofArgs reflProof) ?_ + intro proof + refine bindIntern_preservesInferOnly (.mkConst p.decidableIsTrue #[]) ?_ + intro isTrue + refine bindIntern_preservesInferOnly (.mkApp isTrue prop) ?_ + intro result + exact intern_preservesInferOnly (.mkApp result proof) + +private theorem buildNatDecidableFalse_preservesInferOnly + {methods : Methods .anon} (p : Primitives .anon) + (prop : KExpr .anon) (args : Array (KExpr .anon)) + (proofFalseFn : KId .anon) (u1 : KUniv .anon) : + ((buildNatDecidableFalse p prop args proofFalseFn u1).run + methods).PreservesInferOnly := by + unfold buildNatDecidableFalse + refine bindIntern_preservesInferOnly (.mkConst p.eqRefl #[u1]) ?_ + intro eqRefl + refine bindIntern_preservesInferOnly (.mkConst p.boolType #[]) ?_ + intro boolTy + refine bindIntern_preservesInferOnly (.mkConst p.boolFalse #[]) ?_ + intro boolFalse + refine bindIntern_preservesInferOnly (.mkApp eqRefl boolTy) ?_ + intro reflHead + refine bindIntern_preservesInferOnly (.mkApp reflHead boolFalse) ?_ + intro reflProof + refine bindIntern_preservesInferOnly (.mkConst proofFalseFn #[]) ?_ + intro proofConst + refine bindIntern_preservesInferOnly (.mkApp proofConst args[0]!) ?_ + intro proofLeft + refine bindIntern_preservesInferOnly (.mkApp proofLeft args[1]!) ?_ + intro proofArgs + refine bindIntern_preservesInferOnly (.mkApp proofArgs reflProof) ?_ + intro proof + refine bindIntern_preservesInferOnly (.mkConst p.decidableIsFalse #[]) ?_ + intro isFalse + refine bindIntern_preservesInferOnly (.mkApp isFalse prop) ?_ + intro result + exact intern_preservesInferOnly (.mkApp result proof) + +attribute [local irreducible] + buildNatDecidableTrue buildNatDecidableFalse + +private theorem finishNatDecidable_preservesInferOnly + {methods : Methods .anon} (p : Primitives .anon) + (prop : KExpr .anon) (args : Array (KExpr .anon)) + (bResult isDecEq : Bool) (proofTrueFn proofFalseFn : KId .anon) + (u1 : KUniv .anon) : + ((do + let resultExpr ← if bResult then do + buildNatDecidableTrue p prop args proofTrueFn u1 + else if isDecEq then do + buildNatDecidableFalse p prop args proofFalseFn u1 + else + return none + return some (← finishAppResult resultExpr args 2) : + RecM .anon (Option (KExpr .anon))).run methods).PreservesInferOnly := by + cases hb : bResult with + | true => + simp only [if_true] + refine bind_preservesInferOnly + (buildNatDecidableTrue_preservesInferOnly p prop args proofTrueFn u1) ?_ + intro resultExpr + refine bind_preservesInferOnly + (finishAppResult_preservesInferOnly resultExpr args 2) ?_ + intro finished + exact TcM.PreservesInferOnly.pure (some finished) + | false => + simp only [Bool.false_eq_true, if_false] + cases heq : isDecEq with + | true => + simp only [if_true] + refine bind_preservesInferOnly + (buildNatDecidableFalse_preservesInferOnly p prop args + proofFalseFn u1) ?_ + intro resultExpr + refine bind_preservesInferOnly + (finishAppResult_preservesInferOnly resultExpr args 2) ?_ + intro finished + exact TcM.PreservesInferOnly.pure (some finished) + | false => + simp only [Bool.false_eq_true, if_false] + exact TcM.PreservesInferOnly.pure none + +theorem tryReduceDecidable_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (source : KExpr .anon) : + ((tryReduceDecidable source).run methods).PreservesInferOnly := by + unfold tryReduceDecidable + refine bindTcM_preservesInferOnly TcM.PreservesInferOnly.get ?_ + intro state + cases hnoAccel : state.noAccel with + | true => + simp only [if_true] + exact TcM.PreservesInferOnly.pure none + | false => + simp only [Bool.false_eq_true, if_false, pure_bind] + rcases hspine : source.collectSpine with ⟨head, args⟩ + cases head with + | const id levels info => + simp only [] + refine bind_preservesInferOnly (prims_preservesInferOnly methods) ?_ + intro p + let isDecLe := id.addr == p.natDecLe.addr + let isDecEq := id.addr == p.natDecEq.addr + let isDecLt := id.addr == p.natDecLt.addr + cases hint : id.addr == p.intDecLe.addr || + id.addr == p.intDecEq.addr || id.addr == p.intDecLt.addr with + | true => + simp only [if_true] + refine bind_preservesInferOnly + (tryNormalizeIntDecidable_preservesInferOnly hmethods id.addr + args) ?_ + intro result + exact TcM.PreservesInferOnly.pure result + | false => + simp only [Bool.false_eq_true, if_false] + cases hknown : !isDecLe && !isDecEq && !isDecLt with + | true => + simp only [if_true] + exact TcM.PreservesInferOnly.pure none + | false => + simp only [Bool.false_eq_true, if_false] + by_cases hsmall : args.size < 2 + · simp only [hsmall, if_pos] + exact TcM.PreservesInferOnly.pure none + · simp only [hsmall, if_false] + focus + refine bind_preservesInferOnly + (whnfRec_preservesInferOnly hmethods args[0]!) ?_ + intro leftNormalized + refine bind_preservesInferOnly + (whnfRec_preservesInferOnly hmethods args[1]!) ?_ + intro rightNormalized + cases hleft : extractNatValue leftNormalized p with + | none => exact TcM.PreservesInferOnly.pure none + | some leftValue => + simp only [] + cases hright : extractNatValue rightNormalized p with + | none => exact TcM.PreservesInferOnly.pure none + | some rightValue => + simp only [] + cases hlt : id.addr == p.natDecLt.addr with + | true => + simp only [if_true] + refine bindIntern_preservesInferOnly + (natExprFromValue (leftValue + 1) : + KExpr .anon) ?_ + intro succLeft + refine bindIntern_preservesInferOnly + (.mkConst p.natDecLe #[]) ?_ + intro decLe + refine bindIntern_preservesInferOnly + (.mkApp decLe succLeft) ?_ + intro appliedLeft + refine bindIntern_preservesInferOnly + (.mkApp appliedLeft args[1]!) ?_ + intro result + refine bind_preservesInferOnly + (finishAppResult_preservesInferOnly result + args 2) ?_ + intro finished + exact TcM.PreservesInferOnly.pure + (some finished) + | false => + simp only [Bool.false_eq_true, if_false] + refine bind_preservesInferOnly + (tryInferDecidableProp_preservesInferOnly + hmethods source) ?_ + intro propResult + cases propResult with + | none => + exact TcM.PreservesInferOnly.pure none + | some prop => + simp only [] + let u1 : KUniv .anon := + .mkSucc .mkZero + cases hle : + id.addr == p.natDecLe.addr with + | true => + simp only [if_true] + exact + finishNatDecidable_preservesInferOnly + p prop args + (leftValue.ble rightValue) + isDecEq + p.natLeOfBleEqTrue + p.natNotLeOfNotBleEqTrue u1 + | false => + simp only [Bool.false_eq_true, + if_false] + exact + finishNatDecidable_preservesInferOnly + p prop args + (leftValue == rightValue) + isDecEq + p.natEqOfBeqEqTrue + p.natNeOfBeqEqFalse u1 + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + exact TcM.PreservesInferOnly.pure none + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/WhnfDriverPolicy.lean b/Ix/Tc/Verify/Check/WhnfDriverPolicy.lean new file mode 100644 index 000000000..a82b59ff0 --- /dev/null +++ b/Ix/Tc/Verify/Check/WhnfDriverPolicy.lean @@ -0,0 +1,550 @@ +import Ix.Tc.Verify.Check.ProjectionInferencePolicy + +/-! +# Operational inference-policy frame for WHNF drivers + +The recursive method knot needs an outcome-sensitive guarantee that WHNF +preserves the caller's `TcState.inferOnly` bit. This module proves the +production driver shells directly: bounded iteration, syntactic fast paths, +instrumentation, fuel charging, cache selection, hits, misses, and writes. + +The reducer internals remain explicit premises in +`WhnfReductionPolicyAt`. Later modules discharge those premises over the +individual structural, no-delta, and full-WHNF helper seams; this file ensures +that no additional policy obligation is hidden in the outer drivers. +-/ + +namespace Ix.Tc + +namespace RecM + + +theorem runBounded_preservesInferOnly + {methods : Methods .anon} + {step : sigma → RecM .anon (BoundedStep sigma alpha)} + (hstep : ∀ state, ((step state).run methods).PreservesInferOnly) : + ∀ fuel state, + ((runBounded step fuel state).run methods).PreservesInferOnly + | 0, state => by + exact TcM.PreservesInferOnly.throw _ + | fuel + 1, state => by + rw [runBounded, ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind (hstep state) + intro action + cases action with + | next state => exact runBounded_preservesInferOnly hstep fuel state + | done result => exact TcM.PreservesInferOnly.pure result + +/-- Operational contracts for the production seams inside the three WHNF +drivers. The outer bounded loops, cache routing, instrumentation, and leaf +dispatch are proved below rather than included as assumptions. -/ +structure WhnfNoDeltaPolicyAt (methods : Methods .anon) : Prop where + transient : ∀ source, + ((isTransientNatLiteralWork source).run methods).PreservesInferOnly + coreStep : ∀ source flags, + ((whnfCoreWithFlagsStep source flags).run methods).PreservesInferOnly + noDeltaReducers : ∀ flags mode source, + ((whnfNoDeltaReducersStep flags mode source).run methods).PreservesInferOnly +structure WhnfReductionPolicyAt (methods : Methods .anon) : Prop extends + WhnfNoDeltaPolicyAt methods where + fullStep : ∀ mode state, + ((whnfWithNatSuccModeStep mode state).run methods).PreservesInferOnly + +theorem whnfCoreWithFlagsUncached_preservesInferOnly + {methods : Methods .anon} (policy : WhnfNoDeltaPolicyAt methods) + (source : KExpr .anon) (flags : WhnfFlags) : + ((whnfCoreWithFlagsUncached source flags).run methods).PreservesInferOnly := by + unfold whnfCoreWithFlagsUncached + exact runBounded_preservesInferOnly + (fun current => policy.coreStep current flags) _ source + +private theorem whnfCoreFullCacheMiss_preservesInferOnly + {methods : Methods .anon} (policy : WhnfNoDeltaPolicyAt methods) + (source : KExpr .anon) (flags : WhnfFlags) + (key : Address × Address) : + ((do + let result ← whnfCoreWithFlagsUncached source flags + modify fun state : TcState .anon => { state with env := { state.env with + whnfCoreCache := state.env.whnfCoreCache.insert key result } } + pure result).run methods).PreservesInferOnly := by + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind + (whnfCoreWithFlagsUncached_preservesInferOnly policy source flags) + intro result + show ((do + modify fun state : TcState .anon => { state with env := { state.env with + whnfCoreCache := state.env.whnfCoreCache.insert key result } } + pure result : RecM .anon (KExpr .anon)).run methods).PreservesInferOnly + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.modify + (f := fun state : TcState .anon => { state with env := { state.env with + whnfCoreCache := state.env.whnfCoreCache.insert key result } }) + (fun _ => rfl)) + intro _ + exact TcM.PreservesInferOnly.pure result + +private theorem whnfCoreCheapCacheMiss_preservesInferOnly + {methods : Methods .anon} (policy : WhnfNoDeltaPolicyAt methods) + (source : KExpr .anon) (flags : WhnfFlags) + (key : Address × Address) : + ((do + let result ← whnfCoreWithFlagsUncached source flags + modify fun state : TcState .anon => { state with env := { state.env with + whnfCoreCheapCache := state.env.whnfCoreCheapCache.insert key result } } + pure result).run methods).PreservesInferOnly := by + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind + (whnfCoreWithFlagsUncached_preservesInferOnly policy source flags) + intro result + show ((do + modify fun state : TcState .anon => { state with env := { state.env with + whnfCoreCheapCache := state.env.whnfCoreCheapCache.insert key result } } + pure result : RecM .anon (KExpr .anon)).run methods).PreservesInferOnly + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.modify + (f := fun state : TcState .anon => { state with env := { state.env with + whnfCoreCheapCache := state.env.whnfCoreCheapCache.insert key result } }) + (fun _ => rfl)) + intro _ + exact TcM.PreservesInferOnly.pure result + +theorem whnfCoreWithFlagsNonLeaf_preservesInferOnly + {methods : Methods .anon} (policy : WhnfNoDeltaPolicyAt methods) + (source : KExpr .anon) (flags : WhnfFlags) : + ((whnfCoreWithFlagsNonLeaf source flags).run methods).PreservesInferOnly := by + unfold whnfCoreWithFlagsNonLeaf + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.PreservesInferOnly.bind (TcM.PreservesInferOnly.whnfKey source) + intro key + apply TcM.PreservesInferOnly.bind (policy.transient source) + intro transient + cases hfull : flags.isFull with + | false => + cases transient with + | true => + simp + exact whnfCoreWithFlagsUncached_preservesInferOnly policy source flags + | false => + simp + apply TcM.PreservesInferOnly.bind TcM.PreservesInferOnly.get + intro state + split + · exact TcM.PreservesInferOnly.pure _ + · exact whnfCoreCheapCacheMiss_preservesInferOnly policy source + flags key + | true => + cases transient with + | true => + simp + exact whnfCoreWithFlagsUncached_preservesInferOnly policy source flags + | false => + simp + apply TcM.PreservesInferOnly.bind TcM.PreservesInferOnly.get + intro state + split + · exact TcM.PreservesInferOnly.pure _ + · exact whnfCoreFullCacheMiss_preservesInferOnly policy source + flags key + +theorem whnfCoreWithFlags_preservesInferOnly + {methods : Methods .anon} (policy : WhnfNoDeltaPolicyAt methods) + (source : KExpr .anon) (flags : WhnfFlags) : + ((whnfCoreWithFlags source flags).run methods).PreservesInferOnly := by + cases source with + | var idx name info => + unfold whnfCoreWithFlags + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.isLetVar idx) + intro isLet + cases isLet with + | false => + simp only [Bool.not_false, if_true] + exact TcM.PreservesInferOnly.pure _ + | true => + simp only [Bool.not_true, pure_bind] + exact whnfCoreWithFlagsNonLeaf_preservesInferOnly policy _ flags + | fvar id name info => + simpa only [whnfCoreWithFlags, pure_bind] using + whnfCoreWithFlagsNonLeaf_preservesInferOnly policy _ flags + | app f a info => + simpa only [whnfCoreWithFlags, pure_bind] using + whnfCoreWithFlagsNonLeaf_preservesInferOnly policy _ flags + | letE name ty value body nondep info => + simpa only [whnfCoreWithFlags, pure_bind] using + whnfCoreWithFlagsNonLeaf_preservesInferOnly policy _ flags + | prj id field value info => + simpa only [whnfCoreWithFlags, pure_bind] using + whnfCoreWithFlagsNonLeaf_preservesInferOnly policy _ flags + | sort u info => exact TcM.PreservesInferOnly.pure _ + | const id levels info => exact TcM.PreservesInferOnly.pure _ + | lam name bi ty body info => exact TcM.PreservesInferOnly.pure _ + | all name bi ty body info => exact TcM.PreservesInferOnly.pure _ + | nat value blob info => exact TcM.PreservesInferOnly.pure _ + | str value blob info => exact TcM.PreservesInferOnly.pure _ + +theorem whnfCore_preservesInferOnly + {methods : Methods .anon} (policy : WhnfNoDeltaPolicyAt methods) + (source : KExpr .anon) : + ((whnfCore source).run methods).PreservesInferOnly := by + simpa only [whnfCore] using + whnfCoreWithFlags_preservesInferOnly policy source .FULL + +theorem whnfNoDeltaImplStep_preservesInferOnly + {methods : Methods .anon} (policy : WhnfNoDeltaPolicyAt methods) + (flags : WhnfFlags) (mode : NatSuccMode) (source : KExpr .anon) : + ((whnfNoDeltaImplStep flags mode source).run methods).PreservesInferOnly := by + unfold whnfNoDeltaImplStep + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind + (whnfCoreWithFlags_preservesInferOnly policy source flags) + intro reduced + exact policy.noDeltaReducers flags mode reduced + +theorem whnfNoDeltaImplUncached_preservesInferOnly + {methods : Methods .anon} (policy : WhnfNoDeltaPolicyAt methods) + (source : KExpr .anon) (flags : WhnfFlags) (mode : NatSuccMode) : + ((whnfNoDeltaImplUncached source flags mode).run methods).PreservesInferOnly := by + unfold whnfNoDeltaImplUncached + exact runBounded_preservesInferOnly + (fun current => whnfNoDeltaImplStep_preservesInferOnly policy flags mode + current) _ source + +private theorem whnfNoDeltaNoWriteMiss_preservesInferOnly + {methods : Methods .anon} (policy : WhnfNoDeltaPolicyAt methods) + (source : KExpr .anon) (flags : WhnfFlags) (mode : NatSuccMode) : + ((do + let result ← whnfNoDeltaImplUncached source flags mode + let _ ← (get : RecM .anon (TcState .anon)) + pure result).run methods).PreservesInferOnly := by + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind + (whnfNoDeltaImplUncached_preservesInferOnly policy source flags mode) + intro result + apply TcM.PreservesInferOnly.bind TcM.PreservesInferOnly.get + intro _ + exact TcM.PreservesInferOnly.pure result + +private theorem whnfNoDeltaFullWriteMiss_preservesInferOnly + {methods : Methods .anon} (policy : WhnfNoDeltaPolicyAt methods) + (source : KExpr .anon) (flags : WhnfFlags) (mode : NatSuccMode) + (key : Address × Address) : + ((do + let result ← whnfNoDeltaImplUncached source flags mode + let state ← (get : RecM .anon (TcState .anon)) + if state.inNativeReduce = false then + (fun _ => result) <$> modify fun current : TcState .anon => + { current with env := { current.env with + whnfNoDeltaCache := + current.env.whnfNoDeltaCache.insert key result } } + else + pure result).run methods).PreservesInferOnly := by + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind + (whnfNoDeltaImplUncached_preservesInferOnly policy source flags mode) + intro result + apply TcM.PreservesInferOnly.bind TcM.PreservesInferOnly.get + intro state + cases state.inNativeReduce with + | false => + simp + exact TcM.PreservesInferOnly.map + (TcM.PreservesInferOnly.modify + (f := fun state : TcState .anon => { state with env := { state.env with + whnfNoDeltaCache := + state.env.whnfNoDeltaCache.insert key result } }) + (fun _ => rfl)) + (fun _ => result) + | true => + simp + exact TcM.PreservesInferOnly.pure result + +private theorem whnfNoDeltaCheapWriteMiss_preservesInferOnly + {methods : Methods .anon} (policy : WhnfNoDeltaPolicyAt methods) + (source : KExpr .anon) (flags : WhnfFlags) (mode : NatSuccMode) + (key : Address × Address) : + ((do + let result ← whnfNoDeltaImplUncached source flags mode + let state ← (get : RecM .anon (TcState .anon)) + if state.inNativeReduce = false then + (fun _ => result) <$> modify fun current : TcState .anon => + { current with env := { current.env with + whnfNoDeltaCheapCache := + current.env.whnfNoDeltaCheapCache.insert key result } } + else + pure result).run methods).PreservesInferOnly := by + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind + (whnfNoDeltaImplUncached_preservesInferOnly policy source flags mode) + intro result + apply TcM.PreservesInferOnly.bind TcM.PreservesInferOnly.get + intro state + cases state.inNativeReduce with + | false => + simp + exact TcM.PreservesInferOnly.map + (TcM.PreservesInferOnly.modify + (f := fun state : TcState .anon => { state with env := { state.env with + whnfNoDeltaCheapCache := + state.env.whnfNoDeltaCheapCache.insert key result } }) + (fun _ => rfl)) + (fun _ => result) + | true => + simp + exact TcM.PreservesInferOnly.pure result + +theorem whnfNoDeltaImplNonLeaf_preservesInferOnly + {methods : Methods .anon} (policy : WhnfNoDeltaPolicyAt methods) + (source : KExpr .anon) (flags : WhnfFlags) (mode : NatSuccMode) : + ((whnfNoDeltaImplNonLeaf source flags mode).run methods).PreservesInferOnly := by + unfold whnfNoDeltaImplNonLeaf + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.PreservesInferOnly.bind (TcM.PreservesInferOnly.whnfKey source) + intro key + apply TcM.PreservesInferOnly.bind (policy.transient source) + intro transient + cases huse : (mode == .collapse) with + | false => + simp + exact whnfNoDeltaNoWriteMiss_preservesInferOnly policy source flags mode + | true => + cases transient with + | true => + simp + exact whnfNoDeltaNoWriteMiss_preservesInferOnly policy source flags mode + | false => + cases hfull : flags.isFull with + | false => + simp + apply TcM.PreservesInferOnly.bind TcM.PreservesInferOnly.get + intro state + split + · exact TcM.PreservesInferOnly.pure _ + · exact whnfNoDeltaCheapWriteMiss_preservesInferOnly policy + source flags mode key + | true => + simp + apply TcM.PreservesInferOnly.bind TcM.PreservesInferOnly.get + intro state + split + · exact TcM.PreservesInferOnly.pure _ + · exact whnfNoDeltaFullWriteMiss_preservesInferOnly policy + source flags mode key + +theorem whnfNoDeltaImpl_preservesInferOnly + {methods : Methods .anon} (policy : WhnfNoDeltaPolicyAt methods) + (source : KExpr .anon) (flags : WhnfFlags) (mode : NatSuccMode) : + ((whnfNoDeltaImpl source flags mode).run methods).PreservesInferOnly := by + cases source with + | var idx name info => + unfold whnfNoDeltaImpl + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.isLetVar idx) + intro isLet + cases isLet with + | false => + simp only [Bool.not_false, if_true] + exact TcM.PreservesInferOnly.pure _ + | true => + simp only [Bool.not_true, pure_bind] + exact whnfNoDeltaImplNonLeaf_preservesInferOnly policy _ flags mode + | fvar id name info => + simpa only [whnfNoDeltaImpl, pure_bind] using + whnfNoDeltaImplNonLeaf_preservesInferOnly policy _ flags mode + | const id levels info => + simpa only [whnfNoDeltaImpl, pure_bind] using + whnfNoDeltaImplNonLeaf_preservesInferOnly policy _ flags mode + | app f a info => + simpa only [whnfNoDeltaImpl, pure_bind] using + whnfNoDeltaImplNonLeaf_preservesInferOnly policy _ flags mode + | letE name ty value body nondep info => + simpa only [whnfNoDeltaImpl, pure_bind] using + whnfNoDeltaImplNonLeaf_preservesInferOnly policy _ flags mode + | prj id field value info => + simpa only [whnfNoDeltaImpl, pure_bind] using + whnfNoDeltaImplNonLeaf_preservesInferOnly policy _ flags mode + | sort u info => exact TcM.PreservesInferOnly.pure _ + | lam name bi ty body info => exact TcM.PreservesInferOnly.pure _ + | all name bi ty body info => exact TcM.PreservesInferOnly.pure _ + | nat value blob info => exact TcM.PreservesInferOnly.pure _ + | str value blob info => exact TcM.PreservesInferOnly.pure _ + +theorem whnfNoDelta_preservesInferOnly + {methods : Methods .anon} (policy : WhnfNoDeltaPolicyAt methods) + (source : KExpr .anon) : + ((whnfNoDelta source).run methods).PreservesInferOnly := by + simpa only [whnfNoDelta] using + whnfNoDeltaImpl_preservesInferOnly policy source .FULL .collapse + +theorem whnfWithNatSuccModeUncached_preservesInferOnly + {methods : Methods .anon} (policy : WhnfReductionPolicyAt methods) + (source : KExpr .anon) (mode : NatSuccMode) : + ((whnfWithNatSuccModeUncached source mode).run methods).PreservesInferOnly := by + unfold whnfWithNatSuccModeUncached + exact runBounded_preservesInferOnly + (fun state => policy.fullStep mode state) _ (source, {}) + +theorem whnfWithNatSuccModePrefix_preservesInferOnly + {methods : Methods .anon} (source : KExpr .anon) : + ((whnfWithNatSuccModePrefix source).run methods).PreservesInferOnly := by + unfold whnfWithNatSuccModePrefix + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.stepTrace "whnf+" fun _ => TcM.addr8 source.addr) + intro _ + exact TcM.PreservesInferOnly.bumpStats + (fun state : TcState .anon => { state with + whnfCalls := state.whnfCalls + 1 }) + (fun _ => rfl) + +theorem whnfWithNatSuccModeMissCharge_preservesInferOnly + {methods : Methods .anon} : + ((whnfWithNatSuccModeMissCharge (m := .anon)).run methods).PreservesInferOnly := by + unfold whnfWithNatSuccModeMissCharge + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.bumpStats + (fun state : TcState .anon => { state with + whnfMisses := state.whnfMisses + 1 }) + (fun _ => rfl)) + intro _ + exact TcM.PreservesInferOnly.tick + +private theorem whnfNoWriteMiss_preservesInferOnly + {methods : Methods .anon} (policy : WhnfReductionPolicyAt methods) + (source : KExpr .anon) (mode : NatSuccMode) : + ((do + let result ← whnfWithNatSuccModeUncached source mode + let _ ← (get : RecM .anon (TcState .anon)) + pure result).run methods).PreservesInferOnly := by + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind + (whnfWithNatSuccModeUncached_preservesInferOnly policy source mode) + intro result + apply TcM.PreservesInferOnly.bind TcM.PreservesInferOnly.get + intro _ + exact TcM.PreservesInferOnly.pure result + +private theorem whnfWriteMiss_preservesInferOnly + {methods : Methods .anon} (policy : WhnfReductionPolicyAt methods) + (source : KExpr .anon) (mode : NatSuccMode) + (key : Address × Address) : + ((do + let result ← whnfWithNatSuccModeUncached source mode + let state ← (get : RecM .anon (TcState .anon)) + if state.inNativeReduce = false then + (fun _ => result) <$> modify fun current : TcState .anon => + { current with env := { current.env with + whnfCache := current.env.whnfCache.insert key result } } + else + pure result).run methods).PreservesInferOnly := by + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind + (whnfWithNatSuccModeUncached_preservesInferOnly policy source mode) + intro result + apply TcM.PreservesInferOnly.bind TcM.PreservesInferOnly.get + intro state + cases state.inNativeReduce with + | false => + simp + exact TcM.PreservesInferOnly.map + (TcM.PreservesInferOnly.modify + (f := fun state : TcState .anon => { state with env := { state.env with + whnfCache := state.env.whnfCache.insert key result } }) + (fun _ => rfl)) + (fun _ => result) + | true => + simp + exact TcM.PreservesInferOnly.pure result + +theorem whnfWithNatSuccModeNonLeaf_preservesInferOnly + {methods : Methods .anon} (policy : WhnfReductionPolicyAt methods) + (source : KExpr .anon) (mode : NatSuccMode) : + ((whnfWithNatSuccModeNonLeaf source mode).run methods).PreservesInferOnly := by + unfold whnfWithNatSuccModeNonLeaf + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.PreservesInferOnly.bind + (whnfWithNatSuccModePrefix_preservesInferOnly source) + intro _ + apply TcM.PreservesInferOnly.bind (TcM.PreservesInferOnly.whnfKey source) + intro key + apply TcM.PreservesInferOnly.bind (policy.transient source) + intro transient + cases huse : (mode == .collapse) with + | false => + simp + apply TcM.PreservesInferOnly.bind + whnfWithNatSuccModeMissCharge_preservesInferOnly + intro _ + exact whnfNoWriteMiss_preservesInferOnly policy source mode + | true => + cases transient with + | true => + simp + apply TcM.PreservesInferOnly.bind + whnfWithNatSuccModeMissCharge_preservesInferOnly + intro _ + exact whnfNoWriteMiss_preservesInferOnly policy source mode + | false => + simp + apply TcM.PreservesInferOnly.bind TcM.PreservesInferOnly.get + intro state + split + · exact TcM.PreservesInferOnly.pure _ + · apply TcM.PreservesInferOnly.bind + whnfWithNatSuccModeMissCharge_preservesInferOnly + intro _ + exact whnfWriteMiss_preservesInferOnly policy source mode key + +theorem whnfWithNatSuccMode_preservesInferOnly + {methods : Methods .anon} (policy : WhnfReductionPolicyAt methods) + (source : KExpr .anon) (mode : NatSuccMode) : + ((whnfWithNatSuccMode source mode).run methods).PreservesInferOnly := by + cases source with + | var idx name info => + unfold whnfWithNatSuccMode + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.isLetVar idx) + intro isLet + cases isLet with + | false => + simp only [Bool.not_false, if_true] + exact TcM.PreservesInferOnly.pure _ + | true => + simp only [Bool.not_true, pure_bind] + exact whnfWithNatSuccModeNonLeaf_preservesInferOnly policy _ mode + | fvar id name info => + simpa only [whnfWithNatSuccMode, pure_bind] using + whnfWithNatSuccModeNonLeaf_preservesInferOnly policy _ mode + | const id levels info => + simpa only [whnfWithNatSuccMode, pure_bind] using + whnfWithNatSuccModeNonLeaf_preservesInferOnly policy _ mode + | app f a info => + simpa only [whnfWithNatSuccMode, pure_bind] using + whnfWithNatSuccModeNonLeaf_preservesInferOnly policy _ mode + | letE name ty value body nondep info => + simpa only [whnfWithNatSuccMode, pure_bind] using + whnfWithNatSuccModeNonLeaf_preservesInferOnly policy _ mode + | prj id field value info => + simpa only [whnfWithNatSuccMode, pure_bind] using + whnfWithNatSuccModeNonLeaf_preservesInferOnly policy _ mode + | sort u info => exact TcM.PreservesInferOnly.pure _ + | lam name bi ty body info => exact TcM.PreservesInferOnly.pure _ + | all name bi ty body info => exact TcM.PreservesInferOnly.pure _ + | nat value blob info => exact TcM.PreservesInferOnly.pure _ + | str value blob info => exact TcM.PreservesInferOnly.pure _ + +theorem whnf_preservesInferOnly + {methods : Methods .anon} (policy : WhnfReductionPolicyAt methods) + (source : KExpr .anon) : + ((whnf source).run methods).PreservesInferOnly := by + simpa only [whnf] using + whnfWithNatSuccMode_preservesInferOnly policy source .collapse + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/WhnfHelperPolicy.lean b/Ix/Tc/Verify/Check/WhnfHelperPolicy.lean new file mode 100644 index 000000000..28c3653c2 --- /dev/null +++ b/Ix/Tc/Verify/Check/WhnfHelperPolicy.lean @@ -0,0 +1,44 @@ +import Ix.Tc.Verify.Check.WhnfIotaDispatchPolicy + +/-! +# Concrete operational policy for every WHNF helper + +This module closes `WhnfHelperPolicyAt` over the production helper graph. +The assembled contract contains no abstract helper premise: projection, +application rebuilding, iota, primitive accelerators, Nat-offset handling, +quotient reduction, and delta unfolding are all tied to their concrete +implementations under one fixed predecessor method table. +-/ + +namespace Ix.Tc + +namespace RecM + +/-- Every helper called by the structural, no-delta, and full-WHNF reducer +steps restores the caller's inference policy on both success and error. -/ +def concreteWhnfHelperPolicy + (methods : Methods .anon) (hmethods : methods.PreservesInferOnly) : + WhnfHelperPolicyAt methods where + proj := tryProjReduce_preservesInferOnly hmethods + finishApp := finishAppResult_preservesInferOnly + iota := tryIotaWithFlags_preservesInferOnly hmethods + bitvec := tryReduceBitvec_preservesInferOnly hmethods + nat := tryReduceNatWithSuccMode_preservesInferOnly hmethods + native := tryReduceNative_preservesInferOnly hmethods + string := tryReduceString_preservesInferOnly + projectionDefinition := tryReduceProjectionDefinition_preservesInferOnly + quot := tryQuotReduce_preservesInferOnly hmethods + decidable := tryReduceDecidable_preservesInferOnly hmethods + natOffset := tryNatOffsetStuck_preservesInferOnly hmethods + delta := deltaUnfoldOne_preservesInferOnly + +/-- The complete concrete helper graph induces the reducer-step policy used +by all four public WHNF driver variants. -/ +def concreteWhnfReductionPolicy + (methods : Methods .anon) (hmethods : methods.PreservesInferOnly) : + WhnfReductionPolicyAt methods := + (concreteWhnfHelperPolicy methods hmethods).reductionPolicy hmethods + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/WhnfIotaBasePolicy.lean b/Ix/Tc/Verify/Check/WhnfIotaBasePolicy.lean new file mode 100644 index 000000000..fd8fcc729 --- /dev/null +++ b/Ix/Tc/Verify/Check/WhnfIotaBasePolicy.lean @@ -0,0 +1,286 @@ +import Ix.Tc.Verify.Check.WhnfDecidablePolicy + +/-! +# Operational inference-policy frame for iota rule execution + +This module verifies ordinary and transient iota argument application, +constructor-rule selection, and the bounded Nat-offset parser used to expose +constructor layers before iota dispatch. The mutually recursive offset +workers are proved together over their shared fuel, so their production +fallback behavior remains explicit. +-/ + +namespace Ix.Tc + +namespace RecM + +private theorem prims_preservesInferOnly (methods : Methods .anon) : + ((prims : RecM .anon (Primitives .anon)).run methods).PreservesInferOnly := by + unfold prims + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind TcM.PreservesInferOnly.get + intro state + exact TcM.PreservesInferOnly.pure state.prims + +theorem applyIotaArg_preservesInferOnly + {methods : Methods .anon} (result arg : KExpr .anon) + (transient : Bool) : + ((applyIotaArg result arg transient).run methods).PreservesInferOnly := by + unfold applyIotaArg + cases transient with + | false => + simp only [Bool.false_eq_true, if_false] + exact intern_preservesInferOnly (.mkApp result arg) + | true => + simp only [if_true] + split <;> exact TcM.PreservesInferOnly.pure _ + +theorem applyIotaArgs_preservesInferOnly + {methods : Methods .anon} (result : KExpr .anon) + (args : Array (KExpr .anon)) (transient : Bool) : + ((applyIotaArgs result args transient).run methods).PreservesInferOnly := by + rw [applyIotaArgs_eq_foldlM, ← Array.foldlM_toList] + generalize hitems : args.toList = items + clear hitems + induction items generalizing result with + | nil => exact TcM.PreservesInferOnly.pure result + | cons arg rest ih => + rw [List.foldlM_cons, ReaderT.run_bind] + exact TcM.PreservesInferOnly.bind + (applyIotaArg_preservesInferOnly result arg transient) + (fun next => ih next) + +theorem applyIotaRule_preservesInferOnly + {methods : Methods .anon} (rule : RecRule .anon) + (recUs : Array (KUniv .anon)) (recr : IotaInfo .anon) + (spine ctorArgs : Array (KExpr .anon)) (ctorFields : Nat) + (transient : Bool) : + ((applyIotaRule rule recUs recr spine ctorArgs ctorFields transient).run + methods).PreservesInferOnly := by + unfold applyIotaRule + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.instantiateUnivParams rule.rhs recUs) ?_ + intro rhs + refine bind_preservesInferOnly + (applyIotaArgs_preservesInferOnly rhs (iotaPrefixArgs recr spine) + transient) ?_ + intro prefixResult + refine bind_preservesInferOnly + (applyIotaArgs_preservesInferOnly prefixResult + (iotaFieldArgs ctorArgs ctorFields) transient) ?_ + intro fieldResult + exact applyIotaArgs_preservesInferOnly fieldResult + (iotaTrailingArgs recr spine) transient + +theorem tryApplyIotaCtor_preservesInferOnly + {methods : Methods .anon} (recr : IotaInfo .anon) + (recUs : Array (KUniv .anon)) (spine ctorArgs : Array (KExpr .anon)) + (cidx ctorFields : Nat) (transient : Bool) : + ((tryApplyIotaCtor recr recUs spine ctorArgs cidx ctorFields transient).run + methods).PreservesInferOnly := by + unfold tryApplyIotaCtor + cases hrule : recr.rules[cidx]? with + | none => exact TcM.PreservesInferOnly.pure none + | some rule => + simp only [] + by_cases hlevels : recUs.size.toUInt64 != recr.lvls + · simp only [hlevels, if_pos] + exact TcM.PreservesInferOnly.pure none + · simp only [hlevels] + by_cases hfields : ctorFields > ctorArgs.size + · simp only [hfields, if_pos] + exact TcM.PreservesInferOnly.pure none + · simp only [hfields, if_false] + simpa only [pure_bind] using + (bind_preservesInferOnly + (methods := methods) + (next := fun result => pure (some result)) + (applyIotaRule_preservesInferOnly rule recUs recr spine ctorArgs + ctorFields transient) + (fun result => by + simpa only [ReaderT.run_pure] using + (TcM.PreservesInferOnly.pure (some result)))) + +mutual + +theorem natOffsetFuel_preservesInferOnly + {methods : Methods .anon} : ∀ fuel source, + ((natOffsetFuel fuel source).run methods).PreservesInferOnly + | 0, source => by + rw [natOffsetFuel] + exact TcM.PreservesInferOnly.pure none + | fuel + 1, source => by + rw [natOffsetFuel] + rcases hspine : source.collectSpine with ⟨head, args⟩ + cases head with + | const id levels info => + refine bind_preservesInferOnly (prims_preservesInferOnly methods) ?_ + intro p + cases hsucc : id.addr == p.natSucc.addr && args.size == 1 with + | true => + simp only [if_true] + let arg := args[0]! + refine bind_preservesInferOnly + (natOffsetFuel_preservesInferOnly fuel arg) ?_ + intro result + exact TcM.PreservesInferOnly.pure + (some ((result.getD (arg, 0)).1, + (result.getD (arg, 0)).2 + 1)) + | false => + simp only [Bool.false_eq_true, if_false, pure_bind] + cases hadd : id.addr == p.natAdd.addr && args.size == 2 with + | false => + simp only [Bool.false_eq_true, if_false] + exact TcM.PreservesInferOnly.pure none + | true => + simp only [if_true] + refine bind_preservesInferOnly + (evalNatOffsetLiteralFuel_preservesInferOnly fuel args[1]!) ?_ + intro rhsResult + cases rhsResult with + | none => exact TcM.PreservesInferOnly.pure none + | some rhs => + simp only [] + let arg := args[0]! + refine bind_preservesInferOnly + (natOffsetFuel_preservesInferOnly fuel arg) ?_ + intro result + exact TcM.PreservesInferOnly.pure + (some ((result.getD (arg, 0)).1, + (result.getD (arg, 0)).2 + rhs)) + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + exact TcM.PreservesInferOnly.pure none + +theorem evalNatOffsetLiteralFuel_preservesInferOnly + {methods : Methods .anon} : ∀ fuel source, + ((evalNatOffsetLiteralFuel fuel source).run methods).PreservesInferOnly + | 0, source => by + rw [evalNatOffsetLiteralFuel] + exact TcM.PreservesInferOnly.pure none + | fuel + 1, source => by + rw [evalNatOffsetLiteralFuel] + refine bind_preservesInferOnly (prims_preservesInferOnly methods) ?_ + intro p + cases hliteral : extractNatValue source p with + | some value => + simp only [] + exact TcM.PreservesInferOnly.pure (some value) + | none => + simp only [pure_bind] + rcases hspine : source.collectSpine with ⟨head, args⟩ + cases head with + | const id levels info => + cases hpred : id.addr == p.natPred.addr && args.size == 1 with + | true => + simp only [hpred, if_true] + refine bind_preservesInferOnly + (evalNatOffsetLiteralFuel_preservesInferOnly fuel args[0]!) ?_ + intro result + cases result with + | none => exact TcM.PreservesInferOnly.pure none + | some value => + exact TcM.PreservesInferOnly.pure (some (value - 1)) + | false => + simp only [hpred, Bool.false_eq_true, if_false] + refine bind_preservesInferOnly + (isNatBinArithAddr_preservesInferOnly id.addr) ?_ + intro isArith + cases hbin : isArith && args.size == 2 with + | false => + simp only [Bool.false_eq_true, if_false] + exact TcM.PreservesInferOnly.pure none + | true => + simp only [if_true] + refine bind_preservesInferOnly + (evalNatOffsetLiteralFuel_preservesInferOnly fuel + args[0]!) ?_ + intro leftResult + cases leftResult with + | none => exact TcM.PreservesInferOnly.pure none + | some left => + simp only [] + refine bind_preservesInferOnly + (evalNatOffsetLiteralFuel_preservesInferOnly fuel + args[1]!) ?_ + intro rightResult + cases rightResult with + | none => exact TcM.PreservesInferOnly.pure none + | some right => + exact TcM.PreservesInferOnly.pure + (computeNatBin id.addr PrimAddrs.canonical + left right) + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + exact TcM.PreservesInferOnly.pure none + +end + +theorem natOffset_preservesInferOnly + {methods : Methods .anon} (source : KExpr .anon) (depth : Nat) : + ((natOffset source depth).run methods).PreservesInferOnly := by + unfold natOffset + exact natOffsetFuel_preservesInferOnly _ source + +theorem natOffsetOrZero_preservesInferOnly + {methods : Methods .anon} (source : KExpr .anon) (depth : Nat) : + ((natOffsetOrZero source depth).run methods).PreservesInferOnly := by + unfold natOffsetOrZero + refine bind_preservesInferOnly + (natOffset_preservesInferOnly source depth) ?_ + intro result + exact TcM.PreservesInferOnly.pure (result.getD (source, 0)) + +theorem evalNatOffsetLiteral_preservesInferOnly + {methods : Methods .anon} (source : KExpr .anon) (depth : Nat) : + ((evalNatOffsetLiteral source depth).run methods).PreservesInferOnly := by + unfold evalNatOffsetLiteral + exact evalNatOffsetLiteralFuel_preservesInferOnly _ source + +theorem cleanupNatOffsetMajor_preservesInferOnly + {methods : Methods .anon} (source : KExpr .anon) : + ((cleanupNatOffsetMajor source).run methods).PreservesInferOnly := by + unfold cleanupNatOffsetMajor + refine bind_preservesInferOnly + (evalNatOffsetLiteral_preservesInferOnly source 0) ?_ + intro literalResult + cases literalResult with + | some value => + simp only [Option.isSome, if_true] + exact TcM.PreservesInferOnly.pure none + | none => + simp only [Option.isSome, Bool.false_eq_true, if_false, pure_bind] + refine bind_preservesInferOnly + (natOffset_preservesInferOnly source 0) ?_ + intro offsetResult + cases offsetResult with + | none => exact TcM.PreservesInferOnly.pure none + | some baseOffset => + simp only [] + rcases baseOffset with ⟨base, offset⟩ + cases hzero : offset == 0 with + | true => + simp only [if_true] + exact TcM.PreservesInferOnly.pure none + | false => + simp only [Bool.false_eq_true, if_false] + let predOffset := offset - 1 + cases hpredZero : predOffset == 0 with + | true => + simp only [if_true] + refine bind_preservesInferOnly + (mkNatSucc_preservesInferOnly base) ?_ + intro result + exact TcM.PreservesInferOnly.pure (some result) + | false => + simp only [Bool.false_eq_true, if_false] + refine bind_preservesInferOnly + (mkNatAdd_preservesInferOnly base + (natExprFromValue predOffset)) ?_ + intro pred + refine bind_preservesInferOnly + (mkNatSucc_preservesInferOnly pred) ?_ + intro result + exact TcM.PreservesInferOnly.pure (some result) + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/WhnfIotaDispatchPolicy.lean b/Ix/Tc/Verify/Check/WhnfIotaDispatchPolicy.lean new file mode 100644 index 000000000..bca0daf70 --- /dev/null +++ b/Ix/Tc/Verify/Check/WhnfIotaDispatchPolicy.lean @@ -0,0 +1,238 @@ +import Ix.Tc.Verify.Check.WhnfIotaSynthesisPolicy + +/-! +# Operational inference-policy frame for complete iota dispatch + +This module assembles ordinary constructor iota, struct eta, K synthesis, +Nat-offset cleanup, Nat and String literal expansion, and policy-selected +major normalization. Its public theorem covers every branch of production +`tryIotaWithFlags`, completing the concrete iota helper obligation used by +the WHNF reducer frame. +-/ + +namespace Ix.Tc +namespace RecM + + +private theorem prims_preservesInferOnly (methods : Methods .anon) : + ((prims : RecM .anon (Primitives .anon)).run methods).PreservesInferOnly := by + unfold prims + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind TcM.PreservesInferOnly.get + intro state + exact TcM.PreservesInferOnly.pure state.prims + +theorem natToConstructor_preservesInferOnly + {methods : Methods .anon} (value : Nat) : + ((natToConstructor value).run methods).PreservesInferOnly := by + unfold natToConstructor + refine bind_preservesInferOnly (prims_preservesInferOnly methods) ?_ + intro p + split <;> exact TcM.PreservesInferOnly.pure _ + +theorem tryIotaCtorOrStructEta_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (recId : KId .anon) (recr : IotaInfo .anon) + (recUs : Array (KUniv .anon)) (spine : Array (KExpr .anon)) + (majorWhnf : KExpr .anon) (transient : Bool) : + ((tryIotaCtorOrStructEta recId recr recUs spine majorWhnf transient).run + methods).PreservesInferOnly := by + unfold tryIotaCtorOrStructEta + rcases hspine : majorWhnf.collectSpine with ⟨ctorHead, ctorArgs⟩ + cases ctorHead with + | const ctorId ctorUs ctorInfo => + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.tryGetConst ctorId) ?_ + intro declaration + cases declaration with + | none => + simp only [pure_bind] + exact tryStructEtaIota_preservesInferOnly hmethods recId recr recUs + spine + | some declaration => + cases declaration with + | ctor name levelParams isUnsafe lvls induct cidx params fields ty => + simp only [KConst.iotaCtorInfo?, pure_bind] + simpa only [ReaderT.run_bind, ReaderT.run_pure, bind_pure] using + (tryApplyIotaCtor_preservesInferOnly recr recUs spine + ctorArgs cidx.toNat fields.toNat transient) + | axio | defn | quot | indc | recr => + simp only [KConst.iotaCtorInfo?, pure_bind] + exact tryStructEtaIota_preservesInferOnly hmethods recId recr + recUs spine + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + simp only [pure_bind] + exact tryStructEtaIota_preservesInferOnly hmethods recId recr recUs spine + +attribute [local irreducible] tryIotaCtorOrStructEta + strLitToConstructor + +theorem tryIotaAfterCleanup_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (flags : WhnfFlags) (recId : KId .anon) (recr : IotaInfo .anon) + (recUs : Array (KUniv .anon)) (spine : Array (KExpr .anon)) + (majorWhnf : KExpr .anon) (majorWasNatLit : Bool) : + ((tryIotaAfterCleanup flags recId recr recUs spine majorWhnf + majorWasNatLit).run methods).PreservesInferOnly := by + unfold tryIotaAfterCleanup + cases majorWhnf with + | str value blob info => + refine bind_preservesInferOnly + (strLitToConstructor_preservesInferOnly value) ?_ + intro strCtor + cases hcheap : flags.cheapRec with + | true => + simp only [if_true] + refine bind_preservesInferOnly + (whnfCoreFlagsRec_preservesInferOnly hmethods strCtor flags) ?_ + intro normalized + exact tryIotaCtorOrStructEta_preservesInferOnly hmethods recId recr + recUs spine normalized majorWasNatLit + | false => + simp only [Bool.false_eq_true, if_false] + refine bind_preservesInferOnly + (whnfRec_preservesInferOnly hmethods strCtor) ?_ + intro normalized + exact tryIotaCtorOrStructEta_preservesInferOnly hmethods recId recr + recUs spine normalized majorWasNatLit + | var | fvar | sort | const | app | lam | all | letE | prj | nat => + simp only [pure_bind] + exact tryIotaCtorOrStructEta_preservesInferOnly hmethods recId recr recUs + spine _ majorWasNatLit + +attribute [local irreducible] tryIotaAfterCleanup + +theorem tryIotaAfterMajorWhnf_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (flags : WhnfFlags) (recId : KId .anon) (recr : IotaInfo .anon) + (recUs : Array (KUniv .anon)) (spine : Array (KExpr .anon)) + (majorWhnf0 : KExpr .anon) : + ((tryIotaAfterMajorWhnf flags recId recr recUs spine majorWhnf0).run + methods).PreservesInferOnly := by + unfold tryIotaAfterMajorWhnf + cases majorWhnf0 with + | nat value blob info => + refine bind_preservesInferOnly + (natToConstructor_preservesInferOnly value) ?_ + intro majorWhnf + simp only [pure_bind] + refine bind_preservesInferOnly + (cleanupNatOffsetMajor_preservesInferOnly majorWhnf) ?_ + intro cleaned + cases cleaned with + | none => + exact tryIotaAfterCleanup_preservesInferOnly hmethods flags recId + recr recUs spine majorWhnf true + | some cleaned => + exact tryIotaAfterCleanup_preservesInferOnly hmethods flags recId + recr recUs spine cleaned true + | var | fvar | sort | const | app | lam | all | letE | prj | str => + simp only [pure_bind] + refine bind_preservesInferOnly + (cleanupNatOffsetMajor_preservesInferOnly _) ?_ + intro cleaned + cases cleaned with + | none => + exact tryIotaAfterCleanup_preservesInferOnly hmethods flags recId + recr recUs spine _ false + | some cleaned => + exact tryIotaAfterCleanup_preservesInferOnly hmethods flags recId + recr recUs spine cleaned false + +attribute [local irreducible] tryIotaAfterMajorWhnf synthCtorWhenK + +private theorem tryIotaMajor_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (flags : WhnfFlags) (recId : KId .anon) (recr : IotaInfo .anon) + (recUs : Array (KUniv .anon)) (spine : Array (KExpr .anon)) + (major : KExpr .anon) : + ((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 : + RecM .anon (Option (KExpr .anon))).run methods).PreservesInferOnly := by + refine bind_preservesInferOnly + (cleanupNatOffsetMajor_preservesInferOnly major) ?_ + intro cleaned + let normalizedMajor := cleaned.getD major + cases hcheap : flags.cheapRec with + | true => + simp only [if_true] + refine bind_preservesInferOnly + (whnfCoreFlagsRec_preservesInferOnly hmethods normalizedMajor flags) ?_ + intro majorWhnf0 + exact tryIotaAfterMajorWhnf_preservesInferOnly hmethods flags recId recr + recUs spine majorWhnf0 + | false => + simp only [Bool.false_eq_true, if_false] + refine bind_preservesInferOnly + (whnfRec_preservesInferOnly hmethods normalizedMajor) ?_ + intro majorWhnf0 + exact tryIotaAfterMajorWhnf_preservesInferOnly hmethods flags recId recr + recUs spine majorWhnf0 + +private theorem tryIotaSelected_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (flags : WhnfFlags) (recId : KId .anon) (recr : IotaInfo .anon) + (recUs : Array (KUniv .anon)) (spine : Array (KExpr .anon)) : + ((do + if spine.size ≤ recr.majorIdx then + return none + let major := spine[recr.majorIdx]! + let major ← if recr.k then + pure ((← synthCtorWhenK major recId recr recUs).getD major) + else pure major + 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 : + RecM .anon (Option (KExpr .anon))).run methods).PreservesInferOnly := by + by_cases hmajor : spine.size ≤ recr.majorIdx + · simp only [hmajor, if_pos] + exact TcM.PreservesInferOnly.pure none + · simp only [hmajor, if_false, pure_bind] + let major := spine[recr.majorIdx]! + cases hk : recr.k with + | false => + simp only [Bool.false_eq_true, if_false] + exact tryIotaMajor_preservesInferOnly hmethods flags recId recr recUs + spine major + | true => + simp only [if_true] + refine bind_preservesInferOnly + (synthCtorWhenK_preservesInferOnly hmethods major recId recr recUs) ?_ + intro synthesized + exact tryIotaMajor_preservesInferOnly hmethods flags recId recr recUs + spine (synthesized.getD major) + +theorem tryIotaWithFlags_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (source : KExpr .anon) (flags : WhnfFlags) : + ((tryIotaWithFlags source flags).run methods).PreservesInferOnly := by + unfold tryIotaWithFlags + rcases hspine : source.collectSpine with ⟨head, spine⟩ + cases head with + | const recId recUs info => + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.tryGetConst recId) ?_ + intro declaration + cases declaration with + | none => exact TcM.PreservesInferOnly.pure none + | some declaration => + simp only [] + cases hinfo : declaration.iotaInfo? with + | none => + simp only [] + exact TcM.PreservesInferOnly.pure none + | some recr => + simp only [] + exact tryIotaSelected_preservesInferOnly hmethods flags recId + recr recUs spine + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + exact TcM.PreservesInferOnly.pure none + +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/WhnfIotaRecursionPolicy.lean b/Ix/Tc/Verify/Check/WhnfIotaRecursionPolicy.lean new file mode 100644 index 000000000..d450c8f8a --- /dev/null +++ b/Ix/Tc/Verify/Check/WhnfIotaRecursionPolicy.lean @@ -0,0 +1,312 @@ +import Ix.Tc.Verify.Check.WhnfIotaScopePolicy + +/-! +# Operational inference-policy frame for iota recursion classification + +This module verifies mutual-block discovery and the complete constructive +`computedIsRec` transaction used by struct eta. It covers parameter peeling, +bounded field scanning, legacy-context restoration, provisional and final +cache writes, and cleanup of the provisional entry on classifier errors. +-/ + +namespace Ix.Tc + +namespace RecM + + +private theorem forInList_preservesInferOnly + {methods : Methods .anon} + {step : alpha → beta → RecM .anon (ForInStep beta)} + (hstep : ∀ item state, + ((step item state).run methods).PreservesInferOnly) : + ∀ (items : List alpha) (initial : beta), + ((forIn (m := RecM .anon) items initial step).run + methods).PreservesInferOnly + | [], initial => TcM.PreservesInferOnly.pure initial + | item :: rest, initial => by + rw [List.forIn_cons, ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind (hstep item initial) + intro action + cases action with + | done result => exact TcM.PreservesInferOnly.pure result + | yield next => exact forInList_preservesInferOnly hstep rest next + +private theorem forInArray_preservesInferOnly + {methods : Methods .anon} + {step : alpha → beta → RecM .anon (ForInStep beta)} + (hstep : ∀ item state, + ((step item state).run methods).PreservesInferOnly) + (items : Array alpha) (initial : beta) : + ((forIn (m := RecM .anon) items initial step).run + methods).PreservesInferOnly := by + rcases items with ⟨items⟩ + simp only [List.forIn_toArray] + exact forInList_preservesInferOnly hstep items initial + +private theorem forInRange_preservesInferOnly + {methods : Methods .anon} + {step : Nat → beta → RecM .anon (ForInStep beta)} + (hstep : ∀ item state, + ((step item state).run methods).PreservesInferOnly) + (range : _root_.Std.Legacy.Range) (initial : beta) : + ((forIn (m := RecM .anon) range initial step).run + methods).PreservesInferOnly := by + rw [_root_.Std.Legacy.Range.forIn_eq_forIn_range'] + exact forInList_preservesInferOnly hstep _ initial + +theorem discoverBlockInductives_preservesInferOnly + {methods : Methods .anon} (blockId : KId .anon) : + ((discoverBlockInductives blockId).run methods).PreservesInferOnly := by + unfold discoverBlockInductives + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.tryGetBlock blockId) ?_ + intro found + cases found with + | none => exact TcM.PreservesInferOnly.pure #[] + | some members => + simp only [] + refine bind_preservesInferOnly + (forInArray_preservesInferOnly (methods := methods) + (items := members) (initial := #[]) ?_) ?_ + · intro id inds + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.tryGetConst id) ?_ + intro declaration + cases declaration with + | none => + exact TcM.PreservesInferOnly.pure (ForInStep.yield inds) + | some declaration => + cases declaration with + | indc => + exact TcM.PreservesInferOnly.pure + (ForInStep.yield (inds.push id)) + | axio | defn | quot | ctor | recr => + simp only [pure_bind] + exact TcM.PreservesInferOnly.pure (ForInStep.yield inds) + · intro result + exact TcM.PreservesInferOnly.pure result + +theorem computeIsRecParamStepAfterWhnf_preservesInferOnly + {methods : Methods .anon} (source normalized : KExpr .anon) : + ((computeIsRecParamStepAfterWhnf source normalized).run + methods).PreservesInferOnly := by + unfold computeIsRecParamStepAfterWhnf + cases normalized with + | all name bi domain body info => + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.pushLocal domain) ?_ + intro _ + exact TcM.PreservesInferOnly.pure (ForInStep.yield body) + | var | fvar | sort | const | app | lam | letE | prj | nat | str => + exact TcM.PreservesInferOnly.pure (ForInStep.done source) + +theorem computeIsRecParamStep_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (source : KExpr .anon) : + ((computeIsRecParamStep source).run methods).PreservesInferOnly := by + unfold computeIsRecParamStep + refine bind_preservesInferOnly + (whnfRec_preservesInferOnly hmethods source) ?_ + intro normalized + exact computeIsRecParamStepAfterWhnf_preservesInferOnly source normalized + +theorem computeIsRecFieldStepAfterWhnf_preservesInferOnly + {methods : Methods .anon} (blockAddrs : Array Address) + (normalized : KExpr .anon) : + ((computeIsRecFieldStepAfterWhnf blockAddrs normalized).run + methods).PreservesInferOnly := by + unfold computeIsRecFieldStepAfterWhnf + cases normalized with + | all name bi domain body info => + by_cases hmentions : exprMentionsAnyAddr domain blockAddrs + · simp only [hmentions, if_pos] + exact TcM.PreservesInferOnly.pure (BoundedStep.done true) + · simp only [hmentions] + simpa only [pure_bind] using + (bindTcM_preservesInferOnly + (methods := methods) + (next := fun _ => pure (BoundedStep.next body)) + (TcM.PreservesInferOnly.pushLocal domain) + (fun _ => by + simpa only [ReaderT.run_pure] using + (TcM.PreservesInferOnly.pure (BoundedStep.next body)))) + | var | fvar | sort | const | app | lam | letE | prj | nat | str => + exact TcM.PreservesInferOnly.pure (BoundedStep.done false) + +theorem computeIsRecFieldStep_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (blockAddrs : Array Address) (source : KExpr .anon) : + ((computeIsRecFieldStep blockAddrs source).run + methods).PreservesInferOnly := by + unfold computeIsRecFieldStep + refine bind_preservesInferOnly + (whnfRec_preservesInferOnly hmethods source) ?_ + intro normalized + exact computeIsRecFieldStepAfterWhnf_preservesInferOnly + blockAddrs normalized + +theorem computeIsRecCtor_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (ctorTy : KExpr .anon) (nParams : Nat) + (blockAddrs : Array Address) : + ((computeIsRecCtor ctorTy nParams blockAddrs).run + methods).PreservesInferOnly := by + unfold computeIsRecCtor + refine bindTcM_preservesInferOnly TcM.PreservesInferOnly.saveDepth ?_ + intro saved + change (tryFinally + ((do + let ty ← forIn [0:nParams] ctorTy fun _ ty => + computeIsRecParamStep ty + runBounded (computeIsRecFieldStep blockAddrs) + maxWhnfFuel.toNat ty).run methods) + (TcM.restoreDepth (m := .anon) saved)).PreservesInferOnly + apply TcM.PreservesInferOnly.tryFinally + · refine bind_preservesInferOnly + (forInRange_preservesInferOnly + (fun _ ty => computeIsRecParamStep_preservesInferOnly hmethods ty) + [0:nParams] ctorTy) ?_ + intro ty + exact runBounded_preservesInferOnly + (fun source => computeIsRecFieldStep_preservesInferOnly + hmethods blockAddrs source) maxWhnfFuel.toNat ty + · exact TcM.PreservesInferOnly.restoreDepth saved + +theorem computeIsRec_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (ctors : Array (KId .anon)) (nParams : Nat) + (blockAddrs : Array Address) : + ((computeIsRec ctors nParams blockAddrs).run + methods).PreservesInferOnly := by + unfold computeIsRec + refine bind_preservesInferOnly + (forInArray_preservesInferOnly (methods := methods) + (items := ctors) + (initial := (⟨none, PUnit.unit⟩ : MProd (Option Bool) PUnit)) ?_) ?_ + · intro ctorId state + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.tryGetConst ctorId) ?_ + intro declaration + cases declaration with + | none => + exact TcM.PreservesInferOnly.pure + (ForInStep.yield + (⟨none, PUnit.unit⟩ : MProd (Option Bool) PUnit)) + | some declaration => + cases declaration with + | ctor name levelParams isUnsafe lvls induct cidx params fields ty => + simp only [pure_bind] + refine bind_preservesInferOnly + (computeIsRecCtor_preservesInferOnly hmethods ty nParams + blockAddrs) ?_ + intro found + cases found with + | true => + simp only [if_true] + exact TcM.PreservesInferOnly.pure + (ForInStep.done + (⟨some true, PUnit.unit⟩ : MProd (Option Bool) PUnit)) + | false => + simp only [Bool.false_eq_true, if_false] + exact TcM.PreservesInferOnly.pure + (ForInStep.yield + (⟨none, PUnit.unit⟩ : MProd (Option Bool) PUnit)) + | axio | defn | quot | indc | recr => + exact TcM.PreservesInferOnly.pure + (ForInStep.yield + (⟨none, PUnit.unit⟩ : MProd (Option Bool) PUnit)) + · intro result + rcases result with ⟨found, _unit⟩ + cases found with + | none => + simp only [pure_bind] + exact TcM.PreservesInferOnly.pure false + | some value => exact TcM.PreservesInferOnly.pure value + +theorem cacheIsRec_preservesInferOnly + {methods : Methods .anon} (ind : KId .anon) (value : Bool) : + ((cacheIsRec ind value).run methods).PreservesInferOnly := by + unfold cacheIsRec + exact liftTcM_preservesInferOnly <| + TcM.PreservesInferOnly.modify (fun _ => rfl) + +theorem eraseCachedIsRec_preservesInferOnly + {methods : Methods .anon} (ind : KId .anon) : + ((eraseCachedIsRec ind).run methods).PreservesInferOnly := by + unfold eraseCachedIsRec + exact liftTcM_preservesInferOnly <| + TcM.PreservesInferOnly.modify (fun _ => rfl) + +theorem computedIsRecClassify_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (ind : KId .anon) (ctors : Array (KId .anon)) + (nParams : Nat) (blockAddrs : Array Address) : + ((computedIsRecClassify ind ctors nParams blockAddrs).run + methods).PreservesInferOnly := by + unfold computedIsRecClassify + change (tryCatch + ((do + let value ← computeIsRec ctors nParams blockAddrs + cacheIsRec ind value + return value).run methods) + (fun err => + (do + eraseCachedIsRec ind + throw err : RecM .anon Bool).run methods)).PreservesInferOnly + apply TcM.PreservesInferOnly.tryCatch + · refine bind_preservesInferOnly + (computeIsRec_preservesInferOnly hmethods ctors nParams blockAddrs) ?_ + intro value + refine bind_preservesInferOnly + (cacheIsRec_preservesInferOnly ind value) ?_ + intro _ + exact TcM.PreservesInferOnly.pure value + · intro err + refine bind_preservesInferOnly + (eraseCachedIsRec_preservesInferOnly ind) ?_ + intro _ + exact TcM.PreservesInferOnly.throw err + +attribute [local irreducible] computedIsRecClassify + +theorem computedIsRecMiss_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (ind : KId .anon) (params : UInt64) (ctors : Array (KId .anon)) + (block : KId .anon) : + ((computedIsRecMiss ind params ctors block).run + methods).PreservesInferOnly := by + unfold computedIsRecMiss + refine bind_preservesInferOnly (cacheIsRec_preservesInferOnly ind true) ?_ + intro _ + refine bind_preservesInferOnly + (discoverBlockInductives_preservesInferOnly block) ?_ + intro blockInds + apply computedIsRecClassify_preservesInferOnly + exact hmethods + +theorem computedIsRec_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (ind : KId .anon) : + ((computedIsRec ind).run methods).PreservesInferOnly := by + unfold computedIsRec + refine bindTcM_preservesInferOnly TcM.PreservesInferOnly.get ?_ + intro state + cases hcached : state.env.isRecCache[ind.addr]? with + | some value => + simp only [] + exact TcM.PreservesInferOnly.pure value + | none => + simp only [pure_bind] + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.getConst ind) ?_ + intro declaration + cases declaration with + | indc name levelParams lvls params indices isUnsafe block memberIdx ty + ctors leanAll => + exact computedIsRecMiss_preservesInferOnly hmethods ind params + ctors block + | axio | defn | quot | ctor | recr => + exact TcM.PreservesInferOnly.throw _ + +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/WhnfIotaScopePolicy.lean b/Ix/Tc/Verify/Check/WhnfIotaScopePolicy.lean new file mode 100644 index 000000000..d9edfcdb4 --- /dev/null +++ b/Ix/Tc/Verify/Check/WhnfIotaScopePolicy.lean @@ -0,0 +1,189 @@ +import Ix.Tc.Verify.Check.WhnfIotaBasePolicy + +/-! +# Operational inference-policy frame for scoped iota callbacks + +This module verifies the legacy-context operations, balanced dispatch-depth +wrapper, bounded recursor-type telescope scan, and its error-safe depth +restoration. These are the scoped callback primitives shared by struct eta +and K-like constructor synthesis. +-/ + +namespace Ix.Tc + + +namespace TcM.PreservesInferOnly + +theorem pushLocal (ty : KExpr .anon) : + (TcM.pushLocal ty).PreservesInferOnly := by + intro before + rfl + +theorem popLocal : + (TcM.popLocal (m := .anon)).PreservesInferOnly := by + intro before + rfl + +theorem saveDepth : + (TcM.saveDepth (m := .anon)).PreservesInferOnly := by + intro before + rfl + +private theorem restoreDepthGo (saved : Nat) : ∀ fuel, + (TcM.restoreDepth.go (m := .anon) saved fuel).PreservesInferOnly + | 0 => by + rw [TcM.restoreDepth.go] + exact pure () + | fuel + 1 => by + rw [TcM.restoreDepth.go] + apply bind get + intro state + split + · exact bind popLocal fun _ => restoreDepthGo saved fuel + · exact pure () + +theorem restoreDepth (saved : Nat) : + (TcM.restoreDepth (m := .anon) saved).PreservesInferOnly := by + unfold TcM.restoreDepth + apply bind get + intro state + exact restoreDepthGo saved (state.ctx.size - saved) + +theorem enterDispatch : + (RecM.enterDispatch (m := .anon)).PreservesInferOnly := by + apply ofWF + intro before + unfold RecM.enterDispatch + apply TcM.WF.bind + (Q₁ := fun observed after => observed = before ∧ after = before) + (TcM.WF.get fun _ => ⟨rfl, rfl⟩) + intro observed after hread + rcases hread with ⟨rfl, rfl⟩ + simp only + split + · exact TcM.WF.throw (fun _ => trivial) + · exact TcM.WF.set (fun _ => rfl) (fun _ => trivial) + +theorem exitDispatch : + (RecM.exitDispatch (m := .anon)).PreservesInferOnly := by + intro before + rfl + +end TcM.PreservesInferOnly + +namespace RecM + +theorem callIsDefEq_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (left right : KExpr .anon) : + ((callIsDefEq left right).run methods).PreservesInferOnly := by + unfold callIsDefEq + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.PreservesInferOnly.bind TcM.PreservesInferOnly.enterDispatch + intro _ + change (tryFinally (methods.isDefEq left right) + (RecM.exitDispatch (m := .anon))).PreservesInferOnly + exact TcM.PreservesInferOnly.tryFinally + (hmethods.isDefEq left right) TcM.PreservesInferOnly.exitDispatch + +theorem peelMajorForalls_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) : + ∀ fuel source, + ((peelMajorForalls fuel source).run methods).PreservesInferOnly + | 0, source => by + rw [peelMajorForalls] + exact TcM.PreservesInferOnly.pure source + | fuel + 1, source => by + rw [peelMajorForalls] + refine bind_preservesInferOnly + (whnfRec_preservesInferOnly hmethods source) ?_ + intro normalized + cases normalized with + | all name bi domain body info => + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.pushLocal domain) + intro _ + exact peelMajorForalls_preservesInferOnly hmethods fuel body + | var | fvar | sort | const | app | lam | letE | prj | nat | str => + exact TcM.PreservesInferOnly.throw _ + +theorem scanMajorInductiveStep_preservesInferOnly + {methods : Methods .anon} (next : KExpr .anon → RecM .anon (KId .anon)) + (hnext : ∀ source, ((next source).run methods).PreservesInferOnly) + (normalized : KExpr .anon) : + ((scanMajorInductiveStep next normalized).run + methods).PreservesInferOnly := by + unfold scanMajorInductiveStep + cases normalized with + | all name bi domain body info => + generalize hhead : domain.collectSpine.1 = head + cases head with + | const id levels headInfo => + simp only [hhead] + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.tryGetConst id) ?_ + intro found + cases found with + | some declaration => + cases declaration with + | indc => exact TcM.PreservesInferOnly.pure id + | axio | defn | quot | ctor | recr => + simp only [pure_bind] + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.pushLocal domain) ?_ + intro _ + exact hnext body + | none => + simp only [pure_bind] + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.pushLocal domain) ?_ + intro _ + exact hnext body + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + simp only [hhead, pure_bind] + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.pushLocal domain) ?_ + intro _ + exact hnext body + | var | fvar | sort | const | app | lam | letE | prj | nat | str => + exact TcM.PreservesInferOnly.throw _ + +theorem scanMajorInductive_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) : + ∀ fuel source, + ((scanMajorInductive fuel source).run methods).PreservesInferOnly + | 0, source => by + rw [scanMajorInductive] + exact TcM.PreservesInferOnly.throw _ + | fuel + 1, source => by + rw [scanMajorInductive] + refine bind_preservesInferOnly + (whnfRec_preservesInferOnly hmethods source) ?_ + intro normalized + exact scanMajorInductiveStep_preservesInferOnly + (scanMajorInductive fuel) + (scanMajorInductive_preservesInferOnly hmethods fuel) normalized + +theorem getMajorInductiveId_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (recTy : KExpr .anon) (skip : UInt64) : + ((getMajorInductiveId recTy skip).run methods).PreservesInferOnly := by + unfold getMajorInductiveId + refine bindTcM_preservesInferOnly TcM.PreservesInferOnly.saveDepth ?_ + intro saved + change (tryFinally + ((do + let ty ← peelMajorForalls skip.toNat recTy + scanMajorInductive 9 ty).run methods) + (TcM.restoreDepth (m := .anon) saved)).PreservesInferOnly + apply TcM.PreservesInferOnly.tryFinally + · refine bind_preservesInferOnly + (peelMajorForalls_preservesInferOnly hmethods skip.toNat recTy) ?_ + intro ty + exact scanMajorInductive_preservesInferOnly hmethods 9 ty + · exact TcM.PreservesInferOnly.restoreDepth saved + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/WhnfIotaSynthesisPolicy.lean b/Ix/Tc/Verify/Check/WhnfIotaSynthesisPolicy.lean new file mode 100644 index 000000000..6a1e27103 --- /dev/null +++ b/Ix/Tc/Verify/Check/WhnfIotaSynthesisPolicy.lean @@ -0,0 +1,346 @@ +import Ix.Tc.Verify.Check.WhnfIotaRecursionPolicy + +/-! +# Operational inference-policy frame for struct eta and K synthesis + +This module verifies both iota fallbacks that synthesize constructor-shaped +terms: struct eta for non-recursive one-constructor inductives and K-like +nullary-constructor synthesis. It covers scoped type scans, optional +inference and WHNF probes, universe instantiation, projection rebuilding, +DefEq validation, and synthesis statistics on acceptance and rejection. +-/ + +namespace Ix.Tc +namespace RecM + + +theorem isStructLike_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (id : KId .anon) : + ((isStructLike id).run methods).PreservesInferOnly := by + unfold isStructLike + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.tryGetConst id) ?_ + intro declaration + cases declaration with + | none => exact TcM.PreservesInferOnly.pure false + | some declaration => + cases declaration with + | indc name levelParams lvls params indices isUnsafe block memberIdx ty + ctors leanAll => + by_cases hinvalid : indices != 0 || ctors.size != 1 + · simp only [hinvalid, if_pos] + exact TcM.PreservesInferOnly.pure false + · simp only [hinvalid, pure_bind] + refine bind_preservesInferOnly + (computedIsRec_preservesInferOnly hmethods id) ?_ + intro recursive + exact TcM.PreservesInferOnly.pure (!recursive) + | axio | defn | quot | ctor | recr => + exact TcM.PreservesInferOnly.pure false + +theorem finishStructEtaFields_preservesInferOnly + {methods : Methods .anon} (indId : KId .anon) + (major : KExpr .anon) : ∀ fuel field result, + ((finishStructEtaFields indId major fuel field result).run + methods).PreservesInferOnly + | 0, field, result => by + rw [finishStructEtaFields] + exact TcM.PreservesInferOnly.pure result + | fuel + 1, field, result => by + rw [finishStructEtaFields] + refine bindIntern_preservesInferOnly + (.mkPrj indId field.toUInt64 major) ?_ + intro proj + refine bindIntern_preservesInferOnly (.mkApp result proj) ?_ + intro next + exact finishStructEtaFields_preservesInferOnly indId major fuel + (field + 1) next + +theorem finishStructEtaResult_preservesInferOnly + {methods : Methods .anon} (indId : KId .anon) + (major rhs : KExpr .anon) (fields : UInt64) + (prefixArgs trailingArgs : Array (KExpr .anon)) : + ((finishStructEtaResult indId major rhs fields prefixArgs trailingArgs).run + methods).PreservesInferOnly := by + unfold finishStructEtaResult + refine bind_preservesInferOnly + (finishAppResult_preservesInferOnly rhs prefixArgs 0) ?_ + intro prefixResult + refine bind_preservesInferOnly + (finishStructEtaFields_preservesInferOnly indId major fields.toNat 0 + prefixResult) ?_ + intro fieldResult + exact finishAppResult_preservesInferOnly fieldResult trailingArgs 0 + +attribute [local irreducible] finishStructEtaResult + +theorem finishStructEtaAfterSort_preservesInferOnly + {methods : Methods .anon} (recUs : Array (KUniv .anon)) + (spine : Array (KExpr .anon)) (recr : IotaInfo .anon) + (rule : RecRule .anon) (indId : KId .anon) + (major majorSortW : KExpr .anon) : + ((finishStructEtaAfterSort recUs spine recr rule indId major majorSortW).run + methods).PreservesInferOnly := by + unfold finishStructEtaAfterSort + by_cases hrejected : structEtaSortRejected majorSortW + · simp only [hrejected, if_pos] + exact TcM.PreservesInferOnly.pure none + · simp only [hrejected] + let pmmEnd := recr.params + recr.motives + recr.minors + have htail : + ((do + let rhs ← TcM.instantiateUnivParams rule.rhs recUs + 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 : RecM .anon (Option (KExpr .anon))).run + methods).PreservesInferOnly := by + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.instantiateUnivParams rule.rhs recUs) ?_ + intro rhs + refine bind_preservesInferOnly + (finishStructEtaResult_preservesInferOnly indId major rhs rule.fields + (spine.extract 0 (min pmmEnd spine.size)) + (spine.extract (recr.majorIdx + 1) spine.size)) ?_ + intro result + exact TcM.PreservesInferOnly.pure (some result) + simpa only [pure_bind] using htail + +theorem tryStructEtaAfterInductive_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (recUs : Array (KUniv .anon)) (spine : Array (KExpr .anon)) + (recr : IotaInfo .anon) (rule : RecRule .anon) (indId : KId .anon) : + ((tryStructEtaAfterInductive recUs spine recr rule indId).run + methods).PreservesInferOnly := by + unfold tryStructEtaAfterInductive + refine bind_preservesInferOnly (isStructLike_preservesInferOnly hmethods indId) ?_ + intro structLike + cases structLike with + | false => + simp only [Bool.not_false, if_true] + exact TcM.PreservesInferOnly.pure none + | true => + simp only [Bool.not_true, pure_bind] + let major := spine[recr.majorIdx]! + refine bind_preservesInferOnly + (tryOptional_preservesInferOnly + (inferOnlyRec_preservesInferOnly hmethods major)) ?_ + intro majorTyResult + cases majorTyResult with + | none => exact TcM.PreservesInferOnly.pure none + | some majorTy => + simp only [] + refine bind_preservesInferOnly + (tryOptional_preservesInferOnly + (inferOnlyRec_preservesInferOnly hmethods majorTy)) ?_ + intro majorSortResult + cases majorSortResult with + | none => exact TcM.PreservesInferOnly.pure none + | some majorSort => + simp only [] + refine bind_preservesInferOnly + (tryOptional_preservesInferOnly + (whnfRec_preservesInferOnly hmethods majorSort)) ?_ + intro majorSortWResult + cases majorSortWResult with + | none => exact TcM.PreservesInferOnly.pure none + | some majorSortW => + exact finishStructEtaAfterSort_preservesInferOnly recUs + spine recr rule indId major majorSortW + +attribute [local irreducible] tryStructEtaAfterInductive + +theorem tryStructEtaIota_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (recId : KId .anon) (recr : IotaInfo .anon) + (recUs : Array (KUniv .anon)) (spine : Array (KExpr .anon)) : + ((tryStructEtaIota recId recr recUs spine).run + methods).PreservesInferOnly := by + unfold tryStructEtaIota + by_cases hrules : recr.rules.size != 1 + · simp only [hrules, if_pos] + exact TcM.PreservesInferOnly.pure none + · simp only [hrules, Bool.false_eq_true, if_false, pure_bind] + by_cases hlevels : recUs.size.toUInt64 != recr.lvls + · simp only [hlevels, if_pos] + exact TcM.PreservesInferOnly.pure none + · simp only [hlevels, Bool.false_eq_true, if_false] + let rule := recr.rules[0]! + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.tryGetConst recId) ?_ + intro declaration + cases declaration with + | none => exact TcM.PreservesInferOnly.pure none + | some declaration => + let recTy := declaration.ty + let skip := + (recr.params + recr.motives + recr.minors + + recr.indices).toUInt64 + have hscan : + ((do + let recTy ← TcM.instantiateUnivParams recTy recUs + getMajorInductiveId recTy skip : RecM .anon (KId .anon)).run + methods).PreservesInferOnly := by + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.instantiateUnivParams recTy recUs) ?_ + intro instantiated + exact getMajorInductiveId_preservesInferOnly hmethods + instantiated skip + refine bind_preservesInferOnly + (tryOptional_preservesInferOnly hscan) ?_ + intro indResult + cases indResult with + | none => exact TcM.PreservesInferOnly.pure none + | some indId => + exact tryStructEtaAfterInductive_preservesInferOnly hmethods + recUs spine recr rule indId + +theorem verifyKSynthCandidate_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (majorTyW : KExpr .anon) (ctorId : KId .anon) + (tyUs : Array (KUniv .anon)) (tyArgs : Array (KExpr .anon)) + (params : Nat) : + ((verifyKSynthCandidate majorTyW ctorId tyUs tyArgs params).run + methods).PreservesInferOnly := by + unfold verifyKSynthCandidate + refine bindIntern_preservesInferOnly (.mkConst ctorId tyUs) ?_ + intro ctorHead + refine bind_preservesInferOnly + (finishAppResult_preservesInferOnly ctorHead + (tyArgs.extract 0 (min params tyArgs.size)) 0) ?_ + intro ctorApp + refine bind_preservesInferOnly + (tryOptional_preservesInferOnly + (inferOnlyRec_preservesInferOnly hmethods ctorApp)) ?_ + intro ctorTyResult + cases ctorTyResult with + | none => exact TcM.PreservesInferOnly.pure none + | some ctorTy => + simp only [] + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.bumpStats + (fun state : TcState .anon => { state with + kSynthAttempts := state.kSynthAttempts + 1 }) + (fun _ => rfl)) ?_ + intro _ + refine bind_preservesInferOnly + (callIsDefEq_preservesInferOnly hmethods majorTyW ctorTy) ?_ + intro equal + cases equal with + | true => + simp only [Bool.not_true, pure_bind] + exact TcM.PreservesInferOnly.pure (some ctorApp) + | false => + simp only [Bool.not_false, if_true] + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.bumpStats + (fun state : TcState .anon => { state with + kSynthRejects := state.kSynthRejects + 1 }) + (fun _ => rfl)) ?_ + intro _ + exact TcM.PreservesInferOnly.pure none + +attribute [local irreducible] verifyKSynthCandidate + +theorem selectKSynthCandidate_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (majorTyW : KExpr .anon) (tyHeadId : KId .anon) + (tyUs : Array (KUniv .anon)) (tyArgs : Array (KExpr .anon)) + (indId : KId .anon) (params : Nat) : + ((selectKSynthCandidate majorTyW tyHeadId tyUs tyArgs indId params).run + methods).PreservesInferOnly := by + unfold selectKSynthCandidate + by_cases hmismatch : tyHeadId.addr != indId.addr + · simp only [hmismatch, if_pos] + exact TcM.PreservesInferOnly.pure none + · simp only [hmismatch, Bool.false_eq_true, if_false, pure_bind] + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.tryGetConst indId) ?_ + intro declaration + cases declaration with + | none => exact TcM.PreservesInferOnly.pure none + | some declaration => + cases declaration with + | indc name levelParams lvls indParams indices isUnsafe block memberIdx + ty ctors leanAll => + simp only [] + cases hctor : ctors[0]? with + | none => + simp only [] + exact TcM.PreservesInferOnly.pure none + | some ctorId => + simp only [] + exact verifyKSynthCandidate_preservesInferOnly hmethods + majorTyW ctorId tyUs tyArgs params + | axio | defn | quot | ctor | recr => + simp only [] + exact TcM.PreservesInferOnly.pure none + +attribute [local irreducible] selectKSynthCandidate + +theorem synthCtorWhenK_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (major : KExpr .anon) (recId : KId .anon) (recr : IotaInfo .anon) + (recUs : Array (KUniv .anon)) : + ((synthCtorWhenK major recId recr recUs).run + methods).PreservesInferOnly := by + unfold synthCtorWhenK + by_cases hlevels : recUs.size.toUInt64 != recr.lvls + · simp only [hlevels, if_pos] + exact TcM.PreservesInferOnly.pure none + · simp only [hlevels, Bool.false_eq_true, if_false, pure_bind] + refine bind_preservesInferOnly + (tryOptional_preservesInferOnly + (inferOnlyRec_preservesInferOnly hmethods major)) ?_ + intro majorTyResult + cases majorTyResult with + | none => exact TcM.PreservesInferOnly.pure none + | some majorTy => + simp only [] + refine bind_preservesInferOnly + (tryOptional_preservesInferOnly + (whnfRec_preservesInferOnly hmethods majorTy)) ?_ + intro majorTyWResult + cases majorTyWResult with + | none => exact TcM.PreservesInferOnly.pure none + | some majorTyW => + simp only [] + rcases hspine : majorTyW.collectSpine with ⟨tyHead, tyArgs⟩ + cases tyHead with + | const tyHeadId tyUs tyInfo => + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.tryGetConst recId) ?_ + intro declaration + cases declaration with + | none => exact TcM.PreservesInferOnly.pure none + | some declaration => + let recTy := declaration.ty + let skip := + (recr.params + recr.motives + recr.minors + + recr.indices).toUInt64 + have hscan : + ((do + let recTy ← TcM.instantiateUnivParams recTy recUs + getMajorInductiveId recTy skip : + RecM .anon (KId .anon)).run + methods).PreservesInferOnly := by + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.instantiateUnivParams recTy + recUs) ?_ + intro instantiated + exact getMajorInductiveId_preservesInferOnly hmethods + instantiated skip + refine bind_preservesInferOnly + (tryOptional_preservesInferOnly hscan) ?_ + intro indResult + cases indResult with + | none => exact TcM.PreservesInferOnly.pure none + | some indId => + exact selectKSynthCandidate_preservesInferOnly hmethods + majorTyW tyHeadId tyUs tyArgs indId recr.params + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + exact TcM.PreservesInferOnly.pure none + +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/WhnfNatArgumentPolicy.lean b/Ix/Tc/Verify/Check/WhnfNatArgumentPolicy.lean new file mode 100644 index 000000000..6727156cd --- /dev/null +++ b/Ix/Tc/Verify/Check/WhnfNatArgumentPolicy.lean @@ -0,0 +1,169 @@ +import Ix.Tc.Verify.Check.WhnfProjectionPolicy + +/-! +# Operational policy for Nat argument normalization and stuck offsets + +This module proves that the shared Nat argument callback restores the +caller's inference policy through direct reduction, temporary local fuel, +successful callbacks, caught exhaustion, and propagated errors. It then +closes the complete `tryNatOffsetStuck` classifier and rebuild path. +-/ + +namespace Ix.Tc + +namespace RecM + +private theorem prims_preservesInferOnly (methods : Methods .anon) : + ((prims : RecM .anon (Primitives .anon)).run methods).PreservesInferOnly := by + unfold prims + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind TcM.PreservesInferOnly.get + intro state + exact TcM.PreservesInferOnly.pure state.prims + +theorem whnfNatReducerArg_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (arg : KExpr .anon) : + ((whnfNatReducerArg arg).run methods).PreservesInferOnly := by + unfold whnfNatReducerArg + refine bindTcM_preservesInferOnly TcM.PreservesInferOnly.get ?_ + intro observed + cases hdirect : !arg.hasFVars || observed.eagerReduce with + | true => + simp only [if_true] + refine bind_preservesInferOnly + (x := whnfRec arg) + (whnfRec_preservesInferOnly hmethods arg) ?_ + intro reduced + exact TcM.PreservesInferOnly.pure (some reduced) + | false => + simp only [Bool.false_eq_true, if_false, pure_bind] + refine bindTcM_preservesInferOnly TcM.PreservesInferOnly.get ?_ + intro (saved : TcState .anon) + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.modify + (f := fun state : TcState .anon => + { state with recFuel := + (min saved.recFuel natReducerOpenArgRecFuel) }) + (fun _ => rfl)) ?_ + intro _ + refine bind_preservesInferOnly + (x := try + let reduced ← whnfRec arg + pure (Except.ok reduced) + catch error => + pure (Except.error error)) + (captureErrors_preservesInferOnly + (whnfRec_preservesInferOnly hmethods arg)) ?_ + intro result + refine bindTcM_preservesInferOnly TcM.PreservesInferOnly.get ?_ + intro afterCallback + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.modify + (f := fun state : TcState .anon => + { state with recFuel := saved.recFuel - + (min saved.recFuel + (min saved.recFuel natReducerOpenArgRecFuel - + afterCallback.recFuel)) }) + (fun _ => rfl)) ?_ + intro _ + cases result with + | ok reduced => exact TcM.PreservesInferOnly.pure (some reduced) + | error error => + cases error <;> + first + | exact TcM.PreservesInferOnly.pure none + | exact TcM.PreservesInferOnly.throw _ + +attribute [local irreducible] whnfNatReducerArg + +theorem tryNatOffsetStuck_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (source : KExpr .anon) : + ((tryNatOffsetStuck source).run methods).PreservesInferOnly := by + unfold tryNatOffsetStuck + refine bind_preservesInferOnly + (x := prims) (prims_preservesInferOnly methods) ?_ + intro p + cases hhead : !natOffsetStuckHead p source with + | true => + simp only [if_true] + exact TcM.PreservesInferOnly.pure none + | false => + simp only [Bool.false_eq_true, if_false, pure_bind] + rcases hspine : source.collectSpine with ⟨head, args⟩ + cases head with + | const id levels info => + cases hshape : + ((!(id.addr == p.natAdd.addr) && + !(id.addr == p.natDiv.addr || + id.addr == p.natMod.addr)) || args.size != 2) with + | true => + simp only [hshape, if_true] + exact TcM.PreservesInferOnly.pure none + | false => + simp only [hshape, Bool.false_eq_true, if_false] + refine bind_preservesInferOnly + (x := whnfNatReducerArg args[1]!) + (whnfNatReducerArg_preservesInferOnly hmethods args[1]!) ?_ + intro normalizedRight + cases normalizedRight with + | none => + simp only + exact TcM.PreservesInferOnly.pure none + | some right => + simp only + cases hvalue : extractNatValue right p with + | none => + simp only + exact TcM.PreservesInferOnly.pure none + | some value => + simp only + cases hzero : value == 0 with + | true => + simp only [if_true] + exact TcM.PreservesInferOnly.pure none + | false => + simp only [Bool.false_eq_true, if_false] + cases hone : + (id.addr == p.natDiv.addr || + id.addr == p.natMod.addr) && value == 1 with + | true => + simp only [if_true] + exact TcM.PreservesInferOnly.pure none + | false => + simp only [Bool.false_eq_true, if_false] + refine bind_preservesInferOnly + (x := whnfNatReducerArg args[0]!) + (whnfNatReducerArg_preservesInferOnly + hmethods args[0]!) ?_ + intro normalizedLeft + cases normalizedLeft with + | none => + simp only + exact TcM.PreservesInferOnly.pure none + | some left => + simp only + cases hliteral : + (extractNatValue left p).isSome with + | true => + simp only [if_true] + exact TcM.PreservesInferOnly.pure none + | false => + simp only [Bool.false_eq_true, if_false] + refine bindIntern_preservesInferOnly + (KExpr.mkApp + (.const id levels info) left) ?_ + intro inner + refine bindIntern_preservesInferOnly + (KExpr.mkApp inner + (natExprFromValue value)) ?_ + intro result + exact TcM.PreservesInferOnly.pure + (some result) + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + exact TcM.PreservesInferOnly.pure none + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/WhnfNatPolicy.lean b/Ix/Tc/Verify/Check/WhnfNatPolicy.lean new file mode 100644 index 000000000..0f51d0da6 --- /dev/null +++ b/Ix/Tc/Verify/Check/WhnfNatPolicy.lean @@ -0,0 +1,468 @@ +import Ix.Tc.Verify.Check.WhnfNativePolicy + +/-! +# Operational inference-policy frame for native Nat reduction + +This module closes the Nat reducer from its bounded successor-collapse loop +through binary arithmetic and predicates. The proof covers the stuck-suffix +memo, callback and partial-error paths, local Nat-argument fuel, interning, +and application rebuilding. +-/ + +namespace Ix.Tc + +namespace RecM + + +private theorem prims_preservesInferOnly (methods : Methods .anon) : + ((prims : RecM .anon (Primitives .anon)).run methods).PreservesInferOnly := by + unfold prims + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind TcM.PreservesInferOnly.get + intro state + exact TcM.PreservesInferOnly.pure state.prims + +theorem isNatBinArithAddr_preservesInferOnly + {methods : Methods .anon} (addr : Address) : + ((isNatBinArithAddr addr).run methods).PreservesInferOnly := by + unfold isNatBinArithAddr + refine bind_preservesInferOnly (prims_preservesInferOnly methods) ?_ + intro p + exact TcM.PreservesInferOnly.pure _ + +theorem isNatBinPredAddr_preservesInferOnly + {methods : Methods .anon} (addr : Address) : + ((isNatBinPredAddr addr).run methods).PreservesInferOnly := by + unfold isNatBinPredAddr + refine bind_preservesInferOnly (prims_preservesInferOnly methods) ?_ + intro p + exact TcM.PreservesInferOnly.pure _ + +theorem mkNatAdd_preservesInferOnly + {methods : Methods .anon} (left right : KExpr .anon) : + ((mkNatAdd left right).run methods).PreservesInferOnly := by + unfold mkNatAdd + refine bind_preservesInferOnly (prims_preservesInferOnly methods) ?_ + intro p + exact TcM.PreservesInferOnly.pure _ + +theorem isNatSuccIhStep_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (step : KExpr .anon) : + ((isNatSuccIhStep step).run methods).PreservesInferOnly := by + unfold isNatSuccIhStep + refine bind_preservesInferOnly + (whnfRec_preservesInferOnly hmethods step) ?_ + intro reduced + cases reduced with + | lam name bi ty body info => + simp only [] + cases body with + | lam innerName innerBi innerTy innerBody innerInfo => + simp only [] + rcases hspine : innerBody.collectSpine with ⟨head, args⟩ + cases head with + | const id levels headInfo => + simp only [] + refine bind_preservesInferOnly + (prims_preservesInferOnly methods) ?_ + intro p + split + · exact TcM.PreservesInferOnly.pure false + · cases harg : args[0]! with + | var index argName argInfo => + split <;> exact TcM.PreservesInferOnly.pure _ + | fvar | sort | const | app | lam | all | letE | prj | + nat | str => + exact TcM.PreservesInferOnly.pure false + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + simp only [] + exact TcM.PreservesInferOnly.pure false + | var | fvar | sort | const | app | all | letE | prj | nat | str => + simp only [] + exact TcM.PreservesInferOnly.pure false + | var | fvar | sort | const | app | all | letE | prj | nat | str => + simp only [] + exact TcM.PreservesInferOnly.pure false + +theorem natRecLiteralParts_preservesInferOnly + {methods : Methods .anon} (source : KExpr .anon) : + ((natRecLiteralParts source).run methods).PreservesInferOnly := by + unfold natRecLiteralParts + rcases hspine : source.collectSpine with ⟨head, spine⟩ + cases head with + | const id levels info => + refine bind_preservesInferOnly (prims_preservesInferOnly methods) ?_ + intro p + split + · exact TcM.PreservesInferOnly.pure none + · simp only [pure_bind] + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.tryGetConst id) ?_ + intro found + cases found with + | none => exact TcM.PreservesInferOnly.pure none + | some declaration => + cases declaration + case recr name levelParams kind isUnsafe lvls params indices + motives minors block memberIdx type rules leanAll => + simp only [] + split + · exact TcM.PreservesInferOnly.pure none + · cases hmajor : + spine[(params.toNat + motives.toNat + minors.toNat + + indices.toNat)]? with + | none => exact TcM.PreservesInferOnly.pure none + | some major => + cases major with + | nat value blob majorInfo => + exact TcM.PreservesInferOnly.pure _ + | var | fvar | sort | const | app | lam | all | letE | + prj | str => + exact TcM.PreservesInferOnly.pure none + all_goals + simp only [] + exact TcM.PreservesInferOnly.pure none + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + exact TcM.PreservesInferOnly.pure none + +theorem tryReduceNatSuccLinearRec_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (arg : KExpr .anon) (offset : Nat) : + ((tryReduceNatSuccLinearRec arg offset).run methods).PreservesInferOnly := by + unfold tryReduceNatSuccLinearRec + refine bind_preservesInferOnly + (natRecLiteralParts_preservesInferOnly arg) ?_ + intro found + cases found with + | none => exact TcM.PreservesInferOnly.pure none + | some parts => + simp only [] + cases hbase : parts.spine[parts.baseIdx]? with + | none => exact TcM.PreservesInferOnly.pure none + | some base => + cases hstep : parts.spine[parts.stepIdx]? with + | none => exact TcM.PreservesInferOnly.pure none + | some step => + refine bind_preservesInferOnly + (isNatSuccIhStep_preservesInferOnly hmethods step) ?_ + intro isSuccStep + cases hnot : !isSuccStep with + | true => + simp only [if_true] + exact TcM.PreservesInferOnly.pure none + | false => + simp only [Bool.false_eq_true, if_false, pure_bind] + refine bind_preservesInferOnly + (whnfRec_preservesInferOnly hmethods base) ?_ + intro baseWhnf + refine bind_preservesInferOnly + (prims_preservesInferOnly methods) ?_ + intro p + cases hvalue : extractNatValue baseWhnf p with + | some value => + simp only [] + exact TcM.PreservesInferOnly.pure _ + | none => + simp only [] + split + · exact TcM.PreservesInferOnly.pure none + · refine bind_preservesInferOnly + (mkNatAdd_preservesInferOnly baseWhnf + (natExprFromValue (parts.major + offset))) ?_ + intro result + exact TcM.PreservesInferOnly.pure (some result) + +theorem isNatSuccSpine_preservesInferOnly + {methods : Methods .anon} (source : KExpr .anon) : + ((isNatSuccSpine source).run methods).PreservesInferOnly := by + unfold isNatSuccSpine + rcases hspine : source.collectSpine with ⟨head, args⟩ + cases head with + | const id levels info => + refine bind_preservesInferOnly (prims_preservesInferOnly methods) ?_ + intro p + exact TcM.PreservesInferOnly.pure _ + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + exact TcM.PreservesInferOnly.pure false + +theorem recordNatSuccStuck_preservesInferOnly + {methods : Methods .anon} (visited : Array (Address × Address)) : + ((recordNatSuccStuck visited).run methods).PreservesInferOnly := by + unfold recordNatSuccStuck + exact liftTcM_preservesInferOnly <| + TcM.PreservesInferOnly.modify (fun _ => rfl) + +theorem tryReduceNatSuccPeelMiss_preservesInferOnly + {methods : Methods .anon} (normalized current : KExpr .anon) + (offset : Nat) (visited : Array (Address × Address)) + (currentKey : Address × Address) : + ((tryReduceNatSuccPeelMiss normalized current offset visited + currentKey).run methods).PreservesInferOnly := by + unfold tryReduceNatSuccPeelMiss + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.whnfKey normalized) ?_ + intro normalizedKey + exact TcM.PreservesInferOnly.pure _ + +theorem tryReduceNatSuccPeelAfterKey_preservesInferOnly + {methods : Methods .anon} (normalized current : KExpr .anon) + (offset : Nat) (visited : Array (Address × Address)) + (currentKey : Address × Address) : + ((tryReduceNatSuccPeelAfterKey normalized current offset visited + currentKey).run methods).PreservesInferOnly := by + unfold tryReduceNatSuccPeelAfterKey + refine bindTcM_preservesInferOnly TcM.PreservesInferOnly.get ?_ + intro state + split + · refine bind_preservesInferOnly + (recordNatSuccStuck_preservesInferOnly visited) ?_ + intro _ + exact TcM.PreservesInferOnly.pure _ + · exact tryReduceNatSuccPeelMiss_preservesInferOnly normalized current + offset visited currentKey + +theorem tryReduceNatSuccPeel_preservesInferOnly + {methods : Methods .anon} (normalized current : KExpr .anon) + (offset : Nat) (visited : Array (Address × Address)) : + ((tryReduceNatSuccPeel normalized current offset visited).run methods).PreservesInferOnly := by + unfold tryReduceNatSuccPeel + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.whnfKey current) ?_ + intro currentKey + exact tryReduceNatSuccPeelAfterKey_preservesInferOnly normalized current + offset visited currentKey + +theorem tryReduceNatSuccAfterWhnf_preservesInferOnly + {methods : Methods .anon} (normalized : KExpr .anon) (offset : Nat) + (visited : Array (Address × Address)) : + ((tryReduceNatSuccAfterWhnf normalized offset visited).run methods).PreservesInferOnly := by + unfold tryReduceNatSuccAfterWhnf + refine bind_preservesInferOnly (prims_preservesInferOnly methods) ?_ + intro p + cases hliteral : extractNatLit normalized p with + | some value => + simp only [] + exact TcM.PreservesInferOnly.pure _ + | none => + simp only [pure_bind] + rcases hspine : normalized.collectSpine with ⟨head, args⟩ + refine bind_preservesInferOnly + (isNatSuccSpine_preservesInferOnly normalized) ?_ + intro isSucc + cases hsucc : isSucc with + | true => + simp only [if_true] + refine bind_preservesInferOnly + (tryReduceNatSuccPeel_preservesInferOnly normalized args[0]! + offset visited) ?_ + intro result + exact TcM.PreservesInferOnly.pure result + | false => + simp only [Bool.false_eq_true, if_false] + refine bind_preservesInferOnly + (recordNatSuccStuck_preservesInferOnly visited) ?_ + intro _ + exact TcM.PreservesInferOnly.pure _ + +theorem tryReduceNatSuccIterStep_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (state : KExpr .anon × Nat × Array (Address × Address)) : + ((tryReduceNatSuccIterStep state).run methods).PreservesInferOnly := by + rcases state with ⟨current, offset, visited⟩ + unfold tryReduceNatSuccIterStep + refine bind_preservesInferOnly + (tryReduceNatSuccLinearRec_preservesInferOnly hmethods current offset) ?_ + intro direct + cases direct with + | some result => exact TcM.PreservesInferOnly.pure _ + | none => + simp only [pure_bind] + refine bind_preservesInferOnly + (whnfModeRec_preservesInferOnly hmethods current .stuck) ?_ + intro normalized + exact tryReduceNatSuccAfterWhnf_preservesInferOnly normalized offset + visited + +theorem tryReduceNatSuccIter_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (arg : KExpr .anon) : + ((tryReduceNatSuccIter arg).run methods).PreservesInferOnly := by + unfold tryReduceNatSuccIter + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.whnfKey arg) ?_ + intro entryKey + refine bindTcM_preservesInferOnly TcM.PreservesInferOnly.get ?_ + intro state + split + · exact TcM.PreservesInferOnly.pure none + · exact runBounded_preservesInferOnly + (fun loopState => + tryReduceNatSuccIterStep_preservesInferOnly hmethods loopState) + maxWhnfFuel.toNat (arg, 1, #[entryKey]) + +theorem tryReduceNatPredicate_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (addr : Address) (args : Array (KExpr .anon)) : + ((tryReduceNatPredicate addr args).run methods).PreservesInferOnly := by + unfold tryReduceNatPredicate + refine bind_preservesInferOnly + (whnfNatReducerArg_preservesInferOnly hmethods args[0]!) ?_ + intro leftResult + cases leftResult with + | none => exact TcM.PreservesInferOnly.pure none + | some left => + simp only [] + refine bind_preservesInferOnly (prims_preservesInferOnly methods) ?_ + intro p + cases hleft : extractNatLit left p with + | none => exact TcM.PreservesInferOnly.pure none + | some leftValue => + simp only [] + refine bind_preservesInferOnly + (whnfNatReducerArg_preservesInferOnly hmethods args[1]!) ?_ + intro rightResult + cases rightResult with + | none => exact TcM.PreservesInferOnly.pure none + | some right => + simp only [] + cases hright : extractNatLit right p with + | none => exact TcM.PreservesInferOnly.pure none + | some rightValue => + simp only [] + refine bindIntern_preservesInferOnly + (.mkConst + (if (if addr == p.natBeq.addr then + leftValue == rightValue + else leftValue.ble rightValue) then + p.boolTrue else p.boolFalse) #[]) ?_ + intro result + refine bind_preservesInferOnly + (finishAppResult_preservesInferOnly result args 2) ?_ + intro finished + exact TcM.PreservesInferOnly.pure (some finished) + +theorem tryReduceNatWithSuccMode_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (source : KExpr .anon) (mode : NatSuccMode) : + ((tryReduceNatWithSuccMode source mode).run methods).PreservesInferOnly := by + unfold tryReduceNatWithSuccMode + rcases hspine : source.collectSpine with ⟨head, args⟩ + cases head with + | const id levels info => + refine bind_preservesInferOnly (prims_preservesInferOnly methods) ?_ + intro p + cases hsucc : id.addr == p.natSucc.addr && args.size == 1 with + | true => + simp only [if_true] + cases hmode : mode == .stuck with + | true => + simp only [if_true] + exact TcM.PreservesInferOnly.pure none + | false => + simp only [Bool.false_eq_true, if_false, pure_bind] + refine bind_preservesInferOnly + (tryReduceNatSuccIter_preservesInferOnly hmethods args[0]!) ?_ + intro result + exact TcM.PreservesInferOnly.pure result + | false => + simp only [Bool.false_eq_true, if_false, pure_bind] + by_cases hsmall : args.size < 2 + · simp only [hsmall, if_pos] + exact TcM.PreservesInferOnly.pure none + · simp only [hsmall, if_false] + focus + refine bind_preservesInferOnly + (isNatBinArithAddr_preservesInferOnly id.addr) ?_ + intro isArith + refine bind_preservesInferOnly + (isNatBinPredAddr_preservesInferOnly id.addr) ?_ + intro isPred + cases hknown : !isArith && !isPred with + | true => + simp only [if_true] + exact TcM.PreservesInferOnly.pure none + | false => + simp only [Bool.false_eq_true, if_false] + cases hpred : isPred with + | true => + simp only [if_true] + refine bind_preservesInferOnly + (tryReduceNatPredicate_preservesInferOnly hmethods + id.addr args) ?_ + intro result + exact TcM.PreservesInferOnly.pure result + | false => + simp only [Bool.false_eq_true, if_false] + refine bind_preservesInferOnly + (whnfNatReducerArg_preservesInferOnly hmethods + args[0]!) ?_ + intro leftResult + cases leftResult with + | none => exact TcM.PreservesInferOnly.pure none + | some left => + simp only [] + refine bind_preservesInferOnly + (whnfNatReducerArg_preservesInferOnly hmethods + args[1]!) ?_ + intro rightResult + cases rightResult with + | none => exact TcM.PreservesInferOnly.pure none + | some right => + simp only [] + cases hleft : extractNatLit left p with + | none => + exact TcM.PreservesInferOnly.pure none + | some leftValue => + simp only [] + cases hright : extractNatLit right p with + | none => + exact TcM.PreservesInferOnly.pure none + | some rightValue => + simp only [] + cases harith : isArith with + | true => + simp only [if_true] + cases hcomputed : computeNatBin + id.addr PrimAddrs.canonical + leftValue rightValue with + | none => + exact + TcM.PreservesInferOnly.pure + none + | some value => + simp only [] + refine bind_preservesInferOnly + (finishAppResult_preservesInferOnly + (natExprFromValue value) + args 2) ?_ + intro result + exact + TcM.PreservesInferOnly.pure + (some result) + | false => + simp only [Bool.false_eq_true, + if_false] + refine bindIntern_preservesInferOnly + (.mkConst + (if (if id.addr == + p.natBeq.addr then + leftValue == rightValue + else + leftValue.ble rightValue) + then p.boolTrue + else p.boolFalse) #[]) ?_ + intro result + refine bind_preservesInferOnly + (finishAppResult_preservesInferOnly + result args 2) ?_ + intro finished + exact + TcM.PreservesInferOnly.pure + (some finished) + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + exact TcM.PreservesInferOnly.pure none + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/WhnfNativePolicy.lean b/Ix/Tc/Verify/Check/WhnfNativePolicy.lean new file mode 100644 index 000000000..8a15b3e73 --- /dev/null +++ b/Ix/Tc/Verify/Check/WhnfNativePolicy.lean @@ -0,0 +1,128 @@ +import Ix.Tc.Verify.Check.WhnfNatArgumentPolicy + +/-! +# Operational inference-policy frame for native WHNF reduction + +This module proves the complete policy frame for native reduction. The +syntax-only front end produces a `NativeReductionPlan`; the marker executor +then owns lazy declaration lookup, universe instantiation, the recursive WHNF +callback, and restoration of the re-entrancy guard on both outcomes. +-/ + +namespace Ix.Tc + +namespace RecM + +private theorem prims_preservesInferOnly (methods : Methods .anon) : + ((prims : RecM .anon (Primitives .anon)).run methods).PreservesInferOnly := by + unfold prims + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind TcM.PreservesInferOnly.get + intro state + exact TcM.PreservesInferOnly.pure state.prims + +theorem tryReduceNativeMarker_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (p : Primitives .anon) (isReduceBool : Bool) (id : KId .anon) + (levels : Array (KUniv .anon)) : + TcM.PreservesInferOnly + ((tryReduceNativeMarker p isReduceBool id levels).run methods) := by + unfold tryReduceNativeMarker + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.tryGetConst id) ?_ + intro found + cases found with + | none => exact TcM.PreservesInferOnly.pure none + | some declaration => + cases declaration + case defn name levelParams kind safety hints lvls type body leanAll + block => + simp only [pure_bind] + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.instantiateUnivParams body levels) ?_ + intro instantiated + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.modify + (f := fun state : TcState .anon => + { state with inNativeReduce := true }) + (fun _ => rfl)) ?_ + intro _ + refine bind_preservesInferOnly + (x := try + let result ← whnfRec instantiated + pure (Except.ok result) + catch error => + pure (Except.error error)) + (captureErrors_preservesInferOnly + (whnfRec_preservesInferOnly hmethods instantiated)) ?_ + intro captured + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.modify + (f := fun state : TcState .anon => + { state with inNativeReduce := false }) + (fun _ => rfl)) ?_ + intro _ + cases captured with + | error error => exact TcM.PreservesInferOnly.throw error + | ok result => + cases hbool : isReduceBool with + | true => + simp only [if_true] + cases hresult : result with + | const resultId resultLevels resultInfo => + simp only [] + split <;> exact TcM.PreservesInferOnly.pure _ + | var | fvar | sort | app | lam | all | letE | prj | nat | + str => + exact TcM.PreservesInferOnly.pure none + | false => + simp only [Bool.false_eq_true, if_false] + cases hresult : result <;> + exact TcM.PreservesInferOnly.pure _ + all_goals exact TcM.PreservesInferOnly.pure none + +attribute [local irreducible] tryReduceNativeMarker + +theorem tryReduceNative_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (source : KExpr .anon) : + TcM.PreservesInferOnly ((tryReduceNative source).run methods) := by + unfold tryReduceNative + refine bindTcM_preservesInferOnly TcM.PreservesInferOnly.get ?_ + intro state + cases hnoAccel : state.noAccel with + | true => + simp only [if_true] + exact TcM.PreservesInferOnly.pure none + | false => + simp only [Bool.false_eq_true, if_false, pure_bind] + rcases hspine : source.collectSpine with ⟨head, args⟩ + cases head with + | const id levels info => + refine bind_preservesInferOnly (prims_preservesInferOnly methods) ?_ + intro p + simp only [] + cases hplan : planNativeReduction p source id.addr args with + | done result => exact TcM.PreservesInferOnly.pure result + | marker isReduceBool arg => + refine bindTcM_preservesInferOnly TcM.PreservesInferOnly.get ?_ + intro guardState + cases hguard : guardState.inNativeReduce with + | true => + simp only [if_true] + exact TcM.PreservesInferOnly.pure none + | false => + simp only [Bool.false_eq_true, if_false] + cases harg : arg with + | const argId argLevels argInfo => + exact tryReduceNativeMarker_preservesInferOnly hmethods + p isReduceBool argId argLevels + | var | fvar | sort | app | lam | all | letE | prj | nat | + str => + exact TcM.PreservesInferOnly.pure none + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + exact TcM.PreservesInferOnly.pure none + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/WhnfProjectionPolicy.lean b/Ix/Tc/Verify/Check/WhnfProjectionPolicy.lean new file mode 100644 index 000000000..761e4adb5 --- /dev/null +++ b/Ix/Tc/Verify/Check/WhnfProjectionPolicy.lean @@ -0,0 +1,272 @@ +import Ix.Tc.Verify.Check.WhnfBasicHelperPolicy + +/-! +# Operational policy for WHNF projection reduction + +This module proves inference-policy preservation for String-constructor +expansion, the accelerated `Fin.val`/`Decidable.rec` rewrite, constructor +field selection, and the complete ordinary projection pipeline. Every +intern operation, lazy constructor lookup, recursive WHNF callback, miss, +and partial error is covered. +-/ + +namespace Ix.Tc + +namespace RecM + +set_option maxHeartbeats 800000 + +private theorem prims_preservesInferOnly (methods : Methods .anon) : + ((prims : RecM .anon (Primitives .anon)).run methods).PreservesInferOnly := by + unfold prims + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind TcM.PreservesInferOnly.get + intro state + exact TcM.PreservesInferOnly.pure state.prims + +theorem strLitListToConstructor_preservesInferOnly + {methods : Methods .anon} (charOfNat cons : KExpr .anon) + (chars : List Char) (list : KExpr .anon) : + TcM.PreservesInferOnly + ((strLitListToConstructor charOfNat cons chars list).run methods) := by + induction chars generalizing list with + | nil => + unfold strLitListToConstructor + exact TcM.PreservesInferOnly.pure list + | cons char chars ih => + unfold strLitListToConstructor + apply bindIntern_preservesInferOnly + intro natLiteral + apply bindIntern_preservesInferOnly + intro charValue + apply bindIntern_preservesInferOnly + intro partialApp + apply bindIntern_preservesInferOnly + intro next + exact ih next + +theorem strLitToConstructorWithPrimitives_preservesInferOnly + {methods : Methods .anon} (p : Primitives .anon) (value : String) : + TcM.PreservesInferOnly + ((strLitToConstructorWithPrimitives p value).run methods) := by + rw [strLitToConstructorWithPrimitives_eq] + refine bindIntern_preservesInferOnly (stringCharConst p) ?_ + intro charType + refine bindIntern_preservesInferOnly (stringCharOfNat p) ?_ + intro charOfNat + refine bindIntern_preservesInferOnly (stringMkConst p) ?_ + intro stringOfList + refine bindIntern_preservesInferOnly (stringListNilZero p) ?_ + intro listNil + refine bindIntern_preservesInferOnly + (KExpr.mkApp listNil charType) ?_ + intro nil + refine bindIntern_preservesInferOnly (stringListConsZero p) ?_ + intro listCons + refine bindIntern_preservesInferOnly + (KExpr.mkApp listCons charType) ?_ + intro cons + apply bind_preservesInferOnly + (strLitListToConstructor_preservesInferOnly charOfNat cons + value.toList.reverse nil) + intro list + simp only [ReaderT.run_monadLift] + exact intern_preservesInferOnly _ + +attribute [local irreducible] strLitToConstructor + strLitToConstructorWithPrimitives + +theorem strLitToConstructor_preservesInferOnly + {methods : Methods .anon} (value : String) : + ((strLitToConstructor value).run methods).PreservesInferOnly := by + rw [strLitToConstructor_eq] + intro before + have htail := + strLitToConstructorWithPrimitives_preservesInferOnly + (methods := methods) before.prims value before + unfold prims + simpa only [ReaderT.run_bind, EStateM.bind, get] using htail + +theorem projectDecidableFinValMinor_preservesInferOnly + {methods : Methods .anon} (id : KId .anon) (field : UInt64) + (minor : KExpr .anon) : + TcM.PreservesInferOnly + ((projectDecidableFinValMinor id field minor).run methods) := by + unfold projectDecidableFinValMinor + cases minor with + | lam name bi domain body info => + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.runIntern + (internExprM (KExpr.mkPrj id field body))) + intro projection + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.runIntern + (internExprM (KExpr.mkLam name bi domain projection))) + intro result + exact TcM.PreservesInferOnly.pure (some result) + | var | fvar | sort | const | app | all | letE | prj | nat | str => + exact TcM.PreservesInferOnly.pure none + +attribute [local irreducible] projectDecidableFinValMinor + +theorem tryReduceFinValDecidableRec_preservesInferOnly + {methods : Methods .anon} (id : KId .anon) (field : UInt64) + (head : KExpr .anon) (args : Array (KExpr .anon)) : + TcM.PreservesInferOnly + ((tryReduceFinValDecidableRec id field head args).run methods) := by + rw [tryReduceFinValDecidableRec_equation] + refine bindTcM_preservesInferOnly TcM.PreservesInferOnly.get ?_ + intro state + cases hnoAccel : state.noAccel with + | true => + simp only [if_true] + exact TcM.PreservesInferOnly.pure none + | false => + simp only [Bool.false_eq_true, if_false, pure_bind] + refine bind_preservesInferOnly + (x := prims) (prims_preservesInferOnly methods) ?_ + intro p + cases hfin : id.addr != p.fin.addr || field != 0 with + | true => + simp only [if_true] + exact TcM.PreservesInferOnly.pure none + | false => + simp only [Bool.false_eq_true, if_false] + cases head with + | const recId recLevels recInfo => + cases hrec : + recId.addr != p.decidableRec.addr || args.size < 5 with + | true => + simp only [hrec, if_true] + exact TcM.PreservesInferOnly.pure none + | false => + simp only [hrec, Bool.false_eq_true, if_false] + cases args[1]! with + | lam motiveName motiveBi motiveDomain motiveBody + motiveInfo => + refine bind_preservesInferOnly + (x := projectDecidableFinValMinor id field args[2]!) + (projectDecidableFinValMinor_preservesInferOnly + id field args[2]!) ?_ + intro falseMinor + cases falseMinor with + | none => exact TcM.PreservesInferOnly.pure none + | some falseMinor => + refine bind_preservesInferOnly + (x := projectDecidableFinValMinor id field args[3]!) + (projectDecidableFinValMinor_preservesInferOnly + id field args[3]!) ?_ + intro trueMinor + cases trueMinor with + | none => exact TcM.PreservesInferOnly.pure none + | some trueMinor => + refine bindIntern_preservesInferOnly + (KExpr.mkConst p.nat #[]) ?_ + intro natType + refine bindIntern_preservesInferOnly + (KExpr.mkLam motiveName motiveBi + motiveDomain natType) ?_ + intro motive + refine bindIntern_preservesInferOnly + (KExpr.mkConst recId recLevels) ?_ + intro result + refine bindIntern_preservesInferOnly + (KExpr.mkApp result args[0]!) ?_ + intro result + refine bindIntern_preservesInferOnly + (KExpr.mkApp result motive) ?_ + intro result + refine bindIntern_preservesInferOnly + (KExpr.mkApp result falseMinor) ?_ + intro result + refine bindIntern_preservesInferOnly + (KExpr.mkApp result trueMinor) ?_ + intro result + refine bindIntern_preservesInferOnly + (KExpr.mkApp result args[4]!) ?_ + intro base + rw [projectionDefinitionFinish_eq] + refine bind_preservesInferOnly + (x := finishAppResult base args 5) + (finishAppResult_preservesInferOnly + base args 5) ?_ + intro result + exact TcM.PreservesInferOnly.pure (some result) + | var | fvar | sort | const | app | all | letE | prj | + nat | str => + exact TcM.PreservesInferOnly.pure none + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + exact TcM.PreservesInferOnly.pure none + +attribute [local irreducible] tryReduceFinValDecidableRec + +theorem tryProjReduceTail_preservesInferOnly + {methods : Methods .anon} (id : KId .anon) (field : UInt64) + (value : KExpr .anon) : + ((tryProjReduceTail id field value).run methods).PreservesInferOnly := by + unfold tryProjReduceTail + rcases hspine : value.collectSpine with ⟨head, args⟩ + refine bind_preservesInferOnly + (x := tryReduceFinValDecidableRec id field head args) + (tryReduceFinValDecidableRec_preservesInferOnly id field head args) ?_ + intro special + cases special with + | some result => exact TcM.PreservesInferOnly.pure (some result) + | none => + cases head with + | const ctorId levels info => + simp only [pure_bind] + refine bindTcM_preservesInferOnly + (TcM.PreservesInferOnly.tryGetConst ctorId) ?_ + intro found + cases found with + | none => exact TcM.PreservesInferOnly.pure none + | some declaration => + cases declaration + case ctor name levelParams cidx fields lvls params ind ty + leanAll => + exact TcM.PreservesInferOnly.pure + args[params.toNat + field.toNat]? + all_goals exact TcM.PreservesInferOnly.pure none + | var | fvar | sort | app | lam | all | letE | prj | nat | str => + exact TcM.PreservesInferOnly.pure none + +theorem tryProjPrepare_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (value : KExpr .anon) : + ((tryProjPrepare value).run methods).PreservesInferOnly := by + unfold tryProjPrepare + cases value with + | str value blob info => + refine bind_preservesInferOnly + (x := strLitToConstructor value) + (strLitToConstructor_preservesInferOnly value) ?_ + intro expanded + exact whnfRec_preservesInferOnly hmethods expanded + | var idx name info => exact TcM.PreservesInferOnly.pure _ + | fvar id name info => exact TcM.PreservesInferOnly.pure _ + | sort level info => exact TcM.PreservesInferOnly.pure _ + | const id levels info => exact TcM.PreservesInferOnly.pure _ + | app fn arg info => exact TcM.PreservesInferOnly.pure _ + | lam name bi domain body info => exact TcM.PreservesInferOnly.pure _ + | all name bi domain body info => exact TcM.PreservesInferOnly.pure _ + | letE name type value body nondep info => + exact TcM.PreservesInferOnly.pure _ + | prj id field value info => exact TcM.PreservesInferOnly.pure _ + | nat value blob info => exact TcM.PreservesInferOnly.pure _ + +theorem tryProjReduce_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (id : KId .anon) (field : UInt64) (value : KExpr .anon) : + ((tryProjReduce id field value).run methods).PreservesInferOnly := by + unfold tryProjReduce + refine bind_preservesInferOnly + (x := tryProjPrepare value) + (tryProjPrepare_preservesInferOnly hmethods value) ?_ + intro prepared + exact tryProjReduceTail_preservesInferOnly id field prepared + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/Check/WhnfReductionPolicy.lean b/Ix/Tc/Verify/Check/WhnfReductionPolicy.lean new file mode 100644 index 000000000..a9aec51dc --- /dev/null +++ b/Ix/Tc/Verify/Check/WhnfReductionPolicy.lean @@ -0,0 +1,600 @@ +import Ix.Tc.Verify.Check.WhnfDriverPolicy + +/-! +# Operational inference-policy frame for WHNF reduction steps + +This module decomposes each production WHNF loop iteration into explicit +helper frames. It proves the structural dispatcher, the ordered no-delta +tail, and the full-WHNF iteration—including every success, miss, and partial +error path—without assuming the outer driver. + +`WhnfHelperPolicyAt` is the remaining local acceptance surface. Once its +helper fields are discharged, `reductionPolicy` supplies the complete step +contract consumed by `WhnfDriverPolicy`. +-/ + +namespace Ix.Tc + +namespace RecM + +private theorem prims_preservesInferOnly (methods : Methods .anon) : + ((prims : RecM .anon (Primitives .anon)).run methods).PreservesInferOnly := by + unfold prims + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind TcM.PreservesInferOnly.get + intro state + exact TcM.PreservesInferOnly.pure state.prims + +theorem whnfRec_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (source : KExpr .anon) : + ((whnfRec source).run methods).PreservesInferOnly := by + unfold whnfRec + simpa using hmethods.whnf source + +theorem whnfModeRec_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (source : KExpr .anon) (mode : NatSuccMode) : + ((whnfModeRec source mode).run methods).PreservesInferOnly := by + unfold whnfModeRec + simpa using hmethods.whnfMode source mode + +theorem whnfCoreFlagsRec_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (source : KExpr .anon) (flags : WhnfFlags) : + ((whnfCoreFlagsRec source flags).run methods).PreservesInferOnly := by + unfold whnfCoreFlagsRec + simpa using hmethods.whnfCoreFlags source flags + +theorem inferOnlyRec_preservesInferOnly + {methods : Methods .anon} (_hmethods : methods.PreservesInferOnly) + (source : KExpr .anon) : + ((inferOnlyRec source).run methods).PreservesInferOnly := by + unfold inferOnlyRec + simp only [ReaderT.run_bind] + exact TcM.PreservesInferOnly.withInferOnly (methods.infer source) + +private theorem tryQuestion_preservesInferOnly + {methods : Methods .anon} {x : RecM .anon alpha} + (hx : (x.run methods).PreservesInferOnly) : + ((try? x).run methods).PreservesInferOnly := by + unfold try? + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind + · exact TcM.PreservesInferOnly.tryCatch + (TcM.PreservesInferOnly.bind hx + (fun value => TcM.PreservesInferOnly.pure (some value))) + (fun _ => TcM.PreservesInferOnly.pure none) + · intro result + exact TcM.PreservesInferOnly.pure result + +theorem tryOptional_preservesInferOnly + {methods : Methods .anon} {x : RecM .anon alpha} + (hx : (x.run methods).PreservesInferOnly) : + ((tryOptional x).run methods).PreservesInferOnly := by + simpa only [tryOptional] using tryQuestion_preservesInferOnly hx + +theorem isNatLiteralRecursorApp_preservesInferOnly + {methods : Methods .anon} (source : KExpr .anon) : + ((isNatLiteralRecursorApp source).run methods).PreservesInferOnly := by + unfold isNatLiteralRecursorApp + simp only [] + rcases hspine : source.collectSpine with ⟨head, spine⟩ + cases head with + | const id levels info => + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind (prims_preservesInferOnly methods) + intro p + split + · exact TcM.PreservesInferOnly.pure false + · apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.tryGetConst id) + intro found + cases found with + | none => exact TcM.PreservesInferOnly.pure false + | some info => + cases info <;> simp only + case recr name levelParams k isUnsafe lvls params indices motives + minors block memberIdx ty rules leanAll => + cases hmajor : + spine[(params + motives + minors + indices).toNat]? with + | none => exact TcM.PreservesInferOnly.pure false + | some major => + cases major <;> exact TcM.PreservesInferOnly.pure _ + all_goals exact TcM.PreservesInferOnly.pure false + | var idx name info => exact TcM.PreservesInferOnly.pure false + | fvar id name info => exact TcM.PreservesInferOnly.pure false + | sort u info => exact TcM.PreservesInferOnly.pure false + | app f a info => exact TcM.PreservesInferOnly.pure false + | lam name bi ty body info => exact TcM.PreservesInferOnly.pure false + | all name bi ty body info => exact TcM.PreservesInferOnly.pure false + | letE name ty val body nondep info => exact TcM.PreservesInferOnly.pure false + | prj id field val info => exact TcM.PreservesInferOnly.pure false + | nat value blob info => exact TcM.PreservesInferOnly.pure false + | str value blob info => exact TcM.PreservesInferOnly.pure false + +theorem isTransientNatLiteralWork_preservesInferOnly + {methods : Methods .anon} (source : KExpr .anon) : + ((isTransientNatLiteralWork source).run methods).PreservesInferOnly := by + unfold isTransientNatLiteralWork + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind + (isNatLiteralRecursorApp_preservesInferOnly source) + intro direct + cases direct with + | true => exact TcM.PreservesInferOnly.pure true + | false => + simp only [Bool.false_eq_true, if_false, pure_bind] + rcases hspine : source.collectSpine with ⟨head, args⟩ + cases head with + | const id levels info => + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind (prims_preservesInferOnly methods) + intro p + split + · exact isNatLiteralRecursorApp_preservesInferOnly args[0]! + · exact TcM.PreservesInferOnly.pure false + | var idx name info => exact TcM.PreservesInferOnly.pure false + | fvar id name info => exact TcM.PreservesInferOnly.pure false + | sort u info => exact TcM.PreservesInferOnly.pure false + | app f a info => exact TcM.PreservesInferOnly.pure false + | lam name bi ty body info => exact TcM.PreservesInferOnly.pure false + | all name bi ty body info => exact TcM.PreservesInferOnly.pure false + | letE name ty val body nondep info => exact TcM.PreservesInferOnly.pure false + | prj id field val info => exact TcM.PreservesInferOnly.pure false + | nat value blob info => exact TcM.PreservesInferOnly.pure false + | str value blob info => exact TcM.PreservesInferOnly.pure false + +private theorem tryProjAppReduce_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hproj : ∀ id field value, + ((tryProjReduce id field value).run methods).PreservesInferOnly) + (source : KExpr .anon) (flags : WhnfFlags) : + TcM.PreservesInferOnly + ((tryProjAppReduce source flags).run methods) := by + unfold tryProjAppReduce + rcases hspine : source.collectSpine with ⟨head, args⟩ + cases hempty : args.isEmpty with + | true => + simp only [hempty, if_true] + exact TcM.PreservesInferOnly.pure none + | false => + simp only [hempty, Bool.false_eq_true, if_false, pure_bind] + cases head with + | prj id field value info => + cases hcheap : flags.cheapProj with + | true => + simp only [if_true, ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind + (whnfCoreFlagsRec_preservesInferOnly hmethods value flags) + intro reduced + apply TcM.PreservesInferOnly.bind (hproj id field reduced) + intro projection + cases projection <;> exact TcM.PreservesInferOnly.pure _ + | false => + simp only [Bool.false_eq_true, if_false, ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind + (whnfRec_preservesInferOnly hmethods value) + intro reduced + apply TcM.PreservesInferOnly.bind (hproj id field reduced) + intro projection + cases projection <;> exact TcM.PreservesInferOnly.pure _ + | var | fvar | sort | const | app | lam | all | letE | nat | str => + exact TcM.PreservesInferOnly.pure none + +/-- The projection-application reducer is a composition of the recursive +WHNF edge, the ordinary projection helper, and the shared application +finisher. It therefore needs no independent policy assumption. -/ +theorem tryProjAppReduceFinished_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (hproj : ∀ id field value, + ((tryProjReduce id field value).run methods).PreservesInferOnly) + (hfinish : ∀ base args start, + ((finishAppResult base args start).run methods).PreservesInferOnly) + (source : KExpr .anon) (flags : WhnfFlags) : + TcM.PreservesInferOnly + ((tryProjAppReduceFinished source flags).run methods) := by + unfold tryProjAppReduceFinished + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind + (tryProjAppReduce_preservesInferOnly hmethods hproj source flags) + intro projection + cases projection with + | none => exact TcM.PreservesInferOnly.pure none + | some pair => + rcases pair with ⟨base, args⟩ + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind (hfinish base args 0) + intro rebuilt + exact TcM.PreservesInferOnly.pure (some rebuilt) + +/-- Outcome-sensitive frames for the reduction helpers called by the three +WHNF step seams. Driver control and bounded iteration are not assumptions. -/ +structure WhnfHelperPolicyAt (methods : Methods .anon) : Prop where + proj : ∀ id field value, + ((tryProjReduce id field value).run methods).PreservesInferOnly + finishApp : ∀ base args start, + ((finishAppResult base args start).run methods).PreservesInferOnly + iota : ∀ source flags, + ((tryIotaWithFlags source flags).run methods).PreservesInferOnly + bitvec : ∀ source, + ((tryReduceBitvec source).run methods).PreservesInferOnly + nat : ∀ source mode, + ((tryReduceNatWithSuccMode source mode).run methods).PreservesInferOnly + native : ∀ source, + ((tryReduceNative source).run methods).PreservesInferOnly + string : ∀ source, + ((tryReduceString source).run methods).PreservesInferOnly + projectionDefinition : ∀ source, + ((tryReduceProjectionDefinition source).run methods).PreservesInferOnly + quot : ∀ source, + ((tryQuotReduce source).run methods).PreservesInferOnly + decidable : ∀ source, + ((tryReduceDecidable source).run methods).PreservesInferOnly + natOffset : ∀ source, + ((tryNatOffsetStuck source).run methods).PreservesInferOnly + delta : ∀ source, + ((deltaUnfoldOne source).run methods).PreservesInferOnly + +theorem whnfCoreWithFlagsStep_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (helpers : WhnfHelperPolicyAt methods) + (source : KExpr .anon) (flags : WhnfFlags) : + ((whnfCoreWithFlagsStep source flags).run methods).PreservesInferOnly := by + cases source with + | var idx name info => + unfold whnfCoreWithFlagsStep + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.lookupLetVal idx) + intro found + cases found <;> exact TcM.PreservesInferOnly.pure _ + | fvar id name info => + unfold whnfCoreWithFlagsStep + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind TcM.PreservesInferOnly.get + intro state + cases hfound : state.lctx.find? id with + | none => exact TcM.PreservesInferOnly.pure _ + | some decl => + cases decl <;> exact TcM.PreservesInferOnly.pure _ + | sort u info => exact TcM.PreservesInferOnly.pure _ + | const id levels info => exact TcM.PreservesInferOnly.pure _ + | lam name bi ty body info => exact TcM.PreservesInferOnly.pure _ + | all name bi ty body info => exact TcM.PreservesInferOnly.pure _ + | letE name ty value body nondep info => + unfold whnfCoreWithFlagsStep + simp only [ReaderT.run_bind, ReaderT.run_monadLift] + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.runIntern (subst body value 0)) + intro reduced + exact TcM.PreservesInferOnly.pure (BoundedStep.next reduced) + | prj id field value info => + unfold whnfCoreWithFlagsStep + simp only [] + split + · apply TcM.PreservesInferOnly.bind + (whnfCoreFlagsRec_preservesInferOnly hmethods value flags) + intro reducedValue + apply TcM.PreservesInferOnly.bind + (helpers.proj id field reducedValue) + intro result + cases result <;> exact TcM.PreservesInferOnly.pure _ + · apply TcM.PreservesInferOnly.bind + (whnfRec_preservesInferOnly hmethods value) + intro reducedValue + apply TcM.PreservesInferOnly.bind + (helpers.proj id field reducedValue) + intro result + cases result <;> exact TcM.PreservesInferOnly.pure _ + | nat value blob info => exact TcM.PreservesInferOnly.pure _ + | str value blob info => exact TcM.PreservesInferOnly.pure _ + | app fn arg info => + unfold whnfCoreWithFlagsStep + simp only [ReaderT.run_bind] + generalize hspine : (KExpr.app fn arg info).collectSpine = spine + rcases spine with ⟨head, args⟩ + apply TcM.PreservesInferOnly.bind + (whnfCoreFlagsRec_preservesInferOnly hmethods head flags) + intro reducedHead + cases reducedHead with + | lam name bi ty body info => + generalize hconsume : + consumeBetaLams (.lam name bi ty body info) args = consumed + rcases consumed with ⟨body0, consumedArgs⟩ + simp only [] + split + · simp only [ReaderT.run_bind, ReaderT.run_monadLift, pure_bind] + apply TcM.PreservesInferOnly.bind + (TcM.PreservesInferOnly.runIntern + (simulSubst body0 consumedArgs.reverse 0)) + intro substituted + apply TcM.PreservesInferOnly.bind + (helpers.finishApp substituted args consumedArgs.size) + intro rebuilt + exact TcM.PreservesInferOnly.pure (BoundedStep.next rebuilt) + · simp only [ReaderT.run_bind, pure_bind] + apply TcM.PreservesInferOnly.bind + (helpers.finishApp body0 args consumedArgs.size) + intro rebuilt + exact TcM.PreservesInferOnly.pure (BoundedStep.next rebuilt) + | var idx name info => + simp only + split + · apply TcM.PreservesInferOnly.bind + (helpers.finishApp (.var idx name info) args 0) + intro rebuilt + apply TcM.PreservesInferOnly.bind (helpers.iota rebuilt flags) + intro result + cases result <;> exact TcM.PreservesInferOnly.pure _ + · apply TcM.PreservesInferOnly.bind + (helpers.iota (.app fn arg info) flags) + intro result + cases result <;> exact TcM.PreservesInferOnly.pure _ + | fvar id name info => + simp only + split + · apply TcM.PreservesInferOnly.bind + (helpers.finishApp (.fvar id name info) args 0) + intro rebuilt + apply TcM.PreservesInferOnly.bind (helpers.iota rebuilt flags) + intro result + cases result <;> exact TcM.PreservesInferOnly.pure _ + · apply TcM.PreservesInferOnly.bind + (helpers.iota (.app fn arg info) flags) + intro result + cases result <;> exact TcM.PreservesInferOnly.pure _ + | sort u info => + simp only + split + · apply TcM.PreservesInferOnly.bind + (helpers.finishApp (.sort u info) args 0) + intro rebuilt + apply TcM.PreservesInferOnly.bind (helpers.iota rebuilt flags) + intro result + cases result <;> exact TcM.PreservesInferOnly.pure _ + · apply TcM.PreservesInferOnly.bind + (helpers.iota (.app fn arg info) flags) + intro result + cases result <;> exact TcM.PreservesInferOnly.pure _ + | const id levels info => + simp only + split + · apply TcM.PreservesInferOnly.bind + (helpers.finishApp (.const id levels info) args 0) + intro rebuilt + apply TcM.PreservesInferOnly.bind (helpers.iota rebuilt flags) + intro result + cases result <;> exact TcM.PreservesInferOnly.pure _ + · apply TcM.PreservesInferOnly.bind + (helpers.iota (.app fn arg info) flags) + intro result + cases result <;> exact TcM.PreservesInferOnly.pure _ + | app f a info => + simp only + split + · apply TcM.PreservesInferOnly.bind + (helpers.finishApp (.app f a info) args 0) + intro rebuilt + apply TcM.PreservesInferOnly.bind (helpers.iota rebuilt flags) + intro result + cases result <;> exact TcM.PreservesInferOnly.pure _ + · apply TcM.PreservesInferOnly.bind + (helpers.iota (.app fn arg info) flags) + intro result + cases result <;> exact TcM.PreservesInferOnly.pure _ + | all name bi ty body info => + simp only + split + · apply TcM.PreservesInferOnly.bind + (helpers.finishApp (.all name bi ty body info) args 0) + intro rebuilt + apply TcM.PreservesInferOnly.bind (helpers.iota rebuilt flags) + intro result + cases result <;> exact TcM.PreservesInferOnly.pure _ + · apply TcM.PreservesInferOnly.bind + (helpers.iota (.app fn arg info) flags) + intro result + cases result <;> exact TcM.PreservesInferOnly.pure _ + | letE name ty value body nondep info => + simp only + split + · apply TcM.PreservesInferOnly.bind + (helpers.finishApp (.letE name ty value body nondep info) args 0) + intro rebuilt + apply TcM.PreservesInferOnly.bind (helpers.iota rebuilt flags) + intro result + cases result <;> exact TcM.PreservesInferOnly.pure _ + · apply TcM.PreservesInferOnly.bind + (helpers.iota (.app fn arg info) flags) + intro result + cases result <;> exact TcM.PreservesInferOnly.pure _ + | prj id field value info => + simp only + split + · apply TcM.PreservesInferOnly.bind + (helpers.finishApp (.prj id field value info) args 0) + intro rebuilt + apply TcM.PreservesInferOnly.bind (helpers.iota rebuilt flags) + intro result + cases result <;> exact TcM.PreservesInferOnly.pure _ + · apply TcM.PreservesInferOnly.bind + (helpers.iota (.app fn arg info) flags) + intro result + cases result <;> exact TcM.PreservesInferOnly.pure _ + | nat value blob info => + simp only + split + · apply TcM.PreservesInferOnly.bind + (helpers.finishApp (.nat value blob info) args 0) + intro rebuilt + apply TcM.PreservesInferOnly.bind (helpers.iota rebuilt flags) + intro result + cases result <;> exact TcM.PreservesInferOnly.pure _ + · apply TcM.PreservesInferOnly.bind + (helpers.iota (.app fn arg info) flags) + intro result + cases result <;> exact TcM.PreservesInferOnly.pure _ + | str value blob info => + simp only + split + · apply TcM.PreservesInferOnly.bind + (helpers.finishApp (.str value blob info) args 0) + intro rebuilt + apply TcM.PreservesInferOnly.bind (helpers.iota rebuilt flags) + intro result + cases result <;> exact TcM.PreservesInferOnly.pure _ + · apply TcM.PreservesInferOnly.bind + (helpers.iota (.app fn arg info) flags) + intro result + cases result <;> exact TcM.PreservesInferOnly.pure _ + +theorem whnfNoDeltaReducersStep_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (helpers : WhnfHelperPolicyAt methods) + (flags : WhnfFlags) (mode : NatSuccMode) (source : KExpr .anon) : + ((whnfNoDeltaReducersStep flags mode source).run methods).PreservesInferOnly := by + unfold whnfNoDeltaReducersStep + simp only [ReaderT.run_bind] + apply TcM.PreservesInferOnly.bind + (tryProjAppReduceFinished_preservesInferOnly hmethods helpers.proj + helpers.finishApp source flags) + intro projection + cases projection with + | some reduced => + exact TcM.PreservesInferOnly.pure (BoundedStep.next reduced) + | none => + apply TcM.PreservesInferOnly.bind (helpers.bitvec source) + intro bitvec + cases bitvec with + | some reduced => + exact TcM.PreservesInferOnly.pure (BoundedStep.next reduced) + | none => + apply TcM.PreservesInferOnly.bind (helpers.nat source mode) + intro nat + cases nat with + | some reduced => + exact TcM.PreservesInferOnly.pure (BoundedStep.next reduced) + | none => + apply TcM.PreservesInferOnly.bind (helpers.native source) + intro native + cases native with + | some reduced => + exact TcM.PreservesInferOnly.pure (BoundedStep.next reduced) + | none => + apply TcM.PreservesInferOnly.bind (helpers.string source) + intro string + cases string with + | some reduced => + exact TcM.PreservesInferOnly.pure + (BoundedStep.next reduced) + | none => + cases hfull : flags.isFull with + | true => + simp only [if_true] + apply TcM.PreservesInferOnly.bind + (helpers.projectionDefinition source) + intro projectionDefinition + cases projectionDefinition with + | some reduced => + exact TcM.PreservesInferOnly.pure + (BoundedStep.next reduced) + | none => + apply TcM.PreservesInferOnly.bind + (helpers.quot source) + intro quotient + cases quotient <;> + exact TcM.PreservesInferOnly.pure _ + | false => + simp only [Bool.false_eq] + apply TcM.PreservesInferOnly.bind + (helpers.quot source) + intro quotient + cases quotient <;> exact TcM.PreservesInferOnly.pure _ + +def WhnfHelperPolicyAt.noDeltaPolicy + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (helpers : WhnfHelperPolicyAt methods) : + WhnfNoDeltaPolicyAt methods where + transient := isTransientNatLiteralWork_preservesInferOnly + coreStep := whnfCoreWithFlagsStep_preservesInferOnly hmethods helpers + noDeltaReducers := + whnfNoDeltaReducersStep_preservesInferOnly hmethods helpers + +theorem whnfWithNatSuccModeStep_preservesInferOnly + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (helpers : WhnfHelperPolicyAt methods) + (mode : NatSuccMode) + (state : KExpr .anon × Std.HashSet Address) : + ((whnfWithNatSuccModeStep mode state).run methods).PreservesInferOnly := by + rcases state with ⟨source, seen⟩ + unfold whnfWithNatSuccModeStep + simp only [ReaderT.run_bind] + let noDeltaPolicy := helpers.noDeltaPolicy hmethods + apply TcM.PreservesInferOnly.bind + (whnfNoDeltaImpl_preservesInferOnly noDeltaPolicy source .FULL mode) + intro reduced + split + · exact TcM.PreservesInferOnly.pure (BoundedStep.done reduced) + · apply TcM.PreservesInferOnly.bind (helpers.native reduced) + intro native + cases native with + | some result => + exact TcM.PreservesInferOnly.pure (BoundedStep.next (result, _)) + | none => + apply TcM.PreservesInferOnly.bind (helpers.bitvec reduced) + intro bitvec + cases bitvec with + | some result => + exact TcM.PreservesInferOnly.pure (BoundedStep.next (result, _)) + | none => + apply TcM.PreservesInferOnly.bind (helpers.nat reduced mode) + intro nat + cases nat with + | some result => + exact TcM.PreservesInferOnly.pure + (BoundedStep.next (result, _)) + | none => + apply TcM.PreservesInferOnly.bind (helpers.decidable reduced) + intro decidable + cases decidable with + | some result => + exact TcM.PreservesInferOnly.pure + (BoundedStep.next (result, _)) + | none => + apply TcM.PreservesInferOnly.bind (helpers.string reduced) + intro string + cases string with + | some result => + exact TcM.PreservesInferOnly.pure + (BoundedStep.next (result, _)) + | none => + apply TcM.PreservesInferOnly.bind + (helpers.natOffset reduced) + intro offset + cases offset with + | some result => + exact TcM.PreservesInferOnly.pure + (BoundedStep.done result) + | none => + apply TcM.PreservesInferOnly.bind + (helpers.delta reduced) + intro delta + cases delta with + | some result => + exact TcM.PreservesInferOnly.pure + (BoundedStep.next (result, _)) + | none => + exact TcM.PreservesInferOnly.pure + (BoundedStep.done reduced) + +def WhnfHelperPolicyAt.reductionPolicy + {methods : Methods .anon} (hmethods : methods.PreservesInferOnly) + (helpers : WhnfHelperPolicyAt methods) : + WhnfReductionPolicyAt methods where + toWhnfNoDeltaPolicyAt := helpers.noDeltaPolicy hmethods + fullStep := whnfWithNatSuccModeStep_preservesInferOnly hmethods helpers + +end RecM + +end Ix.Tc diff --git a/Ix/Tc/Verify/DefEq.lean b/Ix/Tc/Verify/DefEq.lean index 75669c8b3..2cb1f27d3 100644 --- a/Ix/Tc/Verify/DefEq.lean +++ b/Ix/Tc/Verify/DefEq.lean @@ -703,6 +703,20 @@ structure ScopedKernelSuffixModel (trProj : RawProjRel) (world : VerifyWorld) where keys : WhnfContextKeys StateInScope : TcState .anon → Prop + /-- A real suffix-key execution keeps the next checker state inside the + same finite run domain. This field is needed independently of semantic + representation: subsequent key operations run from the memo-updated + state, including after partial computations. -/ + preservesCtx : ∀ {before after : TcState .anon} {lbr : UInt64} + {ctxAddr : Address}, + StateInScope before → + TcM.ctxAddrForLbr lbr before = .ok ctxAddr after → + StateInScope after + /-- Ordinary cache, intern, and bookkeeping updates preserve scope when + they fix the complete digest-relevant state projection. -/ + preservesFrame : ∀ {before after : TcState .anon}, + StateInScope before → ContextDigestFrame before after → + StateInScope after representsCtx : ∀ {before after : TcState .anon} {lbr : UInt64} {ctxAddr : Address} {Delta : KVLCtx}, StateInScope before → @@ -740,6 +754,109 @@ structure ScopedKernelSuffixModel (trProj : RawProjRel) IsPropMeaning trProj world keys.uvars Delta source answer → IsPropMeaning trProj world keys.uvars Delta' source answer +/-- The state-independent semantic half shared by the legacy global model +and the run-scoped model. Cache provenance needs only these transports; +key construction is kept in the separate global/scoped operational fields so +it cannot accidentally erase the run domain. -/ +structure KernelSuffixTransports (trProj : RawProjRel) + (world : VerifyWorld) where + keys : WhnfContextKeys + 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 KernelSuffixModel + +def transports {trProj : RawProjRel} {world : VerifyWorld} + (model : KernelSuffixModel trProj world) : + KernelSuffixTransports trProj world where + keys := model.keys + whnfTransport := model.whnfTransport + inferTransport := model.inferTransport + defEqTransport := model.defEqTransport + isPropTransport := model.isPropTransport + +end KernelSuffixModel + +namespace ScopedKernelSuffixModel + +/-- A production reset returns to the finite suffix model's state domain. +This is an operational obligation because an arbitrary scoped model may +choose any predicate for `StateInScope`. -/ +def ResetPreservesScope + {trProj : RawProjRel} {world : VerifyWorld} + (model : ScopedKernelSuffixModel trProj world) : Prop := + ∀ {before after : TcState .anon}, + model.StateInScope before → + TcM.reset before = .ok () after → + model.StateInScope after + +def transports {trProj : RawProjRel} {world : VerifyWorld} + (model : ScopedKernelSuffixModel trProj world) : + KernelSuffixTransports trProj world where + keys := model.keys + whnfTransport := model.whnfTransport + inferTransport := model.inferTransport + defEqTransport := model.defEqTransport + isPropTransport := model.isPropTransport + +end ScopedKernelSuffixModel + +/-- The ordinary checker invariant refined by membership in one explicit +suffix-model state domain. K2S uses this predicate at every model-dependent +key boundary; the unscoped invariant remains available for model-independent +helpers and legacy compatibility theorems. -/ +def ScopedWhnfStateInv {trProj : RawProjRel} {world : VerifyWorld} + (model : ScopedKernelSuffixModel trProj world) + (layer : WhnfLayer) (semantics : CacheSemantics) (support : RunSupport) + (Delta : KVLCtx) (s : TcState .anon) : Prop := + WhnfStateInv layer semantics trProj world support model.keys.uvars Delta s ∧ + model.StateInScope s + +namespace ScopedWhnfStateInv + +theorem base + {trProj : RawProjRel} {world : VerifyWorld} + {model : ScopedKernelSuffixModel trProj world} + {layer : WhnfLayer} {semantics : CacheSemantics} {support : RunSupport} + {Delta : KVLCtx} {s : TcState .anon} + (h : ScopedWhnfStateInv model layer semantics support Delta s) : + WhnfStateInv layer semantics trProj world support model.keys.uvars Delta + s := + h.1 + +theorem inScope + {trProj : RawProjRel} {world : VerifyWorld} + {model : ScopedKernelSuffixModel trProj world} + {layer : WhnfLayer} {semantics : CacheSemantics} {support : RunSupport} + {Delta : KVLCtx} {s : TcState .anon} + (h : ScopedWhnfStateInv model layer semantics support Delta s) : + model.StateInScope s := + h.2 + +end ScopedWhnfStateInv + namespace ScopedKernelSuffixModel /-- Construct the genuinely run-scoped joint model. State membership is @@ -752,6 +869,13 @@ def finiteOperational {trProj : RawProjRel} {world : VerifyWorld} ScopedKernelSuffixModel trProj world where keys := scopedOperationalWhnfContextKeys spec scope StateInScope before := spec.StateValid before ∧ scope.Captures before + preservesCtx hscope hrun := + ⟨spec.preserves hscope.1 hrun, + ContextDigestScope.Captures.contextKeyFrame hscope.2 + (TcM.ctxAddrForLbr_frame hrun)⟩ + preservesFrame hscope hframe := + ⟨spec.framePreserves hscope.1 hframe, + ContextDigestScope.Captures.contextDigestFrame hscope.2 hframe⟩ representsCtx hscope hctx hrun := scopedOperationalWhnfContextKeys.representsCtx hscope.1 hscope.2 hctx hrun represents hscope hctx hrun := @@ -802,6 +926,111 @@ def toKernelSuffixModel {trProj : RawProjRel} {world : VerifyWorld} end ScopedKernelSuffixModel +namespace TcM + +/-- A scoped suffix model interprets and preserves one direct context-key +execution from a state already admitted by the finite run domain. -/ +theorem ctxAddrForLbr_scoped_model_matches_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} + {support : RunSupport} (model : ScopedKernelSuffixModel trProj world) + {Delta : KVLCtx} {source : KExpr .anon} {s : TcState .anon} : + TcM.WF + (ScopedWhnfStateInv model layer semantics support 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.1 + match hrun : TcM.ctxAddrForLbr source.lbr s with + | .ok ctxAddr s' => + rw [hrun] at hwf + exact ⟨⟨hwf.1, model.preservesCtx hI.2 hrun⟩, + model.representsCtx hI.2 hI.1.2.1 hrun, hwf.2⟩ + | .error err s' => + obtain ⟨ctxAddr, after, htotal⟩ := + TcM.ctxAddrForLbr_total source.lbr s + rw [htotal] at hrun + contradiction + +/-- Scoped operational matching for the WHNF-shaped key shared by WHNF and +inference. -/ +theorem whnfKey_scoped_model_matches_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} + {support : RunSupport} (model : ScopedKernelSuffixModel trProj world) + {Delta : KVLCtx} {source : KExpr .anon} {s : TcState .anon} : + TcM.WF + (ScopedWhnfStateInv model layer semantics support Delta) s + (TcM.whnfKey source) + (fun key s' => + model.keys.Matches trProj world s Delta source key ∧ + ContextKeyFrame s s') := by + intro hI + have hwf := TcM.whnfKey_wf + (layer := layer) (semantics := semantics) (trProj := trProj) + (world := world) (support := support) (uvars := model.keys.uvars) + (Δ := Delta) (source := source) (s := s) hI.1 + match hrun : TcM.whnfKey source s with + | .ok key s' => + rw [hrun] at hwf + have hctxRun := TcM.whnfKey_ctx hrun + exact ⟨⟨hwf.1, model.preservesCtx hI.2 hctxRun⟩, + ⟨⟨hI.1.2.1, model.represents hI.2 hI.1.2.1 hrun, ⟨s', hrun⟩⟩, + hwf.2.2⟩⟩ + | .error err s' => + obtain ⟨ctxAddr, after, htotal⟩ := + TcM.ctxAddrForLbr_total source.lbr s + have hkeyTotal : TcM.whnfKey source s = + .ok (source.addr, ctxAddr) after := by + unfold TcM.whnfKey + change EStateM.bind (TcM.ctxAddrForLbr source.lbr) + (fun addr => pure (source.addr, addr)) s = _ + unfold EStateM.bind + rw [htotal] + rfl + rw [hkeyTotal] at hrun + contradiction + +/-- Scoped operational matching for DefEq's bare context key. -/ +theorem defEqCtxKey_scoped_model_matches_wf + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} + {support : RunSupport} (model : ScopedKernelSuffixModel trProj world) + {Delta : KVLCtx} {a b : KExpr .anon} {s : TcState .anon} : + TcM.WF + (ScopedWhnfStateInv model layer semantics support 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.1 + 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, model.preservesCtx hI.2 hctxRun⟩, + ⟨⟨hI.1.2.1, model.representsCtx hI.2 hI.1.2.1 hctxRun, + ⟨s', hrun⟩⟩, hwf.2⟩⟩ + | .error err s' => + obtain ⟨ctxAddr, after, htotal⟩ := + TcM.ctxAddrForLbr_total (max a.lbr b.lbr) s + have hkeyTotal : TcM.defEqCtxKey a b s = .ok ctxAddr after := by + simpa [TcM.defEqCtxKey] using htotal + rw [hkeyTotal] at hrun + contradiction + +end TcM + namespace KernelSuffixModel /-- Forget the K2 transports and recover exactly the K1 suffix model. -/ @@ -943,6 +1172,12 @@ def isPropCacheSemantics (keys : WhnfContextKeys) (trProj : RawProjRel) blockError := by intro authority support block err exact fallback.blockError authority support block err + blockSuccess := by + intro authority support block h + exact fallback.blockSuccess authority support block h + blockSuccessSound := by + intro authority support block h + exact fallback.blockSuccessSound authority support block h /-- Exact validity for full/cheap def-eq maps and the negative failure set. -/ def DefEqCacheValid (keys : WhnfContextKeys) (trProj : RawProjRel) @@ -999,6 +1234,12 @@ def defEqCacheSemantics (keys : WhnfContextKeys) (trProj : RawProjRel) blockError := by intro authority support block err exact fallback.blockError authority support block err + blockSuccess := by + intro authority support block h + exact fallback.blockSuccess authority support block h + blockSuccessSound := by + intro authority support block h + exact fallback.blockSuccessSound authority support block h /-- Canonical K1+K2 semantic stack. K1's WHNF and fixed-universe unfold layers stay outermost; inference and def-eq occupy precisely the fallback @@ -1278,12 +1519,12 @@ theorem defEqMeaning {keys : WhnfContextKeys} {trProj : RawProjRel} end CacheProvenance -namespace KernelSuffixModel +namespace KernelSuffixTransports /-- 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) + {support : RunSupport} (model : KernelSuffixTransports trProj world) (hcollision : support.CollisionFree) {Delta : KVLCtx} {source : KExpr .anon} {answer : Bool} {ctxAddr : Address} @@ -1317,7 +1558,7 @@ theorem isPropProvenance {trProj : RawProjRel} {world : VerifyWorld} 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) + {support : RunSupport} (model : KernelSuffixTransports trProj world) (hcollision : support.CollisionFree) {kind : ExprCacheKind} (hkind : kind.IsInfer) {Delta : KVLCtx} {source ty : KExpr .anon} @@ -1365,7 +1606,7 @@ theorem inferProvenance {trProj : RawProjRel} {world : VerifyWorld} 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) + {support : RunSupport} (model : KernelSuffixTransports trProj world) (hcollision : support.CollisionFree) (kind : DefEqCacheKind) {Delta : KVLCtx} {a b : KExpr .anon} {answer : Bool} {ctxAddr : Address} @@ -1431,7 +1672,7 @@ theorem defEqProvenance {trProj : RawProjRel} {world : VerifyWorld} 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) + {support : RunSupport} (model : KernelSuffixTransports trProj world) {a b : KExpr .anon} {ctxAddr : Address} (ha : support a) (hb : support b) (hreferences : @@ -1466,6 +1707,84 @@ theorem defEqFailureProvenance {trProj : RawProjRel} {world : VerifyWorld} WhnfCacheValid, unfoldCacheSemantics, UnfoldCacheValid, inferCacheSemantics, InferCacheValid] using hvalid +end KernelSuffixTransports + +namespace KernelSuffixModel + +/-- Legacy global-model spelling retained as a compatibility wrapper around +the state-independent transport proof. -/ +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) := + model.transports.isPropProvenance hcollision hsource hctx hmeaning + hreferences + +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) := + model.transports.inferProvenance hcollision hkind hsource hty hmatch + hmeaning hreferences + +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) := + model.transports.defEqProvenance hcollision kind ha hb hctx hmeaning + hreferences + +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)) := + model.transports.defEqFailureProvenance ha hb hreferences + end KernelSuffixModel namespace RecM diff --git a/Ix/Tc/Verify/Driver/BooleanAcceptance.lean b/Ix/Tc/Verify/Driver/BooleanAcceptance.lean new file mode 100644 index 000000000..c7380b4ae --- /dev/null +++ b/Ix/Tc/Verify/Driver/BooleanAcceptance.lean @@ -0,0 +1,629 @@ +import Ix.Tc.Verify.Driver.SupportedAcceptance +import Ix.Tc.Verify.Inductive.EnumerationAcceptance + +/-! +# Certificate-backed Boolean driver acceptance + +This module connects the concrete E2 Boolean generation certificate to the +E3-S production-driver adapter. The runtime checker call remains a required +gate, but semantic authority for these two coordinated blocks comes from the +explicit `InductiveOracle` values proved by the E2 fixture. In particular, +the proof does not reinterpret the runtime cache order as a topological +semantic schedule: the recursor work item is physically enumerated first, +while its successful checker call also validates and caches the family block. + +The staged baseline below has the constructively generated Boolean Theory +environment and an empty trust predicate. Its `VEnv.WF` field is derived +from `CertifiedGenerationTransaction`; it is not an assumed target-world +well-formedness premise. Residual oracles are then restaged at each monotone +current world and admit exactly the exact block members not already trusted. +-/ + +namespace Ix.Tc + +namespace BooleanEnumerationFixture + +local instance booleanAddressDecidableEq : DecidableEq Address := + fun left right => + if h : left == right then + .isTrue (eq_of_beq h) + else + .isFalse fun equality => h (by + cases equality + exact beq_self_eq_true left) + +/- Executable equality is used only to discharge closed native facts about +the finite serialized fixture. These instances compare the actual inductive +data; no address-hash injectivity principle is involved. -/ +deriving instance DecidableEq for Ixon.Univ +deriving instance DecidableEq for Ixon.Expr +deriving instance DecidableEq for Ixon.Definition +deriving instance DecidableEq for Ixon.RecursorRule +deriving instance DecidableEq for Ixon.Recursor +deriving instance DecidableEq for Ixon.Axiom +deriving instance DecidableEq for Ixon.Quotient +deriving instance DecidableEq for Ixon.Constructor +deriving instance DecidableEq for Ixon.Inductive +deriving instance DecidableEq for Ixon.InductiveProj +deriving instance DecidableEq for Ixon.ConstructorProj +deriving instance DecidableEq for Ixon.RecursorProj +deriving instance DecidableEq for Ixon.DefinitionProj +deriving instance DecidableEq for Ixon.MutConst +deriving instance DecidableEq for Ixon.ConstantInfo +deriving instance DecidableEq for Ixon.Constant +deriving instance DecidableEq for Ixon.LazyConstant +deriving instance DecidableEq for AnonWorkItem +deriving instance DecidableEq for CheckResult + +/-- The E2-certified Theory result, with no concrete Ix declaration trusted +yet. Catalog, block table, names, and the empty trust predicate are inherited +unchanged from the concrete ingress fixture. -/ +def stagedWorld : VerifyWorld := + { world with + venv := theoryAfter + venvWF := transaction.facts.afterWF } + +theorem world_le_staged : world ≤ stagedWorld where + catalog := rfl + blocks := rfl + nameOf := rfl + trusted := fun h => h + venv := transaction.facts.envLE + +/-- The two work rows emitted by production enumeration, in their actual +address order. -/ +def recursorItem : AnonWorkItem := + .block recursorBlockAddress recursorId.addr #[recursorId.addr] + +def familyItem : AnonWorkItem := + .block familyBlockAddress familyId.addr + #[familyId.addr, falseId.addr, trueId.addr] + +def booleanWork : Array AnonWorkItem := #[recursorItem, familyItem] + +private theorem buildAnonWorkNative : + buildAnonWork recursorIxonEnv = .ok booleanWork := by + native_decide + +theorem buildAnonWork_eq : + buildAnonWork recursorIxonEnv = .ok booleanWork := + buildAnonWorkNative + +/-! ## Serialized source integrity -/ + +def familyProjectionConstant : Ixon.Constant := + ⟨.iPrj ⟨0, familyBlockAddress⟩, #[], #[], #[]⟩ + +def falseProjectionConstant : Ixon.Constant := + ⟨.cPrj ⟨0, 0, familyBlockAddress⟩, #[], #[], #[]⟩ + +def trueProjectionConstant : Ixon.Constant := + ⟨.cPrj ⟨0, 1, familyBlockAddress⟩, #[], #[], #[]⟩ + +def recursorProjectionConstant : Ixon.Constant := + ⟨.rPrj ⟨0, recursorBlockAddress⟩, #[], #[], #[]⟩ + +private theorem sourceAddressesNative : + orderedAnonConstAddrs recursorIxonEnv = + #[recursorBlockAddress, trueId.addr, familyBlockAddress, + recursorId.addr, falseId.addr, familyId.addr] := by + native_decide + +theorem sourceAddresses : + orderedAnonConstAddrs recursorIxonEnv = + #[recursorBlockAddress, trueId.addr, familyBlockAddress, + recursorId.addr, falseId.addr, familyId.addr] := + sourceAddressesNative + +private theorem sourceKeysNative : + recursorIxonEnv.consts.keys = + [recursorBlockAddress, recursorId.addr, falseId.addr, + trueId.addr, familyBlockAddress, familyId.addr] := by + native_decide + +private theorem sourceAddressesNodupNative : + (#[recursorBlockAddress, trueId.addr, familyBlockAddress, + recursorId.addr, falseId.addr, familyId.addr] : Array Address).toList.Nodup := by + native_decide + +private theorem recursorTargetsNonemptyNative : + (anonBlockTargets recursorBlockAddress #[.recr recursorIxon]).size > 0 := by + native_decide + +private theorem familyTargetsNonemptyNative : + (anonBlockTargets familyBlockAddress #[.indc familyIxon]).size > 0 := by + native_decide + +/-- The unsorted map-key view has the same finite source domain. This form +is used to classify arbitrary successful lookups, independently of the +ordering implementation used by `buildAnonWork`. -/ +theorem sourceKeys : + recursorIxonEnv.consts.keys = + [recursorBlockAddress, recursorId.addr, falseId.addr, + trueId.addr, familyBlockAddress, familyId.addr] := + sourceKeysNative + +private theorem familyBlockEntry : + ExactAnonEntry recursorIxonEnv familyBlockAddress + familyBlockConstant := by + refine ⟨by native_decide, + Ixon.LazyConstant.ofConstant familyBlockConstant, + by native_decide, rfl, by native_decide⟩ + +private theorem recursorBlockEntry : + ExactAnonEntry recursorIxonEnv recursorBlockAddress + recursorBlockConstant := by + refine ⟨by native_decide, + Ixon.LazyConstant.ofConstant recursorBlockConstant, + by native_decide, rfl, by native_decide⟩ + +private theorem familyProjectionEntry : + ExactAnonEntry recursorIxonEnv familyId.addr + familyProjectionConstant := by + refine ⟨by native_decide, + Ixon.LazyConstant.ofConstant familyProjectionConstant, + by native_decide, rfl, by native_decide⟩ + +private theorem falseProjectionEntry : + ExactAnonEntry recursorIxonEnv falseId.addr + falseProjectionConstant := by + refine ⟨by native_decide, + Ixon.LazyConstant.ofConstant falseProjectionConstant, + by native_decide, rfl, by native_decide⟩ + +private theorem trueProjectionEntry : + ExactAnonEntry recursorIxonEnv trueId.addr + trueProjectionConstant := by + refine ⟨by native_decide, + Ixon.LazyConstant.ofConstant trueProjectionConstant, + by native_decide, rfl, by native_decide⟩ + +private theorem recursorProjectionEntry : + ExactAnonEntry recursorIxonEnv recursorId.addr + recursorProjectionConstant := by + refine ⟨by native_decide, + Ixon.LazyConstant.ofConstant recursorProjectionConstant, + by native_decide, rfl, by native_decide⟩ + +/-- Every materialized source entry in the finite Boolean environment is one +of the two block envelopes or one of their four generated projections. -/ +private theorem sourceEntryCases {addr : Address} {constant : Ixon.Constant} + (hentry : ExactAnonEntry recursorIxonEnv addr constant) : + (addr = recursorBlockAddress ∧ constant = recursorBlockConstant) ∨ + (addr = trueId.addr ∧ constant = trueProjectionConstant) ∨ + (addr = familyBlockAddress ∧ constant = familyBlockConstant) ∨ + (addr = recursorId.addr ∧ constant = recursorProjectionConstant) ∨ + (addr = falseId.addr ∧ constant = falseProjectionConstant) ∨ + (addr = familyId.addr ∧ constant = familyProjectionConstant) := by + have haddr := hentry.1 + rw [sourceAddresses] at haddr + simp at haddr + rcases haddr with haddr | haddr | haddr | haddr | haddr | haddr + · subst addr + exact .inl ⟨rfl, + ExactAnonEntry.constant_unique hentry recursorBlockEntry⟩ + · subst addr + exact .inr (.inl ⟨rfl, + ExactAnonEntry.constant_unique hentry trueProjectionEntry⟩) + · subst addr + exact .inr (.inr (.inl ⟨rfl, + ExactAnonEntry.constant_unique hentry familyBlockEntry⟩)) + · subst addr + exact .inr (.inr (.inr (.inl ⟨rfl, + ExactAnonEntry.constant_unique hentry recursorProjectionEntry⟩))) + · subst addr + exact .inr (.inr (.inr (.inr (.inl ⟨rfl, + ExactAnonEntry.constant_unique hentry falseProjectionEntry⟩)))) + · subst addr + exact .inr (.inr (.inr (.inr (.inr ⟨rfl, + ExactAnonEntry.constant_unique hentry familyProjectionEntry⟩)))) + +/-- The concrete serialized Boolean environment satisfies the exact source +integrity contract used by production work enumeration. -/ +def sourceWF : AnonWorkEnvWF recursorIxonEnv where + keysNodup := by + rw [sourceAddresses] + exact sourceAddressesNodupNative + entry := by + intro addr haddr + rw [sourceAddresses] at haddr + simp at haddr + rcases haddr with rfl | rfl | rfl | rfl | rfl | rfl + · exact ⟨recursorBlockConstant, recursorBlockEntry⟩ + · exact ⟨trueProjectionConstant, trueProjectionEntry⟩ + · exact ⟨familyBlockConstant, familyBlockEntry⟩ + · exact ⟨recursorProjectionConstant, recursorProjectionEntry⟩ + · exact ⟨falseProjectionConstant, falseProjectionEntry⟩ + · exact ⟨familyProjectionConstant, familyProjectionEntry⟩ + blocksNonempty := by + intro addr constant members hentry hinfo + rcases sourceEntryCases hentry with + ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | + ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ + · cases hinfo + exact recursorTargetsNonemptyNative + · simp [trueProjectionConstant] at hinfo + · cases hinfo + exact familyTargetsNonemptyNative + · simp [recursorProjectionConstant] at hinfo + · simp [falseProjectionConstant] at hinfo + · simp [familyProjectionConstant] at hinfo + projectionComplete := by + intro block constant members target hentry hinfo htarget + rcases sourceEntryCases hentry with + ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | + ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ + · cases hinfo + simp [anonBlockTargets, anonMemberTargets, recursorIxon] at htarget + subst target + exact ⟨recursorProjectionConstant, recursorProjectionEntry, rfl⟩ + · simp [trueProjectionConstant] at hinfo + · cases hinfo + simp [anonBlockTargets, anonMemberTargets, familyIxon] at htarget + rcases htarget with htarget | ⟨index, hbound, htarget⟩ + · subst target + exact ⟨familyProjectionConstant, familyProjectionEntry, rfl⟩ + · have hindex : index = 0 ∨ index = 1 := by omega + rcases hindex with rfl | rfl + · subst target + exact ⟨falseProjectionConstant, falseProjectionEntry, rfl⟩ + · subst target + exact ⟨trueProjectionConstant, trueProjectionEntry, rfl⟩ + · simp [recursorProjectionConstant] at hinfo + · simp [falseProjectionConstant] at hinfo + · simp [familyProjectionConstant] at hinfo + projectionOwned := by + intro addr constant owner hentry howner + rcases sourceEntryCases hentry with + ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | + ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ + · simp [recursorBlockConstant, projectionOwner?] at howner + · simp [trueProjectionConstant, projectionOwner?] at howner + subst owner + exact ⟨familyBlockConstant, #[.indc familyIxon], familyBlockEntry, + rfl, by + simp [anonBlockTargets, anonMemberTargets, familyIxon, trueId] + right + exact ⟨1, by omega, rfl⟩⟩ + · simp [familyBlockConstant, projectionOwner?] at howner + · simp [recursorProjectionConstant, projectionOwner?] at howner + subst owner + exact ⟨recursorBlockConstant, #[.recr recursorIxon], + recursorBlockEntry, rfl, by + simp [anonBlockTargets, anonMemberTargets, recursorIxon, + recursorId]⟩ + · simp [falseProjectionConstant, projectionOwner?] at howner + subst owner + exact ⟨familyBlockConstant, #[.indc familyIxon], familyBlockEntry, + rfl, by + simp [anonBlockTargets, anonMemberTargets, familyIxon, falseId] + right + exact ⟨0, by omega, rfl⟩⟩ + · simp [familyProjectionConstant, projectionOwner?] at howner + subst owner + exact ⟨familyBlockConstant, #[.indc familyIxon], familyBlockEntry, + rfl, by + simp [anonBlockTargets, anonMemberTargets, familyIxon, familyId]⟩ + +theorem expectedAnonWork_eq : + expectedAnonWork recursorIxonEnv = booleanWork := by + exact Except.ok.inj + (sourceWF.buildAnonWork_eq_expected.symm.trans buildAnonWork_eq) + +/-- Every generated projection collapses directly to a non-projection block +envelope, while both envelopes are fixed points. Successful lookups are +first reduced to the exact finite source-key domain; unknown addresses are +fixed points by definition. -/ +def blockOfIdempotent : IxonEnv.BlockOfIdempotent recursorIxonEnv := by + intro addr + cases hlookup : recursorIxonEnv.getConst? addr with + | none => + simp [blockOfAddr, hlookup] + | some constant => + have hraw : ∃ lazy, + recursorIxonEnv.consts.get? addr = some lazy := by + have hbind : + (recursorIxonEnv.consts.get? addr).bind + Ixon.LazyConstant.get? = some constant := by + simpa only [Ixon.Env.getConst?] using hlookup + rw [Option.bind_eq_some_iff] at hbind + obtain ⟨lazy, hstored, _⟩ := hbind + exact ⟨lazy, hstored⟩ + obtain ⟨lazy, hraw⟩ := hraw + have hmem : addr ∈ recursorIxonEnv.consts := + (Std.HashMap.getElem?_eq_some_iff.mp hraw).choose + have hkey : addr ∈ recursorIxonEnv.consts.keys := + Std.HashMap.mem_keys.mpr hmem + rw [sourceKeys] at hkey + simp at hkey + rcases hkey with rfl | rfl | rfl | rfl | rfl | rfl + · simp [blockOfAddr, recursorBlockEntry.getConst, + recursorBlockConstant] + · simp [blockOfAddr, recursorProjectionEntry.getConst, + recursorBlockEntry.getConst, recursorProjectionConstant, + recursorBlockConstant] + · simp [blockOfAddr, falseProjectionEntry.getConst, + familyBlockEntry.getConst, falseProjectionConstant, + familyBlockConstant] + · simp [blockOfAddr, trueProjectionEntry.getConst, + familyBlockEntry.getConst, trueProjectionConstant, + familyBlockConstant] + · simp [blockOfAddr, familyBlockEntry.getConst, + familyBlockConstant] + · simp [blockOfAddr, familyProjectionEntry.getConst, + familyBlockEntry.getConst, familyProjectionConstant, + familyBlockConstant] + +/-- Exact collapsed dependency catalog used by the Boolean driver theorem. -/ +def dependencyGraph : DependencyCatalog := + IxonEnv.dependencyCatalog recursorIxonEnv blockOfIdempotent + +/-- The closed Boolean fixture has no external declaration assumptions. -/ +def noAssumptions : FiniteAddressSet := ⟨[], by simp⟩ + +/-- Exact physical block identity, rebased to the staged semantic baseline. -/ +def stagedExactFamily : + ExactCheckBlock stagedWorld familyBlockId familyMembers .inductive' := + exactFamilyBlock.rebaseWorld world_le_staged + +def stagedExactRecursor : + ExactCheckBlock stagedWorld recursorBlockId recursorMembers .recursor := + exactRecursorBlock.rebaseWorld world_le_staged + +theorem familyWorkCatalog : + familyItem.MatchesBlockCatalog stagedWorld.blocks := by + refine ⟨familyId, #[falseId, trueId], ?_, rfl, ?_⟩ + · simpa [stagedWorld, familyMembers_eq] using + stagedExactFamily.blockLookup + · simp + +theorem recursorWorkCatalog : + recursorItem.MatchesBlockCatalog stagedWorld.blocks := by + refine ⟨recursorId, #[], ?_, rfl, ?_⟩ + · simpa [stagedWorld, recursorMembers_eq] using + stagedExactRecursor.blockLookup + · simp + +/-! ## Closed dependency graph -/ + +theorem family_no_dependencies {target : Address} : + ¬dependencyGraph.dependsOn familyBlockAddress target := by + rintro ⟨constant, hget, hsemantic⟩ + have hconstant : constant = familyBlockConstant := + Option.some.inj (hget.symm.trans familyBlockEntry.getConst) + subst constant + have hmem := hsemantic.target_mem_refs + simp [familyBlockConstant] at hmem + +theorem recursor_dependency_target {target : Address} + (hdependency : dependencyGraph.dependsOn recursorBlockAddress target) : + target = familyId.addr ∨ target = falseId.addr ∨ + target = trueId.addr := by + obtain ⟨constant, hget, hsemantic⟩ := hdependency + have hconstant : constant = recursorBlockConstant := + Option.some.inj (hget.symm.trans recursorBlockEntry.getConst) + subst constant + simpa [recursorBlockConstant] using hsemantic.target_mem_refs + +theorem depsClosed : + DepsClosed dependencyGraph (expectedAnonWork recursorIxonEnv) + sourceWF.subjects noAssumptions := by + intro item hitem target hdependency + rw [expectedAnonWork_eq] at hitem + have hcases : item = recursorItem ∨ item = familyItem := by + simpa [booleanWork] using hitem + rcases hcases with rfl | rfl + · left + change dependencyGraph.dependsOn recursorBlockAddress target at hdependency + rcases recursor_dependency_target hdependency with + rfl | rfl | rfl <;> + simp [AnonWorkEnvWF.subjects, sourceAddresses] + · change dependencyGraph.dependsOn familyBlockAddress target at hdependency + exact (family_no_dependencies hdependency).elim + +theorem assumptionsWF : AssumptionsWF stagedWorld noAssumptions := by + intro addr haddr + simp [noAssumptions] at haddr + +theorem subjects_disjoint_assumptions : + sourceWF.subjects.Disjoint noAssumptions := by + intro addr _ haddr + simp [noAssumptions] at haddr + +/-- A semantic schedule may differ from the physical serial enumeration. +The family is admitted first because every recursor reference collapses into +that family block; the production driver still executes recursor-first. -/ +def wellFounded : + WellFoundedBlocks dependencyGraph (expectedAnonWork recursorIxonEnv) + sourceWF.subjects where + schedule := [familyItem, recursorItem] + permutation := by + rw [expectedAnonWork_eq] + exact List.Perm.swap recursorItem familyItem [] + topological := by + apply TopologicalFrom.cons + · intro target hdependency _ + change dependencyGraph.dependsOn familyBlockAddress target at hdependency + exact (family_no_dependencies hdependency).elim + · apply TopologicalFrom.cons + · intro target hdependency _ + change dependencyGraph.dependsOn recursorBlockAddress target at hdependency + right + refine ⟨familyItem, by simp, ?_⟩ + rcases recursor_dependency_target hdependency with + rfl | rfl | rfl <;> + simp [familyItem, AnonWorkItem.Covers, + AnonWorkItem.provenTargets] + · exact .nil _ + rank := fun addr => if addr = recursorBlockAddress then 1 else 0 + decreases := by + intro item target hitem hdependency _ houtside + rw [expectedAnonWork_eq] at hitem + have hcases : item = recursorItem ∨ item = familyItem := by + simpa [booleanWork] using hitem + rcases hcases with rfl | rfl + · change dependencyGraph.blockOf target ≠ recursorBlockAddress at houtside + change (if dependencyGraph.blockOf target = recursorBlockAddress then 1 else 0) < + (if recursorBlockAddress = recursorBlockAddress then 1 else 0) + simp [houtside] + · change dependencyGraph.dependsOn familyBlockAddress target at hdependency + exact (family_no_dependencies hdependency).elim + +/-- Restage the E2 family oracle at an arbitrary monotone current world, +admitting only family members which are still missing there. -/ +def familyResidualResources + (current : VerifyWorld) (hle : stagedWorld ≤ current) + (hnot : ¬WorkItemAccepted current familyItem) : + ResidualOracleBlockResources current familyBlockAddress familyId.addr + #[familyId.addr, falseId.addr, trueId.addr] := by + have hexact := stagedExactFamily.rebaseWorld hle + have hwork : familyItem.MatchesBlockCatalog current.blocks := by + simpa only [← hle.blocks] using familyWorkCatalog + have hmissing : ∃ id, + familyBlockOracle.members id ∧ ¬current.trusted id := + ResidualOracleBlockResources.missing_of_not_accepted + hexact hwork (fun id => familyLink.oracle_members_iff id) hnot + have hcatalog : world.catalog = current.catalog := by + simpa [stagedWorld] using hle.catalog + have hnameOf : world.nameOf = current.nameOf := by + simpa [stagedWorld] using hle.nameOf + let reindexed := familyBlockOracle.reindex hcatalog hnameOf + have henv : reindexed.after ≤ current.venv := by + simpa [reindexed, stagedWorld] using hle.venv + let oracle := reindexed.restageMissing henv current.venvWF + current.trusted (by + simpa [reindexed] using hmissing) + exact { + trProj := RawProjRel.none + members := familyMembers + kind := .inductive' + oracleBacked := trivial + exactBlock := hexact + workCatalog := hwork + oracle := oracle + memberIff := by + intro id + dsimp only [oracle] + rw [InductiveOracle.restageMissing_members_iff, + InductiveOracle.reindex_members] + exact and_congr (by + simpa only [familyBlockOracle] using + familyLink.oracle_members_iff id) Iff.rfl + } + +/-- Recursor analogue of `familyResidualResources`, including the E2 proof +that both Boolean iota rules are the generated enumeration equations. -/ +def recursorResidualResources + (current : VerifyWorld) (hle : stagedWorld ≤ current) + (hnot : ¬WorkItemAccepted current recursorItem) : + ResidualOracleBlockResources current recursorBlockAddress recursorId.addr + #[recursorId.addr] := by + have hexact := stagedExactRecursor.rebaseWorld hle + have hwork : recursorItem.MatchesBlockCatalog current.blocks := by + simpa only [← hle.blocks] using recursorWorkCatalog + have hmissing : ∃ id, + recursorBlockOracle.members id ∧ ¬current.trusted id := + ResidualOracleBlockResources.missing_of_not_accepted + hexact hwork + (fun id => recursorLink.oracle_members_iff enumerationShape id) hnot + have hcatalog : world.catalog = current.catalog := by + simpa [stagedWorld] using hle.catalog + have hnameOf : world.nameOf = current.nameOf := by + simpa [stagedWorld] using hle.nameOf + let reindexed := recursorBlockOracle.reindex hcatalog hnameOf + have henv : reindexed.after ≤ current.venv := by + simpa [reindexed, stagedWorld] using hle.venv + let oracle := reindexed.restageMissing henv current.venvWF + current.trusted (by + simpa [reindexed] using hmissing) + exact { + trProj := RawProjRel.none + members := recursorMembers + kind := .recursor + oracleBacked := trivial + exactBlock := hexact + workCatalog := hwork + oracle := oracle + memberIff := by + intro id + dsimp only [oracle] + rw [InductiveOracle.restageMissing_members_iff, + InductiveOracle.reindex_members] + exact and_congr (by + simpa only [recursorBlockOracle] using + recursorLink.oracle_members_iff enumerationShape id) Iff.rfl + } + +/-! ## Supported production calls -/ + +/-- Every still-pending successful call in the concrete two-row work set has +certificate-backed evidence at its *current* semantic world. The actual +successful `checkConst` equation remains in the provider interface and hence +in `CheckSuccessSound`; it is deliberately not used as a substitute for the +E2 semantic certificate. -/ +def supportedFragment : + SupportedCheckFragment stagedWorld dependencyGraph booleanWork where + resources := by + intro item hitem before checker hrun current hle hdeps hnot + have hcases : item = recursorItem ∨ item = familyItem := by + simpa [booleanWork] using hitem + by_cases hrecursor : item = recursorItem + · subst item + exact .certificateBackedBlock + (recursorResidualResources current hle hnot) + · have hfamily : item = familyItem := hcases.resolve_left hrecursor + subst item + exact .certificateBackedBlock + (familyResidualResources current hle hnot) + +def supportedExpectedFragment : + SupportedCheckFragment stagedWorld dependencyGraph + (expectedAnonWork recursorIxonEnv) := by + rw [expectedAnonWork_eq] + exact supportedFragment + +/-! ## Actual production-driver acceptance -/ + +/-- Hash verification is enabled: the release witness executes the same +address validation path as the public anonymous-environment checker. A +one-item clearing interval also exercises the production cache-reset branch +between the recursor and family rows. -/ +def checkCfg : CheckCfg := + { verifyHashes := true, clearEvery := 1 } + +def successfulResults : Array CheckResult := + #[⟨recursorId.addr, none⟩, ⟨familyId.addr, none⟩, + ⟨falseId.addr, none⟩, ⟨trueId.addr, none⟩] + +private theorem checkEnvAnonNative : + checkEnvAnon recursorIxonEnv checkCfg = .ok successfulResults := by + native_decide + +/-- Exact result of the real production driver on the certified Boolean +environment. -/ +theorem checkEnvAnon_eq : + checkEnvAnon recursorIxonEnv checkCfg = .ok successfulResults := + checkEnvAnonNative + +theorem allResultsSucceeded : + AllCheckResultsSucceeded successfulResults := by + intro result hresult + simp [successfulResults] at hresult + rcases hresult with rfl | rfl | rfl | rfl <;> rfl + +/-- Whole-driver E3-S witness for a real environment containing an inductive +family and its generated recursor. The theorem consumes the actual +`checkEnvAnon` success, the exact finite source domain, the collapsed +dependency schedule, and the residual E2 certificates for both coordinated +blocks. -/ +theorem subjectWF : + SubjectWF stagedWorld dependencyGraph + (expectedAnonWork recursorIxonEnv) sourceWF.subjects + noAssumptions := by + exact sourceWF.checkEnvAnon_supported_subjectWF blockOfIdempotent + depsClosed wellFounded assumptionsWF subjects_disjoint_assumptions + supportedExpectedFragment checkCfg checkEnvAnon_eq allResultsSucceeded + +end BooleanEnumerationFixture + +end Ix.Tc diff --git a/Ix/Tc/Verify/Driver/Dependencies.lean b/Ix/Tc/Verify/Driver/Dependencies.lean new file mode 100644 index 000000000..d2f022133 --- /dev/null +++ b/Ix/Tc/Verify/Driver/Dependencies.lean @@ -0,0 +1,180 @@ +import Ix.Tc.Verify.Driver.Model + +/-! +# Semantic dependencies of Ixon constants + +`Ixon.Constant.refs` is an intern table, not itself a dependency list. Nat +and String nodes index blobs through the same table, and malformed/unused +table entries must not become declaration assumptions. E1 therefore follows +the expression constructors which ingress turns into kernel constants: + +* `.ref i` contributes `refs[i]`; +* `.prj i ...` contributes its type declaration `refs[i]`; +* structural children and reachable `.share` expansions are traversed; +* `.recur` remains internal to the current collapsed block; and +* `.nat`/`.str` are data dependencies, not Theory declaration dependencies. +-/ + +namespace Ix.Tc + +namespace IxonExpr + +/-- A finite derivation that expression ingress can expose `target` as a +kernel declaration reference. Sharing is followed through its exact table +lookup, so an unused sharing entry contributes nothing. -/ +inductive DeclReference (sharing : Array Ixon.Expr) + (refs : Array Address) : Ixon.Expr → Address → Prop + | ref {index : UInt64} {univs : Array UInt64} {target : Address} : + refs[index.toNat]? = some target → + DeclReference sharing refs (.ref index univs) target + | prjType {index field : UInt64} {value : Ixon.Expr} {target : Address} : + refs[index.toNat]? = some target → + DeclReference sharing refs (.prj index field value) target + | prjValue {index field : UInt64} {value : Ixon.Expr} {target : Address} : + DeclReference sharing refs value target → + DeclReference sharing refs (.prj index field value) target + | appFn {fn arg : Ixon.Expr} {target : Address} : + DeclReference sharing refs fn target → + DeclReference sharing refs (.app fn arg) target + | appArg {fn arg : Ixon.Expr} {target : Address} : + DeclReference sharing refs arg target → + DeclReference sharing refs (.app fn arg) target + | lamType {type body : Ixon.Expr} {target : Address} : + DeclReference sharing refs type target → + DeclReference sharing refs (.lam type body) target + | lamBody {type body : Ixon.Expr} {target : Address} : + DeclReference sharing refs body target → + DeclReference sharing refs (.lam type body) target + | allType {type body : Ixon.Expr} {target : Address} : + DeclReference sharing refs type target → + DeclReference sharing refs (.all type body) target + | allBody {type body : Ixon.Expr} {target : Address} : + DeclReference sharing refs body target → + DeclReference sharing refs (.all type body) target + | letType {nondep : Bool} {type value body : Ixon.Expr} + {target : Address} : + DeclReference sharing refs type target → + DeclReference sharing refs (.letE nondep type value body) target + | letValue {nondep : Bool} {type value body : Ixon.Expr} + {target : Address} : + DeclReference sharing refs value target → + DeclReference sharing refs (.letE nondep type value body) target + | letBody {nondep : Bool} {type value body : Ixon.Expr} + {target : Address} : + DeclReference sharing refs body target → + DeclReference sharing refs (.letE nondep type value body) target + | share {index : UInt64} {expansion : Ixon.Expr} {target : Address} : + sharing[index.toNat]? = some expansion → + DeclReference sharing refs expansion target → + DeclReference sharing refs (.share index) target + +/-- Every semantic declaration reference selects an address from the +constant's reference table. Following a sharing-table expansion can expose +more syntax, but cannot introduce an address outside `refs`. -/ +theorem DeclReference.target_mem_refs {sharing : Array Ixon.Expr} + {refs : Array Address} {root : Ixon.Expr} {target : Address} + (h : DeclReference sharing refs root target) : target ∈ refs := by + induction h with + | ref hlookup | prjType hlookup => + obtain ⟨hbound, hget⟩ := Array.getElem?_eq_some_iff.mp hlookup + exact Array.mem_iff_getElem.mpr ⟨_, hbound, hget⟩ + | prjValue _ ih => exact ih + | appFn _ ih => exact ih + | appArg _ ih => exact ih + | lamType _ ih => exact ih + | lamBody _ ih => exact ih + | allType _ ih => exact ih + | allBody _ ih => exact ih + | letType _ ih => exact ih + | letValue _ ih => exact ih + | letBody _ ih => exact ih + | share _ _ ih => exact ih + +end IxonExpr + +namespace IxonMutConst + +/-- Root expressions which contribute to one member of a Muts block. -/ +inductive RootExpr : Ixon.MutConst → Ixon.Expr → Prop + | defnType {defn : Ixon.Definition} : RootExpr (.defn defn) defn.typ + | defnValue {defn : Ixon.Definition} : RootExpr (.defn defn) defn.value + | inductiveType {ind : Ixon.Inductive} : RootExpr (.indc ind) ind.typ + | constructorType {ind : Ixon.Inductive} {ctor : Ixon.Constructor} : + ctor ∈ ind.ctors → RootExpr (.indc ind) ctor.typ + | recursorType {recr : Ixon.Recursor} : RootExpr (.recr recr) recr.typ + | recursorRule {recr : Ixon.Recursor} {rule : Ixon.RecursorRule} : + rule ∈ recr.rules → RootExpr (.recr recr) rule.rhs + +end IxonMutConst + +namespace IxonConstantInfo + +/-- Every expression root which is semantically part of a constant. Pure +projection records have no expression roots. -/ +inductive RootExpr : Ixon.ConstantInfo → Ixon.Expr → Prop + | defnType {defn : Ixon.Definition} : RootExpr (.defn defn) defn.typ + | defnValue {defn : Ixon.Definition} : RootExpr (.defn defn) defn.value + | recursorType {recr : Ixon.Recursor} : RootExpr (.recr recr) recr.typ + | recursorRule {recr : Ixon.Recursor} {rule : Ixon.RecursorRule} : + rule ∈ recr.rules → RootExpr (.recr recr) rule.rhs + | axiomType {ax : Ixon.Axiom} : RootExpr (.axio ax) ax.typ + | quotientType {quotient : Ixon.Quotient} : + RootExpr (.quot quotient) quotient.typ + | mutualMember {members : Array Ixon.MutConst} {member : Ixon.MutConst} + {expr : Ixon.Expr} : + member ∈ members → IxonMutConst.RootExpr member expr → + RootExpr (.muts members) expr + +end IxonConstantInfo + +namespace IxonConstant + +/-- Exact declaration dependency of a serialized constant. -/ +def SemanticDependency (constant : Ixon.Constant) + (target : Address) : Prop := + ∃ root, + IxonConstantInfo.RootExpr constant.info root ∧ + IxonExpr.DeclReference constant.sharing constant.refs root target + +theorem SemanticDependency.target_mem_refs {constant : Ixon.Constant} + {target : Address} (h : SemanticDependency constant target) : + target ∈ constant.refs := by + obtain ⟨_, _, href⟩ := h + exact href.target_mem_refs + +end IxonConstant + +namespace IxonEnv + +/-- Structural condition needed to use production `blockOfAddr` as a +collapsed-node map. Well-formed compiled environments satisfy it; malformed +projection chains must state the failure rather than being normalized +silently. -/ +def BlockOfIdempotent (env : Ixon.Env) : Prop := + ∀ addr, blockOfAddr env (blockOfAddr env addr) = blockOfAddr env addr + +/-- Production Ixon dependency catalog. Dependencies are read from the +constant stored at the already-collapsed node. -/ +def dependencyCatalog (env : Ixon.Env) (hblock : BlockOfIdempotent env) : + DependencyCatalog where + blockOf := blockOfAddr env + dependsOn := fun source target => + ∃ constant, env.getConst? source = some constant ∧ + IxonConstant.SemanticDependency constant target + blockOf_idem := hblock + +@[simp] theorem dependencyCatalog_blockOf (env : Ixon.Env) + (hblock : BlockOfIdempotent env) (addr : Address) : + (dependencyCatalog env hblock).blockOf addr = blockOfAddr env addr := + rfl + +theorem dependencyCatalog_dependsOn_iff (env : Ixon.Env) + (hblock : BlockOfIdempotent env) {source target : Address} : + (dependencyCatalog env hblock).dependsOn source target ↔ + ∃ constant, env.getConst? source = some constant ∧ + IxonConstant.SemanticDependency constant target := + Iff.rfl + +end IxonEnv + +end Ix.Tc diff --git a/Ix/Tc/Verify/Driver/Enumeration.lean b/Ix/Tc/Verify/Driver/Enumeration.lean new file mode 100644 index 000000000..75a0066c3 --- /dev/null +++ b/Ix/Tc/Verify/Driver/Enumeration.lean @@ -0,0 +1,563 @@ +import Ix.Tc.Verify.Driver.Dependencies + +/-! +# Exact `buildAnonWork` enumeration + +The work builder operates on a serialized `Ixon.Env`, so its theorem needs an +explicit input-integrity contract. `AnonWorkEnvWF` says every sorted source +key materializes with an agreeing cheap tag, every generated projection is +stored, every stored projection is owned by a stored Muts block, and Muts +blocks are nonempty. None of these fields grants typing authority. + +Under that structural contract, the production builder succeeds, its +`provenTargets` partition is exactly the source-key domain, and every target +collapses to its work item's root. +-/ + +namespace Ix.Tc + +/-- Exact lazy entry used by the production classifier. This is a +proposition, rather than a data-bearing structure, so the lazy implementation +witness cannot escape the structural environment contract. -/ +def ExactAnonEntry (env : Ixon.Env) (addr : Address) + (constant : Ixon.Constant) : Prop := + addr ∈ orderedAnonConstAddrs env ∧ + ∃ lazy, env.consts.get? addr = some lazy ∧ + lazy.get = .ok constant ∧ + lazy.peekTag = .ok (constantInfoTag constant.info) + +namespace ExactAnonEntry + +theorem getConst {env : Ixon.Env} {addr : Address} + {constant : Ixon.Constant} (h : ExactAnonEntry env addr constant) : + env.getConst? addr = some constant := by + obtain ⟨_, lazy, hlookup, hmaterialize, _⟩ := h + simp only [Ixon.Env.getConst?] + rw [hlookup] + simp only [Option.bind_some] + unfold Ixon.LazyConstant.get? at ⊢ + unfold Ixon.LazyConstant.get at hmaterialize + cases hcache : lazy.cache with + | none => + simp only [hcache] at hmaterialize ⊢ + simpa using congrArg Except.toOption hmaterialize + | some cached => + simp only [hcache] at hmaterialize ⊢ + cases hmaterialize + rfl + +theorem constant_unique {env : Ixon.Env} {addr : Address} + {left right : Ixon.Constant} + (hleft : ExactAnonEntry env addr left) + (hright : ExactAnonEntry env addr right) : left = right := by + obtain ⟨_, leftLazy, hleftLookup, hleftGet, _⟩ := hleft + obtain ⟨_, rightLazy, hrightLookup, hrightGet, _⟩ := hright + have hlazy : leftLazy = rightLazy := + Option.some.inj (hleftLookup.symm.trans hrightLookup) + subst rightLazy + exact Except.ok.inj (hleftGet.symm.trans hrightGet) + +end ExactAnonEntry + +/-- Owning Muts address of a projection record. -/ +def projectionOwner? : Ixon.ConstantInfo → Option Address + | .iPrj projection => some projection.block + | .cPrj projection => some projection.block + | .rPrj projection => some projection.block + | .dPrj projection => some projection.block + | _ => none + +/-- Structural source-environment contract sufficient for exact work +enumeration. It is deliberately separate from hash collision assumptions: +if two generated projection addresses collide, `projectionComplete` would +force the one map entry to materialize as two different projection records, +which `ExactAnonEntry.constant_unique` rules out. -/ +structure AnonWorkEnvWF (env : Ixon.Env) : Prop where + keysNodup : (orderedAnonConstAddrs env).toList.Nodup + entry : ∀ {addr}, addr ∈ orderedAnonConstAddrs env → + ∃ constant, ExactAnonEntry env addr constant + blocksNonempty : ∀ {addr constant members}, + ExactAnonEntry env addr constant → + constant.info = .muts members → + (anonBlockTargets addr members).size > 0 + projectionComplete : ∀ {block constant members target}, + ExactAnonEntry env block constant → + constant.info = .muts members → + target ∈ anonBlockTargets block members → + ∃ projectionConstant, + ExactAnonEntry env target projectionConstant ∧ + projectionOwner? projectionConstant.info = some block + projectionOwned : ∀ {addr constant owner}, + ExactAnonEntry env addr constant → + projectionOwner? constant.info = some owner → + ∃ blockConstant members, + ExactAnonEntry env owner blockConstant ∧ + blockConstant.info = .muts members ∧ + addr ∈ anonBlockTargets owner members + +namespace ExactAnonEntry + +/-- Exact entries make the cheap production classifier equal the pure +materialized classifier. -/ +theorem buildAnonWorkItem_eq {env : Ixon.Env} {addr : Address} + {constant : Ixon.Constant} (h : ExactAnonEntry env addr constant) : + buildAnonWorkItem env addr = + .ok (AnonWorkItem.ofConstantInfo addr constant.info) := by + obtain ⟨_, lazy, hlookup, hmaterialize, htag⟩ := h + unfold buildAnonWorkItem + simp only [hlookup] + rw [htag] + cases hinfo : constant.info <;> + simp [hmaterialize, constantInfoTag, AnonWorkItem.ofConstantInfo, + hinfo] + all_goals + change Except.ok _ = Except.ok _ + rfl + +end ExactAnonEntry + +/-- Pure materialized normal form of production work enumeration. -/ +def expectedAnonWork (env : Ixon.Env) : Array AnonWorkItem := + (orderedAnonConstAddrs env).filterMap fun addr => + (env.getConst? addr).bind fun constant => + AnonWorkItem.ofConstantInfo addr constant.info + +namespace AnonWorkEnvWF + +private theorem list_filterMapM_eq_filterMap + {α β : Type} {xs : List α} + {f : α → Except IngressErr (Option β)} {g : α → Option β} + (h : ∀ x, x ∈ xs → f x = .ok (g x)) : + xs.filterMapM f = .ok (xs.filterMap g) := by + induction xs with + | nil => + change Except.ok [] = Except.ok [] + rfl + | cons x xs ih => + have hx := h x (by simp) + have hxs : ∀ y, y ∈ xs → f y = .ok (g y) := by + intro y hy + exact h y (by simp [hy]) + rw [List.filterMapM_cons, hx, ih hxs] + cases hresult : g x with + | none => + simp [hresult] + change Except.ok (List.filterMap g xs) = + Except.ok (List.filterMap g xs) + rfl + | some result => + simp [hresult] + change Except.ok (result :: List.filterMap g xs) = + Except.ok (result :: List.filterMap g xs) + rfl + +private theorem array_filterMapM_eq_filterMap + {α β : Type} {xs : Array α} + {f : α → Except IngressErr (Option β)} {g : α → Option β} + (h : ∀ x, x ∈ xs → f x = .ok (g x)) : + xs.filterMapM f = .ok (xs.filterMap g) := by + have hlist : xs.toList.filterMapM f = + .ok (xs.toList.filterMap g) := by + apply list_filterMapM_eq_filterMap + intro x hx + exact h x (by simpa using hx) + rw [← Array.toArray_toList (xs := xs), List.filterMapM_toArray, hlist] + exact congrArg Except.ok + (by simpa using (List.filterMap_toArray (l := xs.toList) (f := g)).symm) + +theorem buildItem_eq_expected {env : Ixon.Env} (h : AnonWorkEnvWF env) + {addr : Address} (haddr : addr ∈ orderedAnonConstAddrs env) : + buildAnonWorkItem env addr = .ok + ((env.getConst? addr).bind fun constant => + AnonWorkItem.ofConstantInfo addr constant.info) := by + obtain ⟨constant, hentry⟩ := h.entry haddr + rw [hentry.buildAnonWorkItem_eq, hentry.getConst] + rfl + +/-- The optimized tag-dispatch implementation has the exact pure +materialized normal form on structurally valid inputs. -/ +theorem buildAnonWork_eq_expected {env : Ixon.Env} + (h : AnonWorkEnvWF env) : + buildAnonWork env = .ok (expectedAnonWork env) := by + unfold buildAnonWork expectedAnonWork + apply array_filterMapM_eq_filterMap + intro addr haddr + exact h.buildItem_eq_expected haddr + +/-! ## Exact source-domain coverage -/ + +/-- The canonical source-key set certified by an environment contract. -/ +def subjects {env : Ixon.Env} (h : AnonWorkEnvWF env) : + FiniteAddressSet := + ⟨(orderedAnonConstAddrs env).toList, h.keysNodup⟩ + +@[simp] theorem mem_subjects {env : Ixon.Env} (h : AnonWorkEnvWF env) + {addr : Address} : + addr ∈ h.subjects ↔ addr ∈ orderedAnonConstAddrs env := by + simp [subjects] + +/-- Membership in the pure workset has an exact materialized source entry. -/ +theorem mem_expectedAnonWork_iff {env : Ixon.Env} + (h : AnonWorkEnvWF env) {item : AnonWorkItem} : + item ∈ expectedAnonWork env ↔ + ∃ addr constant, + ExactAnonEntry env addr constant ∧ + AnonWorkItem.ofConstantInfo addr constant.info = some item := by + rw [expectedAnonWork, Array.mem_filterMap] + constructor + · rintro ⟨addr, haddr, hemitted⟩ + obtain ⟨constant, hentry⟩ := h.entry haddr + refine ⟨addr, constant, hentry, ?_⟩ + rw [hentry.getConst] at hemitted + exact hemitted + · rintro ⟨addr, constant, hentry, hemitted⟩ + refine ⟨addr, hentry.1, ?_⟩ + rw [hentry.getConst] + exact hemitted + +end AnonWorkEnvWF + +namespace AnonWorkItem + +/-- Every emitted item is rooted at the source key which emitted it. -/ +theorem ofConstantInfo_root {addr : Address} {info : Ixon.ConstantInfo} + {item : AnonWorkItem} + (h : ofConstantInfo addr info = some item) : item.root = addr := by + cases info with + | defn _ | recr _ | axio _ | quot _ => + have heq : standalone addr = item := by + simpa [ofConstantInfo] using h + rw [← heq] + rfl + | cPrj _ | rPrj _ | iPrj _ | dPrj _ => + simp [ofConstantInfo] at h + | muts members => + cases hprimary : (anonBlockTargets addr members)[0]? with + | none => simp [ofConstantInfo, hprimary] at h + | some primary => + have heq : block addr primary (anonBlockTargets addr members) = + item := by + simpa [ofConstantInfo, hprimary] using h + rw [← heq] + rfl + +@[simp] theorem covers_root (item : AnonWorkItem) : + item.Covers item.root := by + cases item <;> + simp [Covers, root, provenTargets] + +/-- Classification emits only items whose primary is an actual checker +target. -/ +theorem ofConstantInfo_primary_mem_targets {addr : Address} + {info : Ixon.ConstantInfo} {item : AnonWorkItem} + (h : ofConstantInfo addr info = some item) : + item.primary ∈ item.targets := by + cases info with + | defn _ | recr _ | axio _ | quot _ => + have heq : standalone addr = item := by + simpa [ofConstantInfo] using h + rw [← heq] + simp [primary, targets] + | cPrj _ | rPrj _ | iPrj _ | dPrj _ => + simp [ofConstantInfo] at h + | muts members => + cases hprimary : (anonBlockTargets addr members)[0]? with + | none => simp [ofConstantInfo, hprimary] at h + | some primaryAddr => + have heq : block addr primaryAddr (anonBlockTargets addr members) = + item := by + simpa [ofConstantInfo, hprimary] using h + rw [← heq] + simp only [primary, targets] + obtain ⟨hbound, hget⟩ := Array.getElem?_eq_some_iff.mp hprimary + exact Array.mem_iff_getElem.mpr ⟨0, hbound, hget⟩ + +end AnonWorkItem + +namespace AnonWorkEnvWF + +private theorem covered_of_emitted {env : Ixon.Env} + (h : AnonWorkEnvWF env) {addr : Address} + {constant : Ixon.Constant} (hentry : ExactAnonEntry env addr constant) + {item : AnonWorkItem} + (hemitted : AnonWorkItem.ofConstantInfo addr constant.info = some item) : + item ∈ expectedAnonWork env ∧ item.Covers addr := by + constructor + · exact (h.mem_expectedAnonWork_iff).2 + ⟨addr, constant, hentry, hemitted⟩ + · have hroot := AnonWorkItem.ofConstantInfo_root hemitted + rw [← hroot] + exact item.covers_root + +private theorem block_primary {env : Ixon.Env} + (h : AnonWorkEnvWF env) {addr : Address} + {constant : Ixon.Constant} {members : Array Ixon.MutConst} + (hentry : ExactAnonEntry env addr constant) + (hinfo : constant.info = .muts members) : + ∃ primary, (anonBlockTargets addr members)[0]? = some primary := by + cases hprimary : (anonBlockTargets addr members)[0]? with + | none => + have hle := Array.getElem?_eq_none_iff.mp hprimary + have hpos := h.blocksNonempty hentry hinfo + omega + | some primary => exact ⟨primary, rfl⟩ + +private theorem projection_source_covered {env : Ixon.Env} + (h : AnonWorkEnvWF env) {addr owner : Address} + {constant : Ixon.Constant} (hentry : ExactAnonEntry env addr constant) + (howner : projectionOwner? constant.info = some owner) : + ∃ item, item ∈ expectedAnonWork env ∧ item.Covers addr := by + obtain ⟨blockConstant, members, hblock, hblockInfo, htarget⟩ := + h.projectionOwned hentry howner + obtain ⟨primary, hprimary⟩ := h.block_primary hblock hblockInfo + let item := AnonWorkItem.block owner primary + (anonBlockTargets owner members) + refine ⟨item, ?_, ?_⟩ + · exact (h.mem_expectedAnonWork_iff).2 ⟨owner, blockConstant, hblock, by + simp [item, AnonWorkItem.ofConstantInfo, hblockInfo, hprimary]⟩ + · simp [item, AnonWorkItem.Covers, AnonWorkItem.provenTargets, + htarget] + +/-- Every serialized source key is covered by a production work item. Pure +projection records are covered by their owning block rather than emitted a +second time. -/ +theorem source_covered {env : Ixon.Env} (h : AnonWorkEnvWF env) + {addr : Address} (haddr : addr ∈ orderedAnonConstAddrs env) : + ∃ item, item ∈ expectedAnonWork env ∧ item.Covers addr := by + obtain ⟨constant, hentry⟩ := h.entry haddr + cases hinfo : constant.info with + | defn | recr | axio | quot => + let item := AnonWorkItem.standalone addr + exact ⟨item, h.covered_of_emitted hentry (by + simp [item, AnonWorkItem.ofConstantInfo, hinfo])⟩ + | muts members => + obtain ⟨primary, hprimary⟩ := h.block_primary hentry hinfo + let item := AnonWorkItem.block addr primary + (anonBlockTargets addr members) + exact ⟨item, h.covered_of_emitted hentry (by + simp [item, AnonWorkItem.ofConstantInfo, hinfo, hprimary])⟩ + | iPrj projection => + exact h.projection_source_covered (owner := projection.block) hentry (by + simp [projectionOwner?, hinfo]) + | cPrj projection => + exact h.projection_source_covered (owner := projection.block) hentry (by + simp [projectionOwner?, hinfo]) + | rPrj projection => + exact h.projection_source_covered (owner := projection.block) hentry (by + simp [projectionOwner?, hinfo]) + | dPrj projection => + exact h.projection_source_covered (owner := projection.block) hentry (by + simp [projectionOwner?, hinfo]) + +/-- Conversely, an emitted item's `provenTargets` cannot certify an address +outside the serialized source-key domain. -/ +theorem covered_is_source {env : Ixon.Env} (h : AnonWorkEnvWF env) + {item : AnonWorkItem} (hitem : item ∈ expectedAnonWork env) + {addr : Address} (hcovered : item.Covers addr) : + addr ∈ orderedAnonConstAddrs env := by + obtain ⟨source, constant, hentry, hemitted⟩ := + (h.mem_expectedAnonWork_iff).1 hitem + cases hinfo : constant.info with + | defn | recr | axio | quot => + have hitemEq : item = .standalone source := by + simpa [AnonWorkItem.ofConstantInfo, hinfo] using hemitted.symm + subst item + simp [AnonWorkItem.Covers, AnonWorkItem.provenTargets] at hcovered + subst addr + exact hentry.1 + | iPrj | cPrj | rPrj | dPrj => + simp [AnonWorkItem.ofConstantInfo, hinfo] at hemitted + | muts members => + cases hprimary : (anonBlockTargets source members)[0]? with + | none => + simp [AnonWorkItem.ofConstantInfo, hinfo, hprimary] at hemitted + | some primary => + have hitemEq : item = .block source primary + (anonBlockTargets source members) := by + simpa [AnonWorkItem.ofConstantInfo, hinfo, hprimary] using + hemitted.symm + subst item + simp [AnonWorkItem.Covers, AnonWorkItem.provenTargets] at hcovered + rcases hcovered with rfl | htarget + · exact hentry.1 + · obtain ⟨projectionConstant, hprojection, _⟩ := + h.projectionComplete hentry hinfo htarget + exact hprojection.1 + +/-- Every production-normalized work item emits at least its primary checker +target. -/ +theorem expected_primary_mem_targets {env : Ixon.Env} + (h : AnonWorkEnvWF env) {item : AnonWorkItem} + (hitem : item ∈ expectedAnonWork env) : item.primary ∈ item.targets := by + obtain ⟨_, _, _, hemitted⟩ := (h.mem_expectedAnonWork_iff).1 hitem + exact AnonWorkItem.ofConstantInfo_primary_mem_targets hemitted + +/-! ## Collapsed-address alignment and uniqueness -/ + +end AnonWorkEnvWF + +namespace ExactAnonEntry + +theorem blockOfAddr_eq_owner {env : Ixon.Env} + {addr owner : Address} {constant : Ixon.Constant} + (h : ExactAnonEntry env addr constant) + (howner : projectionOwner? constant.info = some owner) : + blockOfAddr env addr = owner := by + cases hinfo : constant.info <;> + simp [blockOfAddr, h.getConst, projectionOwner?, hinfo] at howner ⊢ <;> + assumption + +theorem blockOfAddr_eq_self {env : Ixon.Env} + {addr : Address} {constant : Ixon.Constant} + (h : ExactAnonEntry env addr constant) + (hnone : projectionOwner? constant.info = none) : + blockOfAddr env addr = addr := by + cases hinfo : constant.info <;> + simp [blockOfAddr, h.getConst, projectionOwner?, hinfo] at hnone ⊢ + +end ExactAnonEntry + +namespace AnonWorkEnvWF + +/-- `provenTargets` and production dependency collapsing use exactly the same +`Address` domain: every covered target collapses to its work item's root. -/ +theorem matches_blockOfAddr {env : Ixon.Env} (h : AnonWorkEnvWF env) + {item : AnonWorkItem} (hitem : item ∈ expectedAnonWork env) + {addr : Address} (hcovered : item.Covers addr) : + blockOfAddr env addr = item.root := by + obtain ⟨source, constant, hentry, hemitted⟩ := + (h.mem_expectedAnonWork_iff).1 hitem + cases hinfo : constant.info with + | defn | recr | axio | quot => + have hitemEq : item = .standalone source := by + simpa [AnonWorkItem.ofConstantInfo, hinfo] using hemitted.symm + subst item + simp [AnonWorkItem.Covers, AnonWorkItem.provenTargets] at hcovered + subst addr + exact ExactAnonEntry.blockOfAddr_eq_self hentry (by + simp [projectionOwner?, hinfo]) + | cPrj | rPrj | iPrj | dPrj => + simp [AnonWorkItem.ofConstantInfo, hinfo] at hemitted + | muts members => + cases hprimary : (anonBlockTargets source members)[0]? with + | none => + simp [AnonWorkItem.ofConstantInfo, hinfo, hprimary] at hemitted + | some primary => + have hitemEq : item = .block source primary + (anonBlockTargets source members) := by + simpa [AnonWorkItem.ofConstantInfo, hinfo, hprimary] using + hemitted.symm + subst item + simp [AnonWorkItem.Covers, AnonWorkItem.provenTargets] at hcovered + rcases hcovered with rfl | htarget + · exact ExactAnonEntry.blockOfAddr_eq_self hentry (by + simp [projectionOwner?, hinfo]) + · obtain ⟨projectionConstant, hprojection, howner⟩ := + h.projectionComplete hentry hinfo htarget + exact ExactAnonEntry.blockOfAddr_eq_owner hprojection howner + +private theorem item_unique_of_root_eq {env : Ixon.Env} + (h : AnonWorkEnvWF env) {left right : AnonWorkItem} + (hleft : left ∈ expectedAnonWork env) + (hright : right ∈ expectedAnonWork env) + (hroot : left.root = right.root) : left = right := by + obtain ⟨leftSource, leftConstant, hleftEntry, hleftEmitted⟩ := + (h.mem_expectedAnonWork_iff).1 hleft + obtain ⟨rightSource, rightConstant, hrightEntry, hrightEmitted⟩ := + (h.mem_expectedAnonWork_iff).1 hright + have hleftRoot := AnonWorkItem.ofConstantInfo_root hleftEmitted + have hrightRoot := AnonWorkItem.ofConstantInfo_root hrightEmitted + have hsources : leftSource = rightSource := + hleftRoot.symm.trans (hroot.trans hrightRoot) + rw [← hsources] at hrightEntry hrightEmitted + have hconstants : leftConstant = rightConstant := + ExactAnonEntry.constant_unique hleftEntry hrightEntry + rw [← hconstants] at hrightEmitted + exact Option.some.inj (hleftEmitted.symm.trans hrightEmitted) + +private theorem list_filterMap_nodup_of_root + {xs : List Address} (hxs : xs.Nodup) + (f : Address → Option AnonWorkItem) + (hroot : ∀ {source item}, source ∈ xs → f source = some item → + item.root = source) : + (xs.filterMap f).Nodup := by + induction xs with + | nil => simp + | cons source rest ih => + obtain ⟨hnotMem, hrestNodup⟩ := List.nodup_cons.mp hxs + rw [List.filterMap_cons] + cases hemitted : f source with + | none => + apply ih hrestNodup + intro other item hother hitem + exact hroot (by simp [hother]) hitem + | some item => + rw [List.nodup_cons] + constructor + · intro hitemMem + obtain ⟨other, hother, hotherEmitted⟩ := + List.mem_filterMap.mp hitemMem + have hsourceRoot := hroot (by simp) hemitted + have hotherRoot := hroot (by simp [hother]) hotherEmitted + have hsources : source = other := + hsourceRoot.symm.trans hotherRoot + apply hnotMem + rw [hsources] + exact hother + · apply ih hrestNodup + intro other result hother hresult + exact hroot (by simp [hother]) hresult + +private theorem expectedAnonWork_nodup {env : Ixon.Env} + (h : AnonWorkEnvWF env) : + (expectedAnonWork env).toList.Nodup := by + rw [expectedAnonWork, Array.toList_filterMap] + apply list_filterMap_nodup_of_root h.keysNodup + intro source item hsource hemitted + obtain ⟨constant, hentry⟩ := h.entry (by simpa using hsource) + rw [hentry.getConst] at hemitted + exact AnonWorkItem.ofConstantInfo_root hemitted + +/-- Exact partition theorem for the pure normal form of production +enumeration. Removing any emitted item falsifies `WorkCovers.exact` for its +root, while overlapping work items are ruled out by collapsed-address +alignment and deterministic source classification. -/ +theorem expectedAnonWork_covers {env : Ixon.Env} + (h : AnonWorkEnvWF env) : + WorkCovers (expectedAnonWork env) h.subjects where + exact addr := by + rw [h.mem_subjects] + constructor + · exact h.source_covered + · rintro ⟨item, hitem, hcovered⟩ + exact h.covered_is_source hitem hcovered + workNodup := h.expectedAnonWork_nodup + unique := by + intro addr left right hleft hright hleftCovered hrightCovered + apply h.item_unique_of_root_eq hleft hright + exact (h.matches_blockOfAddr hleft hleftCovered).symm.trans + (h.matches_blockOfAddr hright hrightCovered) + +/-- Exact workset/collapsed-catalog alignment for the production dependency +catalog. -/ +theorem expectedAnonWork_matchesCatalog {env : Ixon.Env} + (h : AnonWorkEnvWF env) (hblock : IxonEnv.BlockOfIdempotent env) : + WorkMatchesCatalog (IxonEnv.dependencyCatalog env hblock) + (expectedAnonWork env) := by + intro item hitem addr hcovered + exact h.matches_blockOfAddr hitem hcovered + +/-- Public production-facing E1 enumeration result. -/ +theorem buildAnonWork_exact {env : Ixon.Env} + (h : AnonWorkEnvWF env) (hblock : IxonEnv.BlockOfIdempotent env) : + ∃ work, + buildAnonWork env = .ok work ∧ + WorkCovers work h.subjects ∧ + WorkMatchesCatalog (IxonEnv.dependencyCatalog env hblock) work := by + refine ⟨expectedAnonWork env, h.buildAnonWork_eq_expected, + h.expectedAnonWork_covers, ?_⟩ + exact h.expectedAnonWork_matchesCatalog hblock + +end AnonWorkEnvWF + +end Ix.Tc diff --git a/Ix/Tc/Verify/Driver/Fixtures.lean b/Ix/Tc/Verify/Driver/Fixtures.lean new file mode 100644 index 000000000..84c9403e4 --- /dev/null +++ b/Ix/Tc/Verify/Driver/Fixtures.lean @@ -0,0 +1,181 @@ +import Ix.Tc.Verify.Driver.Serial + +/-! +# Adversarial E1 fixtures + +These small, Blake3-independent fixtures exercise the checked-set contracts +themselves. They deliberately use fixed distinct addresses so failures in +coverage, dependency closure, or graph well-foundedness cannot be hidden by +content-address computation. +-/ + +namespace Ix.Tc.E1Fixture + +def address (byte : UInt8) : Address := + ⟨⟨Array.replicate 32 byte⟩⟩ + +def first : Address := address 41 +def second : Address := address 42 +def external : Address := address 43 +def unresolved : Address := address 44 + +theorem address_ne {left right : UInt8} (h : left ≠ right) : + address left ≠ address right := by + intro heq + have hbyte := congrArg (fun value : Address => value.hash.get! 0) heq + simp [address] at hbyte + exact h hbyte + +@[simp] theorem first_ne_second : first ≠ second := + address_ne (by decide) + +@[simp] theorem second_ne_first : second ≠ first := + Ne.symm first_ne_second + +@[simp] theorem first_ne_external : first ≠ external := + address_ne (by decide) + +@[simp] theorem external_ne_first : external ≠ first := + Ne.symm first_ne_external + +@[simp] theorem second_ne_external : second ≠ external := + address_ne (by decide) + +@[simp] theorem external_ne_second : external ≠ second := + Ne.symm second_ne_external + +@[simp] theorem unresolved_ne_first : unresolved ≠ first := + address_ne (by decide) + +@[simp] theorem unresolved_ne_second : unresolved ≠ second := + address_ne (by decide) + +@[simp] theorem unresolved_ne_external : unresolved ≠ external := + address_ne (by decide) + +def firstItem : AnonWorkItem := .standalone first +def secondItem : AnonWorkItem := .standalone second + +def work : Array AnonWorkItem := #[firstItem, secondItem] + +def subjects : FiniteAddressSet := + ⟨[first, second], by simp⟩ + +def assumptions : FiniteAddressSet := + ⟨[external], by simp⟩ + +/-- The positive fixture: `first` depends on one external assumption and +`second` depends on `first`. -/ +def catalog : DependencyCatalog where + blockOf := id + dependsOn := fun source target => + (source = first ∧ target = external) ∨ + (source = second ∧ target = first) + blockOf_idem := fun _ => rfl + +@[simp] theorem mem_subjects {addr : Address} : + addr ∈ subjects ↔ addr = first ∨ addr = second := by + simp [subjects] + +@[simp] theorem mem_assumptions {addr : Address} : + addr ∈ assumptions ↔ addr = external := by + simp [assumptions] + +/-- The two standalone work items cover exactly the advertised subject set. -/ +theorem workCovers : WorkCovers work subjects := by + refine ⟨?_, ?_, ?_⟩ + · intro addr + simp [work, firstItem, secondItem, subjects, + AnonWorkItem.Covers, + AnonWorkItem.provenTargets] + · simp [work, firstItem, secondItem] + · intro addr left right hleft hright hleftCovered hrightCovered + simp [work] at hleft hright + rcases hleft with rfl | rfl <;> + rcases hright with rfl | rfl <;> + simp [firstItem, secondItem, AnonWorkItem.Covers, + AnonWorkItem.provenTargets] at hleftCovered hrightCovered ⊢ + exact False.elim (first_ne_second + (hleftCovered.symm.trans hrightCovered)) + exact False.elim (second_ne_first + (hleftCovered.symm.trans hrightCovered)) + +/-- Every positive-fixture dependency lies in the exact `S ∪ A`: the only +external edge is `first → external`. -/ +theorem depsClosed : DepsClosed catalog work subjects assumptions := by + intro item hitem target hdependency + simp [work] at hitem + rcases hitem with rfl | rfl + · right + simp [catalog, firstItem, AnonWorkItem.root] at hdependency ⊢ + exact hdependency + · left + simp [catalog, secondItem, AnonWorkItem.root] at hdependency ⊢ + exact .inl hdependency + +/-- Bundled positive acceptance witness: a multi-declaration fixture has the +exact abstract subject and external-assumption domains claimed above. -/ +theorem exactSubjectsAndAssumptions : + WorkCovers work subjects ∧ + DepsClosed catalog work subjects assumptions ∧ + (∀ addr, addr ∈ subjects ↔ addr = first ∨ addr = second) ∧ + (∀ addr, addr ∈ assumptions ↔ addr = external) := + ⟨workCovers, depsClosed, fun _ => mem_subjects, + fun _ => mem_assumptions⟩ + +/-- Dropping the second item leaves its subject uncovered. -/ +theorem droppingWorkItem_breaks_coverage : + ¬WorkCovers #[firstItem] subjects := by + intro hcover + have hsecond : second ∈ subjects := by simp + obtain ⟨item, hitem, hcovered⟩ := hcover.covered hsecond + simp only [Array.mem_singleton] at hitem + subst item + simp [firstItem, AnonWorkItem.Covers, + AnonWorkItem.provenTargets] at hcovered + +/-- Add one edge whose target is in neither `S` nor `A`. -/ +def unresolvedCatalog : DependencyCatalog where + blockOf := id + dependsOn := fun source target => + catalog.dependsOn source target ∨ + (source = first ∧ target = unresolved) + blockOf_idem := fun _ => rfl + +/-- The extra unresolved edge makes dependency closure impossible. -/ +theorem unresolvedDependency_breaks_closure : + ¬DepsClosed unresolvedCatalog work subjects assumptions := by + intro hclosed + have hdependency : unresolvedCatalog.dependsOn first unresolved := by + exact .inr ⟨rfl, rfl⟩ + have hresult := hclosed (item := firstItem) (target := unresolved) + (by simp [work, firstItem]) hdependency + rcases hresult with hsubject | hassumption + · simp at hsubject + · simp at hassumption + +/-- Two distinct standalone nodes depending on one another. -/ +def cyclicCatalog : DependencyCatalog where + blockOf := id + dependsOn := fun source target => + (source = first ∧ target = second) ∨ + (source = second ∧ target = first) + blockOf_idem := fun _ => rfl + +/-- No rank/schedule certificate can exist for the two-node cycle. -/ +theorem cyclicStandalones_not_wellFounded : + WellFoundedBlocks cyclicCatalog work subjects → False := by + intro hwf + apply hwf.noTwoCycle + (left := firstItem) (right := secondItem) + · simp [work, firstItem] + · simp [work, secondItem] + · exact .inl ⟨rfl, rfl⟩ + · exact .inr ⟨rfl, rfl⟩ + · simp [firstItem, AnonWorkItem.root] + · simp [secondItem, AnonWorkItem.root] + · rfl + · rfl + · simp [firstItem, secondItem, AnonWorkItem.root] + +end Ix.Tc.E1Fixture diff --git a/Ix/Tc/Verify/Driver/Model.lean b/Ix/Tc/Verify/Driver/Model.lean new file mode 100644 index 000000000..a51e486a0 --- /dev/null +++ b/Ix/Tc/Verify/Driver/Model.lean @@ -0,0 +1,369 @@ +import Ix.Tc.Verify.Check.BlockIdentity + +/-! +# Workset and dependency model + +This file is the semantic half of E1. It deliberately keeps three address +roles distinct while representing all of them with the production `Address` +type: + +* `AnonWorkItem.provenTargets` describes serialized input coverage; +* `AnonWorkItem.targets` describes declarations actually checked/admitted; +* `DependencyCatalog.dependsOn` describes semantic declaration references. + +A mutual block is one atomic dependency node. Its serialized block address +and every projection address have the same `blockOf` image. Standalones map +to themselves. +-/ + +namespace Ix.Tc + +/-! ## Canonical finite address sets -/ + +/-- A duplicate-free finite address collection. The list is retained as the +canonical representative later bound to a claim root; semantic membership is +ordinary propositional list membership. -/ +structure FiniteAddressSet where + entries : List Address + nodup : entries.Nodup + +namespace FiniteAddressSet + +def Contains (set : FiniteAddressSet) (addr : Address) : Prop := + addr ∈ set.entries + +instance : Membership Address FiniteAddressSet := ⟨Contains⟩ + +def Disjoint (left right : FiniteAddressSet) : Prop := + ∀ ⦃addr⦄, addr ∈ left → addr ∈ right → False + +@[simp] theorem mem_mk {entries : List Address} {nodup : entries.Nodup} + {addr : Address} : + addr ∈ (⟨entries, nodup⟩ : FiniteAddressSet) ↔ addr ∈ entries := + Iff.rfl + +end FiniteAddressSet + +/-! ## Work coverage -/ + +namespace AnonWorkItem + +/-- The collapsed dependency node represented by this work item. -/ +def root : AnonWorkItem → Address + | .standalone addr => addr + | .block blockAddr _ _ => blockAddr + +/-- Propositional coverage by the production `provenTargets` array. -/ +def Covers (item : AnonWorkItem) (addr : Address) : Prop := + addr ∈ item.provenTargets + +end AnonWorkItem + +/-- `subjects` is exactly the union of the production work items' serialized +coverage. The second field rules out duplicate work entries, and the third +rules out assigning one address to two distinct work items. -/ +structure WorkCovers (work : Array AnonWorkItem) + (subjects : FiniteAddressSet) : Prop where + exact : ∀ addr, addr ∈ subjects ↔ + ∃ item, item ∈ work ∧ item.Covers addr + workNodup : work.toList.Nodup + unique : ∀ {addr left right}, + left ∈ work → right ∈ work → + left.Covers addr → right.Covers addr → left = right + +namespace WorkCovers + +theorem covered {work : Array AnonWorkItem} {subjects : FiniteAddressSet} + (h : WorkCovers work subjects) {addr : Address} + (haddr : addr ∈ subjects) : + ∃ item, item ∈ work ∧ item.Covers addr := + (h.exact addr).1 haddr + +theorem subjectOfCovered {work : Array AnonWorkItem} + {subjects : FiniteAddressSet} (h : WorkCovers work subjects) + {item : AnonWorkItem} (hitem : item ∈ work) {addr : Address} + (haddr : item.Covers addr) : addr ∈ subjects := + (h.exact addr).2 ⟨item, hitem, haddr⟩ + +end WorkCovers + +/-! ## Semantic dependencies and collapsed blocks -/ + +/-- Abstract semantic reference catalog. Both fields use the exact +production `Address` domain. `blockOf` collapses projection addresses to +their owning Muts address and fixes already-collapsed nodes. -/ +structure DependencyCatalog where + blockOf : Address → Address + dependsOn : Address → Address → Prop + blockOf_idem : ∀ addr, blockOf (blockOf addr) = blockOf addr + +/-- Every serialized address covered by an item collapses to that item's +single dependency node. -/ +def WorkMatchesCatalog (catalog : DependencyCatalog) + (work : Array AnonWorkItem) : Prop := + ∀ {item}, item ∈ work → ∀ {addr}, item.Covers addr → + catalog.blockOf addr = item.root + +/-- A dependency edge between distinct collapsed subject nodes. The edge is +oriented from the prerequisite node to the dependent node, matching Lean's +`WellFounded` convention. -/ +def CollapsedDependency (catalog : DependencyCatalog) + (work : Array AnonWorkItem) (prerequisite dependent : Address) : Prop := + ∃ item, item ∈ work ∧ item.root = dependent ∧ + ∃ target, catalog.dependsOn dependent target ∧ + catalog.blockOf target = prerequisite ∧ prerequisite ≠ dependent + +/-- Every semantic dependency of every selected subject item is either +another exact subject address or an explicit external assumption. -/ +def DepsClosed (catalog : DependencyCatalog) (work : Array AnonWorkItem) + (subjects assumptions : FiniteAddressSet) : Prop := + ∀ {item}, item ∈ work → ∀ {target}, + catalog.dependsOn item.root target → + target ∈ subjects ∨ target ∈ assumptions + +/-! ## Semantic acceptance of work items -/ + +namespace VerifyWorld + +/-- Semantic acceptance for a raw address. Declaration projection and +standalone addresses are accepted by `trusted`; a Muts envelope address is +accepted by the atomic `AcceptedBlock` fact established in E0. -/ +def AcceptsAddress (world : VerifyWorld) (addr : Address) : Prop := + world.trusted (⟨addr, ()⟩ : KId .anon) ∨ + world.AcceptedBlock (⟨addr, ()⟩ : KId .anon) + +theorem AcceptsAddress.mono {before after : VerifyWorld} + (hle : before ≤ after) {addr : Address} + (h : before.AcceptsAddress addr) : after.AcceptsAddress addr := by + rcases h with htrusted | hblock + · exact .inl (hle.trusted htrusted) + · exact .inr (hblock.mono hle) + +end VerifyWorld + +/-- Exact semantic meaning of accepting one production work item. A block +must publish its atomic block fact and trust every checker target; the Muts +envelope itself is intentionally not inserted into `VerifyWorld.trusted`. -/ +def WorkItemAccepted (world : VerifyWorld) : AnonWorkItem → Prop + | .standalone addr => world.trusted (⟨addr, ()⟩ : KId .anon) + | .block blockAddr _ targets => + world.AcceptedBlock (⟨blockAddr, ()⟩ : KId .anon) ∧ + ∀ addr, addr ∈ targets → + world.trusted (⟨addr, ()⟩ : KId .anon) + +namespace WorkItemAccepted + +theorem mono {before after : VerifyWorld} (hle : before ≤ after) + {item : AnonWorkItem} (h : WorkItemAccepted before item) : + WorkItemAccepted after item := by + cases item with + | standalone addr => exact hle.trusted h + | block blockAddr primary targets => + exact ⟨h.1.mono hle, fun addr haddr => hle.trusted (h.2 addr haddr)⟩ + +/-- Semantic item acceptance covers every raw address in `provenTargets`, +using block acceptance for the envelope and declaration trust elsewhere. -/ +theorem acceptsAddress {world : VerifyWorld} {item : AnonWorkItem} + (h : WorkItemAccepted world item) {addr : Address} + (haddr : item.Covers addr) : world.AcceptsAddress addr := by + cases item with + | standalone target => + simp only [AnonWorkItem.Covers, AnonWorkItem.provenTargets, + Array.mem_singleton] at haddr + subst addr + exact .inl h + | block blockAddr primary targets => + simp only [AnonWorkItem.Covers, AnonWorkItem.provenTargets, + Array.mem_append, Array.mem_singleton] at haddr + rcases haddr with haddr | haddr + · subst addr + exact .inr h.1 + · exact .inl (h.2 addr haddr) + +end WorkItemAccepted + +/-- The external assumptions already have semantic meaning in the baseline +Theory world. -/ +def AssumptionsWF (baseline : VerifyWorld) + (assumptions : FiniteAddressSet) : Prop := + ∀ {addr}, addr ∈ assumptions → baseline.AcceptsAddress addr + +/-- Per-item C2 consequence needed by composition. The rule is reusable at +any extension of `baseline`: once every dependency outside the item's own +collapsed block is accepted, the item can be admitted atomically. -/ +def AllAccepted (baseline : VerifyWorld) (catalog : DependencyCatalog) + (work : Array AnonWorkItem) : Prop := + ∀ item, item ∈ work → ∀ before, baseline ≤ before → + (∀ {target}, catalog.dependsOn item.root target → + catalog.blockOf target ≠ item.root → before.AcceptsAddress target) → + ∃ after, before ≤ after ∧ WorkItemAccepted after item + +/-! ## Constructive well-founded block schedules -/ + +/-- An item is ready after `done` when every subject dependency is either +internal to its own collapsed block or covered by an already completed item. +External assumptions are handled separately by `DepsClosed` and +`AssumptionsWF`. -/ +def WorkReadyAfter (catalog : DependencyCatalog) + (subjects : FiniteAddressSet) (done : List AnonWorkItem) + (item : AnonWorkItem) : Prop := + ∀ {target}, catalog.dependsOn item.root target → target ∈ subjects → + catalog.blockOf target = item.root ∨ + ∃ prior, prior ∈ done ∧ prior.Covers target + +/-- An executable topological certificate, indexed by the reverse list of +items already completed. -/ +inductive TopologicalFrom (catalog : DependencyCatalog) + (subjects : FiniteAddressSet) : + List AnonWorkItem → List AnonWorkItem → Prop + | nil (done) : TopologicalFrom catalog subjects done [] + | cons {done item rest} : + WorkReadyAfter catalog subjects done item → + TopologicalFrom catalog subjects (item :: done) rest → + TopologicalFrom catalog subjects done (item :: rest) + +/-- Finite well-foundedness certificate for the collapsed dependency graph. +The schedule is a permutation of the work array and is directly usable by +the composition proof. The rank field separately exposes the mathematical +decrease used to rule out dependency cycles. -/ +structure WellFoundedBlocks (catalog : DependencyCatalog) + (work : Array AnonWorkItem) (subjects : FiniteAddressSet) where + schedule : List AnonWorkItem + permutation : schedule.Perm work.toList + topological : TopologicalFrom catalog subjects [] schedule + rank : Address → Nat + decreases : ∀ {item target}, item ∈ work → + catalog.dependsOn item.root target → target ∈ subjects → + catalog.blockOf target ≠ item.root → + rank (catalog.blockOf target) < rank item.root + +namespace WellFoundedBlocks + +/-- Two distinct collapsed nodes cannot depend on each other. -/ +theorem noTwoCycle {catalog : DependencyCatalog} + {work : Array AnonWorkItem} {subjects : FiniteAddressSet} + (h : WellFoundedBlocks catalog work subjects) + {left right : AnonWorkItem} + (hleft : left ∈ work) (hright : right ∈ work) + (hlr : catalog.dependsOn left.root right.root) + (hrl : catalog.dependsOn right.root left.root) + (hsubjectLeft : left.root ∈ subjects) + (hsubjectRight : right.root ∈ subjects) + (hleftFixed : catalog.blockOf left.root = left.root) + (hrightFixed : catalog.blockOf right.root = right.root) + (hne : left.root ≠ right.root) : False := by + have hrightLeft : catalog.blockOf right.root ≠ left.root := by + simpa [hrightFixed] using hne.symm + have hleftRight : catalog.blockOf left.root ≠ right.root := by + simpa [hleftFixed] using hne + have h₁ := h.decreases hleft hlr hsubjectRight hrightLeft + have h₂ := h.decreases hright hrl hsubjectLeft hleftRight + rw [hrightFixed] at h₁ + rw [hleftFixed] at h₂ + exact (Nat.not_lt_of_ge (Nat.le_of_lt h₂)) h₁ + +end WellFoundedBlocks + +/-! ## Checked-set composition -/ + +/-- C3's semantic result: some final Theory world extends the baseline, +accepts exactly the advertised subject domain at the raw-address interface, +retains every explicit assumption, and records the closure/disjointness +contracts needed for later claim-root binding. -/ +def SubjectWF (baseline : VerifyWorld) (catalog : DependencyCatalog) + (work : Array AnonWorkItem) (subjects assumptions : FiniteAddressSet) : + Prop := + ∃ finalWorld : VerifyWorld, + baseline ≤ finalWorld ∧ + (∀ {addr}, addr ∈ subjects → finalWorld.AcceptsAddress addr) ∧ + (∀ {addr}, addr ∈ assumptions → finalWorld.AcceptsAddress addr) ∧ + WorkCovers work subjects ∧ + DepsClosed catalog work subjects assumptions ∧ + subjects.Disjoint assumptions + +private theorem composeTopological + {baseline : VerifyWorld} {catalog : DependencyCatalog} + {work : Array AnonWorkItem} {subjects assumptions : FiniteAddressSet} + (hall : AllAccepted baseline catalog work) + (hdeps : DepsClosed catalog work subjects assumptions) + (hassumptions : AssumptionsWF baseline assumptions) + {done schedule : List AnonWorkItem} {current : VerifyWorld} + (hcurrent : baseline ≤ current) + (hdone : ∀ {item}, item ∈ done → WorkItemAccepted current item) + (hschedule : ∀ {item}, item ∈ schedule → item ∈ work) + (htopo : TopologicalFrom catalog subjects done schedule) : + ∃ final, current ≤ final ∧ + ∀ {item}, item ∈ done ∨ item ∈ schedule → + WorkItemAccepted final item := by + induction htopo generalizing current with + | nil done => + exact ⟨current, VerifyWorld.LE.rfl, fun hitem => by + rcases hitem with hitem | hitem + · exact hdone hitem + · simp at hitem⟩ + | @cons done item rest hready hrest ih => + have hitemWork : item ∈ work := hschedule (by simp) + have hdependencies : ∀ {target}, + catalog.dependsOn item.root target → + catalog.blockOf target ≠ item.root → + current.AcceptsAddress target := by + intro target htarget houtside + rcases hdeps hitemWork htarget with hsubject | hassumption + · rcases hready htarget hsubject with hinternal | hprior + · exact False.elim (houtside hinternal) + · obtain ⟨prior, hpriorDone, hpriorTarget⟩ := hprior + exact (hdone hpriorDone).acceptsAddress hpriorTarget + · exact (hassumptions hassumption).mono hcurrent + obtain ⟨next, hnext, haccepted⟩ := + hall item hitemWork current hcurrent hdependencies + have hdoneNext : ∀ {candidate}, candidate ∈ item :: done → + WorkItemAccepted next candidate := by + intro candidate hcandidate + rcases List.mem_cons.mp hcandidate with hcandidate | hcandidate + · subst candidate + exact haccepted + · exact (hdone hcandidate).mono hnext + have hrestWork : ∀ {candidate}, candidate ∈ rest → candidate ∈ work := by + intro candidate hcandidate + exact hschedule (by simp [hcandidate]) + obtain ⟨final, hfinal, hallFinal⟩ := + ih (hcurrent.trans hnext) hdoneNext hrestWork + refine ⟨final, hnext.trans hfinal, ?_⟩ + intro candidate hcandidate + apply hallFinal + rcases hcandidate with hdoneOld | hscheduleAll + · exact .inl (.tail _ hdoneOld) + · rcases List.mem_cons.mp hscheduleAll with hhead | hrestMember + · subst candidate + exact .inl (.head _) + · exact .inr hrestMember + +/-- The E1 checked-set theorem. Successful per-item C2 rules are reordered +by the constructive collapsed-block schedule; runtime address order is not +assumed to be topological. -/ +theorem acceptedWorkset_subjectWF + {baseline : VerifyWorld} {catalog : DependencyCatalog} + {work : Array AnonWorkItem} {subjects assumptions : FiniteAddressSet} + (hall : AllAccepted baseline catalog work) + (hcovers : WorkCovers work subjects) + (hdeps : DepsClosed catalog work subjects assumptions) + (hwf : WellFoundedBlocks catalog work subjects) + (hassumptions : AssumptionsWF baseline assumptions) + (hdisjoint : subjects.Disjoint assumptions) : + SubjectWF baseline catalog work subjects assumptions := by + have hschedule : ∀ {item}, item ∈ hwf.schedule → item ∈ work := by + intro item hitem + have hlist : item ∈ work.toList := (hwf.permutation.mem_iff).1 hitem + simpa using hlist + obtain ⟨final, hfinal, haccepted⟩ := composeTopological hall hdeps + hassumptions VerifyWorld.LE.rfl (by simp) hschedule hwf.topological + refine ⟨final, hfinal, ?_, ?_, hcovers, hdeps, hdisjoint⟩ + · intro addr haddr + obtain ⟨item, hitem, hcovered⟩ := hcovers.covered haddr + have hitemList : item ∈ work.toList := by simpa using hitem + exact (haccepted (.inr ((hwf.permutation.mem_iff).2 hitemList))) + |>.acceptsAddress hcovered + · intro addr haddr + exact (hassumptions haddr).mono hfinal + +end Ix.Tc diff --git a/Ix/Tc/Verify/Driver/Serial.lean b/Ix/Tc/Verify/Driver/Serial.lean new file mode 100644 index 000000000..1a19001f4 --- /dev/null +++ b/Ix/Tc/Verify/Driver/Serial.lean @@ -0,0 +1,229 @@ +import Ix.Tc.Verify.Driver.Enumeration + +/-! +# Serial `checkEnvAnon` composition + +This file connects the result-only public driver API back to the successful +per-item checker calls which produced it. A failed call always contributes +at least one `CheckResult` for a well-formed production work item, so an +all-success result array yields a concrete serial success trace. + +`CheckSuccessSound` is the named C2 adapter: it consumes an actual successful +`TcM.checkConst` execution and returns the reusable semantic admission rule +needed by dependency-order composition. The serial corollary therefore does +not assume `AllAccepted` directly. +-/ + +namespace Ix.Tc + +/-- Every public result row reports success. -/ +def AllCheckResultsSucceeded (results : Array CheckResult) : Prop := + ∀ result, result ∈ results → result.err? = none + +@[simp] theorem finishAnonCheckItem_results + (cfg : CheckCfg) (before : AnonCheckLoopState) + (item : AnonWorkItem) (checker : TcState .anon) + (err? : Option String) : + (finishAnonCheckItem cfg before item checker err?).results = + before.results ++ item.targets.map fun target => ⟨target, err?⟩ := by + simp [finishAnonCheckItem] + split <;> rfl + +/-- One loop step never removes an already emitted result. -/ +theorem runAnonCheckItem_preserves_result + (cfg : CheckCfg) (before : AnonCheckLoopState) + (item : AnonWorkItem) {result : CheckResult} + (hresult : result ∈ before.results) : + result ∈ (runAnonCheckItem cfg before item).results := by + cases hrun : (TcM.checkConst + (⟨item.primary, ()⟩ : KId .anon)).run before.checker with + | ok value checker => + cases value + simp only [runAnonCheckItem, hrun, finishAnonCheckItem_results] + exact Array.mem_append.mpr (.inl hresult) + | error err checker => + simp only [runAnonCheckItem, hrun, finishAnonCheckItem_results] + exact Array.mem_append.mpr (.inl hresult) + +/-- The recursive serial loop never removes an existing result. -/ +theorem runAnonCheckList_preserves_result + (cfg : CheckCfg) (work : List AnonWorkItem) + (before : AnonCheckLoopState) {result : CheckResult} + (hresult : result ∈ before.results) : + result ∈ (runAnonCheckList cfg work before).results := by + induction work generalizing before with + | nil => exact hresult + | cons item rest ih => + apply ih + exact runAnonCheckItem_preserves_result cfg before item hresult + +/-- A failed checker call contributes a row carrying that failure for every +target of the item. -/ +theorem runAnonCheckItem_error_result + (cfg : CheckCfg) (before : AnonCheckLoopState) + (item : AnonWorkItem) {err : TcError .anon} {checker : TcState .anon} + (hrun : (TcM.checkConst + (⟨item.primary, ()⟩ : KId .anon)).run before.checker = + .error err checker) + {target : Address} (htarget : target ∈ item.targets) : + (⟨target, some (toString err)⟩ : CheckResult) ∈ + (runAnonCheckItem cfg before item).results := by + simp only [runAnonCheckItem, hrun, finishAnonCheckItem_results] + apply Array.mem_append.mpr + exact .inr (Array.mem_map_of_mem htarget) + +/-- Exact successful-call trace of the serial production loop. Cache +clearing is retained in the indexed next accumulator. -/ +inductive SerialChecksSucceeded (cfg : CheckCfg) : + AnonCheckLoopState → List AnonWorkItem → Prop + | nil (state) : SerialChecksSucceeded cfg state [] + | cons {before : AnonCheckLoopState} {item : AnonWorkItem} + {rest : List AnonWorkItem} {checker : TcState .anon} : + (TcM.checkConst + (⟨item.primary, ()⟩ : KId .anon)).run before.checker = + .ok () checker → + SerialChecksSucceeded cfg + (finishAnonCheckItem cfg before item checker none) rest → + SerialChecksSucceeded cfg before (item :: rest) + +/-- An all-success public result array exposes the exact successful checker +call for every work item. Nonempty target arrays are essential: without +them a failing item could emit no observable row. -/ +theorem serialChecksSucceeded_of_results + (cfg : CheckCfg) (work : List AnonWorkItem) + (before : AnonCheckLoopState) + (hnonempty : ∀ item, item ∈ work → + ∃ target, target ∈ item.targets) + (hresults : AllCheckResultsSucceeded + (runAnonCheckList cfg work before).results) : + SerialChecksSucceeded cfg before work := by + induction work generalizing before with + | nil => exact .nil before + | cons item rest ih => + cases hrun : (TcM.checkConst + (⟨item.primary, ()⟩ : KId .anon)).run before.checker with + | ok value checker => + cases value + apply SerialChecksSucceeded.cons hrun + apply ih + · intro candidate hcandidate + exact hnonempty candidate (by simp [hcandidate]) + · simpa [runAnonCheckList, runAnonCheckItem, hrun] using hresults + | error err checker => + exfalso + obtain ⟨target, htarget⟩ := hnonempty item (by simp) + let failed : CheckResult := ⟨target, some (toString err)⟩ + have hfailedStep : failed ∈ + (runAnonCheckItem cfg before item).results := by + exact runAnonCheckItem_error_result cfg before item hrun htarget + have hfailedFinal : failed ∈ + (runAnonCheckList cfg rest + (runAnonCheckItem cfg before item)).results := + runAnonCheckList_preserves_result cfg rest _ hfailedStep + have hnone := hresults failed (by + simpa [runAnonCheckList] using hfailedFinal) + simp [failed] at hnone + +namespace SerialChecksSucceeded + +/-- Every list member has a concrete successful production call somewhere +in the serial trace. -/ +theorem successfulStep {cfg : CheckCfg} {initial : AnonCheckLoopState} + {work : List AnonWorkItem} + (h : SerialChecksSucceeded cfg initial work) + {item : AnonWorkItem} (hitem : item ∈ work) : + ∃ before : AnonCheckLoopState, ∃ checker : TcState .anon, + (TcM.checkConst + (⟨item.primary, ()⟩ : KId .anon)).run before.checker = + .ok () checker := by + induction h with + | nil state => simp at hitem + | @cons before head rest checker hrun hrest ih => + rcases List.mem_cons.mp hitem with hhead | htail + · subst item + exact ⟨before, checker, hrun⟩ + · exact ih htail + +end SerialChecksSucceeded + +/-- The concrete C2 adapter used by the serial corollary. Its premise is an +actual successful `TcM.checkConst` call; its conclusion is the reusable +dependency-relative admission rule produced by the K3/E0 per-item theorem. -/ +def CheckSuccessSound (baseline : VerifyWorld) + (catalog : DependencyCatalog) (work : Array AnonWorkItem) : Prop := + ∀ item, item ∈ work → + ∀ {before : AnonCheckLoopState} {checker : TcState .anon}, + (TcM.checkConst + (⟨item.primary, ()⟩ : KId .anon)).run before.checker = + .ok () checker → + ∀ current, baseline ≤ current → + (∀ {target}, catalog.dependsOn item.root target → + catalog.blockOf target ≠ item.root → + current.AcceptsAddress target) → + ∃ after, current ≤ after ∧ WorkItemAccepted after item + +/-- A successful serial trace plus the concrete C2 adapter constructs the +abstract admission predicate needed by topological composition. -/ +theorem SerialChecksSucceeded.allAccepted + {cfg : CheckCfg} {initial : AnonCheckLoopState} + {work : Array AnonWorkItem} {baseline : VerifyWorld} + {catalog : DependencyCatalog} + (htrace : SerialChecksSucceeded cfg initial work.toList) + (hsound : CheckSuccessSound baseline catalog work) : + AllAccepted baseline catalog work := by + intro item hitem current hbaseline hdeps + have hitemList : item ∈ work.toList := by simpa using hitem + obtain ⟨before, checker, hrun⟩ := htrace.successfulStep hitemList + exact hsound item hitem hrun current hbaseline hdeps + +namespace AnonWorkEnvWF + +/-- Normal form of the public serial driver on a structurally valid Ixon +environment. -/ +theorem checkEnvAnon_eq_serial {env : Ixon.Env} + (h : AnonWorkEnvWF env) (cfg : CheckCfg) : + checkEnvAnon env cfg = .ok + (runAnonCheckList cfg (expectedAnonWork env).toList + (initialAnonCheckLoopState env cfg)).results := by + unfold checkEnvAnon + rw [h.buildAnonWork_eq_expected] + rfl + +/-- E1's production serial-driver corollary. All emitted rows succeeding is +converted to concrete per-item success traces, those traces are interpreted +through the C2 success rule, and the resulting admissions are reordered by +the proved collapsed-block schedule. -/ +theorem checkEnvAnon_subjectWF + {env : Ixon.Env} (h : AnonWorkEnvWF env) + (hblock : IxonEnv.BlockOfIdempotent env) + {baseline : VerifyWorld} {assumptions : FiniteAddressSet} + (hdeps : DepsClosed (IxonEnv.dependencyCatalog env hblock) + (expectedAnonWork env) h.subjects assumptions) + (hwf : WellFoundedBlocks (IxonEnv.dependencyCatalog env hblock) + (expectedAnonWork env) h.subjects) + (hassumptions : AssumptionsWF baseline assumptions) + (hdisjoint : h.subjects.Disjoint assumptions) + (hsound : CheckSuccessSound baseline + (IxonEnv.dependencyCatalog env hblock) (expectedAnonWork env)) + (cfg : CheckCfg) {results : Array CheckResult} + (hrun : checkEnvAnon env cfg = .ok results) + (hresults : AllCheckResultsSucceeded results) : + SubjectWF baseline (IxonEnv.dependencyCatalog env hblock) + (expectedAnonWork env) h.subjects assumptions := by + rw [h.checkEnvAnon_eq_serial cfg] at hrun + have hresultsEq := Except.ok.inj hrun + rw [← hresultsEq] at hresults + have hnonempty : ∀ item, item ∈ (expectedAnonWork env).toList → + ∃ target, target ∈ item.targets := by + intro item hitem + refine ⟨item.primary, ?_⟩ + exact h.expected_primary_mem_targets (by simpa using hitem) + have htrace := serialChecksSucceeded_of_results cfg + (expectedAnonWork env).toList (initialAnonCheckLoopState env cfg) + hnonempty hresults + exact acceptedWorkset_subjectWF (htrace.allAccepted hsound) + h.expectedAnonWork_covers hdeps hwf hassumptions hdisjoint + +end AnonWorkEnvWF + +end Ix.Tc diff --git a/Ix/Tc/Verify/Driver/SupportedAcceptance.lean b/Ix/Tc/Verify/Driver/SupportedAcceptance.lean new file mode 100644 index 000000000..b5f0e51ba --- /dev/null +++ b/Ix/Tc/Verify/Driver/SupportedAcceptance.lean @@ -0,0 +1,543 @@ +import Ix.Tc.Verify.Check.PublicBlocks +import Ix.Tc.Verify.Check.PublicStandalone +import Ix.Tc.Verify.Driver.Serial + +/-! +# Supported production-checker acceptance + +This module is the concrete adapter between the per-call K3/E0 theorems and +E1's serial checked-set composition. It intentionally does not contain an +opaque `checkConst succeeded, therefore the declaration is sound` callback. +Instead, every reusable successful call must expose: + +* one finite, run-scoped recursive-method context; +* the exact physical/world cache and block-table invariants for that call; +* agreement between the source work item and the block selected by the + production router; +* declaration-local K3 resources for an observed standalone route; and +* either constructive scoped singleton-definition evidence or an explicit + E2 oracle-backed resource for every fresh coordinated body. + +The final theorem below turns those operational resources into +`CheckSuccessSound`, which `Driver.Serial` then composes into `SubjectWF`. +The source-to-kernel route agreement remains an explicit representation +premise until the later ingress/refinement phase discharges it generically. +-/ + +namespace Ix.Tc + +namespace AnonWorkItem + +/-- Exact relation between a production work item and the result observed +from `coordinatedBlockFor`. A standalone source entry may be checked either +through K3 (axioms) or through its singleton coordinated block +(definitions/recursors). A Muts work item must route to its advertised +envelope address. -/ +def SelectedBlockMatches (item : AnonWorkItem) : + Option (KId .anon) → Prop + | selected => match item with + | .standalone _ => True + | .block blockAddr _ _ => + selected = some (⟨blockAddr, ()⟩ : KId .anon) + +end AnonWorkItem + +/-! ## Standalone K3 resources -/ + +/-- The declaration-local premises needed when the actual production router +selects K3's standalone path. None of these fields assumes a declaration-WF +transition or target trust; `PendingDecl` explicitly asserts the opposite. -/ +structure SupportedStandaloneResources + {initial : TcState .anon} {id : KId .anon} + {requests : List WalkerRequest} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (context : ScopedRecursiveMethodRunContext initial (TcM.checkConst id) + requests trProj world support) + (concrete : KConst .anon) : Type where + pipelines : ScopedStandalonePipelineResources context.model support + (context.calls (initial.recFuel.toNat + 1)) + (Ix.Tc.methodsN (m := .anon) initial.recFuel.toNat) + decl : Lean4Lean.VDecl + projection : trProj.SubstCompatible + literals : ∀ literal, world.venv.ContainsLits literal + pending : PendingDecl trProj world id decl + catalog : world.catalog id = some concrete + validation : StandaloneValidationResources support concrete + covered : pipelines.Covers concrete + collision : support.CollisionFree + uvars : context.model.keys.uvars = concrete.lvls.toNat + resetScope : context.model.ResetPreservesScope + route : StandaloneRoute + (ScopedWhnfStateInv context.model .noAccel + (kernelCacheSemantics context.model.keys trProj) support []) + (Ix.Tc.methodsN (m := .anon) initial.recFuel.toNat) concrete + +namespace SupportedStandaloneResources + +/-- Apply K3 to the exact successful public call and retain only the world +extension and target-trust facts required by E1. -/ +theorem promotes + {initial after : TcState .anon} {id : KId .anon} + {requests : List WalkerRequest} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {context : ScopedRecursiveMethodRunContext initial (TcM.checkConst id) + requests trProj world support} + {concrete : KConst .anon} + (resources : SupportedStandaloneResources context concrete) + (hI : ScopedWhnfStateInv context.model .noAccel + (kernelCacheSemantics context.model.keys trProj) support [] initial) + (hfault : TcM.LazyFaultPreserves + (ScopedWhnfStateInv context.model .noAccel + (kernelCacheSemantics context.model.keys trProj) support [])) + (hrun : TcM.checkConst id initial = .ok () after) : + ∃ world', world ≤ world' ∧ world'.trusted id := by + have hresult := TcM.checkConst.wf context resources.pipelines + resources.projection resources.literals resources.pending + resources.catalog resources.validation resources.covered + resources.collision resources.uvars resources.resetScope resources.route + hI hfault hrun + obtain ⟨world', hpromotes, _hpost, _hscope, _htrusted⟩ := hresult.2 + exact ⟨world', hpromotes.1, hpromotes.2 rfl⟩ + +end SupportedStandaloneResources + +/-! ## Coordinated-body resources -/ + +/-- Exhaustive body evidence supported by the E3-S adapter. + +The first constructor is constructive K3 evidence for the only definition +block shape currently modeled atomically by Lean4Lean: one definition. The +second constructor keeps the E2 inductive/recursor oracle visible. In +particular there is no constructor containing a prebuilt +`CertifiedBlockBodySuccess`. -/ +inductive SupportedBlockBodyResources + {initial : TcState .anon} {id : KId .anon} + {requests : List WalkerRequest} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (context : ScopedRecursiveMethodRunContext initial (TcM.checkConst id) + requests trProj world support) : + (block requested : KId .anon) → Array (KId .anon) → CheckBlockKind → + TcState .anon → TcState .anon → Prop + | singletonDefinition + {block requested member : KId .anon} {concrete : KConst .anon} + {decl : Lean4Lean.VDecl} {before after : TcState .anon} + (pipelines : ScopedStandalonePipelineResources context.model support + (context.calls (initial.recFuel.toNat + 1)) + (Ix.Tc.methodsN (m := .anon) initial.recFuel.toNat)) + (projection : trProj.SubstCompatible) + (literals : ∀ literal, world.venv.ContainsLits literal) + (pending : PendingDecl trProj world member decl) + (catalog : world.catalog member = some concrete) + (validation : StandaloneValidationResources support concrete) + (covered : pipelines.Covers concrete) + (collision : support.CollisionFree) + (uvars : context.model.keys.uvars = concrete.lvls.toNat) + (resetScope : context.model.ResetPreservesScope) + (initialInv : ScopedWhnfStateInv context.model .noAccel + (kernelCacheSemantics context.model.keys trProj) support [] before) + (lazyFault : TcM.LazyFaultPreserves + (ScopedWhnfStateInv context.model .noAccel + (kernelCacheSemantics context.model.keys trProj) support [])) + (blocksAfter : LoadedBlocksAgrees world.blocks after.env) : + SupportedBlockBodyResources context block requested #[member] .defn + before after + | oracleBacked + {block requested : KId .anon} {members : Array (KId .anon)} + {kind : CheckBlockKind} {before after : TcState .anon} + (resources : OracleBackedBlockResources + (kernelCacheSemantics context.model.keys trProj) trProj world support + members kind after) : + SupportedBlockBodyResources context block requested members kind before + after + +namespace SupportedBlockBodyResources + +/-- Turn one transparent supported-body constructor into the exact E0 body +certificate for the observed trace. -/ +theorem certify + {initial : TcState .anon} {id : KId .anon} + {requests : List WalkerRequest} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + {context : ScopedRecursiveMethodRunContext initial (TcM.checkConst id) + requests trProj world support} + {block requested : KId .anon} {members : Array (KId .anon)} + {kind : CheckBlockKind} {before after : TcState .anon} + (resources : SupportedBlockBodyResources context block requested members + kind before after) + (hexact : ExactCheckBlock world block members kind) + (trace : RecM.ExactBlockBodySuccessTrace + (Ix.Tc.methodsN (m := .anon) initial.recFuel.toNat) + block requested members kind before after) : + CertifiedBlockBodySuccess + (kernelCacheSemantics context.model.keys trProj) trProj world support + (Ix.Tc.methodsN (m := .anon) initial.recFuel.toNat) + block requested members kind before after := by + cases resources with + | singletonDefinition pipelines projection literals pending catalog + validation covered collision uvars resetScope initialInv lazyFault + blocksAfter => + let methods := Ix.Tc.methodsN (m := .anon) initial.recFuel.toNat + have hmethods : Methods.ScopedWFAtOn context.model .noAccel + (kernelCacheSemantics context.model.keys trProj) support + (context.calls (initial.recFuel.toNat + 1)) + (Methods.next methods) := by + simpa [methods] using context.schedule.nextSelected + have hpolicy : (Methods.next methods).PreservesInferOnly := + Methods.next_preservesInferOnly methods + (Methods.methodsN_concrete_preservesInferOnly + initial.recFuel.toNat) + simpa [methods] using RecM.certifySingletonDefinitionScoped pipelines + hmethods hpolicy projection literals pending catalog validation + covered collision uvars resetScope hexact trace initialInv lazyFault + blocksAfter + | oracleBacked oracle => + exact RecM.certifyOracleBackedBlock trace hexact oracle + +end SupportedBlockBodyResources + +/-! ## Certificate-backed coordinated blocks -/ + +/-- A coordinated block whose semantic meaning is supplied directly by an +explicit E2 oracle rather than by K3's standalone recursive-method proof. + +The oracle contains exactly the exact physical members which are not already +trusted in `world`. This residual form is important for reusable checked-set +composition: an arbitrary monotone current world may already contain a +proper subset, while a replayed successful block must still establish the +whole `WorkItemAccepted` fact without re-certifying an existing member. + +This resource is intentionally unavailable for definitions. Its semantic +authority is the named `InductiveOracle` boundary, and its member equation +prevents either an unrelated declaration or an already-trusted declaration +from appearing in the new trust delta. -/ +structure ResidualOracleBlockResources (world : VerifyWorld) + (blockAddr primary : Address) (targets : Array Address) : Type where + trProj : RawProjRel + members : Array (KId .anon) + kind : CheckBlockKind + oracleBacked : kind.OracleBacked + exactBlock : ExactCheckBlock world (⟨blockAddr, ()⟩ : KId .anon) + members kind + workCatalog : (AnonWorkItem.block blockAddr primary targets) + |>.MatchesBlockCatalog world.blocks + oracle : InductiveOracle trProj world.catalog world.nameOf world.trusted + world.venv + memberIff : ∀ id, + oracle.members id ↔ id ∈ members ∧ ¬world.trusted id + +namespace ResidualOracleBlockResources + +/-- If the exact work item is not accepted, at least one semantic template +member is still untrusted. This is the non-vacuity bridge used before +`InductiveOracle.restageMissing`; unlike an all-members freshness premise it +also handles safe partial/replay worlds. -/ +theorem missing_of_not_accepted + {world : VerifyWorld} {blockAddr primary : Address} + {targets : Array Address} {members : Array (KId .anon)} + {kind : CheckBlockKind} {member : KId .anon → Prop} + (exactBlock : ExactCheckBlock world + (⟨blockAddr, ()⟩ : KId .anon) members kind) + (workCatalog : (AnonWorkItem.block blockAddr primary targets) + |>.MatchesBlockCatalog world.blocks) + (memberIff : ∀ id, member id ↔ id ∈ members) + (hnot : ¬WorkItemAccepted world + (.block blockAddr primary targets)) : + ∃ id, member id ∧ ¬world.trusted id := by + by_contra hmissing + have htrusted : ∀ id, id ∈ members → world.trusted id := by + intro id hid + by_contra huntrusted + exact hmissing ⟨id, (memberIff id).2 hid, huntrusted⟩ + have haccepted : world.AcceptedBlock + (⟨blockAddr, ()⟩ : KId .anon) := + ⟨members, exactBlock.blockLookup, exactBlock.nonempty, htrusted⟩ + apply hnot + refine ⟨haccepted, ?_⟩ + obtain ⟨workMembers, hworkBlock, _hnonempty, _hprimary, htargets⟩ := + workCatalog.block_targets + have hmembers : workMembers = members := + Option.some.inj (hworkBlock.symm.trans exactBlock.blockLookup) + subst workMembers + intro addr haddr + rw [htargets] at haddr + obtain ⟨id, hid, haddr⟩ := Array.mem_map.mp haddr + have htrustedId := htrusted id hid + have hkId : (⟨id.addr, ()⟩ : KId .anon) = id := by + cases id with + | mk idAddr idName => cases idName; rfl + rw [← haddr, hkId] + exact htrustedId + +/-- Admit precisely the residual oracle members and recover the complete +atomic work-item predicate. Existing exact members are retained through the +old-trust side of `TrustBlock`; missing exact members enter through the +oracle side. -/ +theorem accepts + {world : VerifyWorld} {blockAddr primary : Address} + {targets : Array Address} + (resources : ResidualOracleBlockResources world blockAddr primary + targets) : + ∃ admittedWorld, world ≤ admittedWorld ∧ + WorkItemAccepted admittedWorld + (.block blockAddr primary targets) := by + let admittedWorld := world.admitOracle resources.oracle + have hle : world ≤ admittedWorld := + world.le_admitOracle resources.oracle + have htrusted : ∀ id, id ∈ resources.members → + admittedWorld.trusted id := by + intro id hmember + by_cases hold : world.trusted id + · exact resources.oracle.trust_old hold + · exact resources.oracle.trust_member + ((resources.memberIff id).2 ⟨hmember, hold⟩) + have haccepted : admittedWorld.AcceptedBlock + (⟨blockAddr, ()⟩ : KId .anon) := by + refine ⟨resources.members, ?_, resources.exactBlock.nonempty, + htrusted⟩ + simpa only [admittedWorld, VerifyWorld.admitOracle] using + resources.exactBlock.blockLookup + refine ⟨admittedWorld, hle, haccepted, ?_⟩ + obtain ⟨workMembers, hworkBlock, _hnonempty, _hprimary, htargets⟩ := + resources.workCatalog.block_targets + have hmembers : workMembers = resources.members := + Option.some.inj + (hworkBlock.symm.trans resources.exactBlock.blockLookup) + subst workMembers + intro addr haddr + rw [htargets] at haddr + obtain ⟨member, hmember, hmemberAddr⟩ := Array.mem_map.mp haddr + have hmemberTrusted := htrusted member hmember + have hid : (⟨member.addr, ()⟩ : KId .anon) = member := by + cases member with + | mk memberAddr memberName => cases memberName; rfl + rw [← hmemberAddr, hid] + exact hmemberTrusted + +end ResidualOracleBlockResources + +/-! ## One reusable production call -/ + +/-- Complete non-semantic resources for reinterpreting one successful serial +checker call in a particular current ghost world. The world may differ from +the runtime serial order: cache provenance therefore has to be re-established +for this exact `initial` state, rather than inferred from a result bit. + +`routeMatches` is the explicit Ixon-to-kernel representation seam. It says +only which physical block the observed production router selected; it grants +no typing or trust fact. -/ +structure SupportedCheckRun (world : VerifyWorld) (item : AnonWorkItem) + (initial : TcState .anon) : Type where + requests : List WalkerRequest + trProj : RawProjRel + support : RunSupport + context : ScopedRecursiveMethodRunContext initial + (TcM.checkConst (⟨item.primary, ()⟩ : KId .anon)) requests trProj world + support + initialInv : ScopedWhnfStateInv context.model .noAccel + (kernelCacheSemantics context.model.keys trProj) support [] initial + loadedBlocks : LoadedBlocksAgrees world.blocks initial.env + scopedLazyFault : TcM.LazyFaultPreserves + (ScopedWhnfStateInv context.model .noAccel + (kernelCacheSemantics context.model.keys trProj) support []) + coordinatedLazyFault : TcM.LazyFaultPreserves + (CoordinatedKernelStateWF + (kernelCacheSemantics context.model.keys trProj) trProj world support) + blockLazyFault : TcM.LazyFaultPreserves + (fun state => BlockStateWF trProj state world) + exactCatalog : ExactCoordinatedCatalog world + workCatalog : item.MatchesBlockCatalog world.blocks + routeMatches : ∀ {concrete : KConst .anon} {loaded routed : TcState .anon} + {selected : Option (KId .anon)}, + TcM.getConst (⟨item.primary, ()⟩ : KId .anon) initial = + .ok concrete loaded → + (RecM.coordinatedBlockFor concrete).run + (Ix.Tc.methodsN (m := .anon) initial.recFuel.toNat) loaded = + .ok selected routed → + item.SelectedBlockMatches selected + standalone : ∀ {concrete : KConst .anon} {loaded routed : TcState .anon}, + TcM.getConst (⟨item.primary, ()⟩ : KId .anon) initial = + .ok concrete loaded → + (RecM.coordinatedBlockFor concrete).run + (Ix.Tc.methodsN (m := .anon) initial.recFuel.toNat) loaded = + .ok none routed → + SupportedStandaloneResources context concrete + blockBody : ∀ {block : KId .anon} {members : Array (KId .anon)} + {kind : CheckBlockKind} {routed bodyAfter : TcState .anon}, + ExactCheckBlock world block members kind → + (⟨item.primary, ()⟩ : KId .anon) ∈ members → + RecM.ExactBlockBodySuccessTrace + (Ix.Tc.methodsN (m := .anon) initial.recFuel.toNat) + block (⟨item.primary, ()⟩ : KId .anon) members kind routed + bodyAfter → + SupportedBlockBodyResources context block + (⟨item.primary, ()⟩ : KId .anon) members kind routed bodyAfter + +namespace SupportedCheckRun + +/-- K3/E0 assembly for one actual successful production call. -/ +theorem accepts + {world : VerifyWorld} {item : AnonWorkItem} + {initial after : TcState .anon} + (resources : SupportedCheckRun world item initial) + (hrun : TcM.checkConst (⟨item.primary, ()⟩ : KId .anon) initial = + .ok () after) : + ∃ admittedWorld, world ≤ admittedWorld ∧ + WorkItemAccepted admittedWorld item := by + have hcoordinated : CoordinatedKernelStateWF + (kernelCacheSemantics resources.context.model.keys resources.trProj) + resources.trProj world resources.support initial := + ⟨resources.initialInv.1.1, resources.loadedBlocks⟩ + have hdisposition := TcM.checkConst.blockDisposition hcoordinated + resources.exactCatalog resources.coordinatedLazyFault + resources.blockLazyFault + (fun hexact hmember trace => + (resources.blockBody hexact hmember trace).certify hexact trace) + hrun + cases item with + | standalone addr => + cases hdisposition with + | @coordinated concrete loaded routed block members kind hget hroute + hexact hmember haccepted => + obtain ⟨admittedWorld, hle, hblock⟩ := haccepted.accepted + exact ⟨admittedWorld, hle, + (hexact.rebaseWorld hle).trusted hblock hmember⟩ + | @standalone concrete loaded routed hget hroute hmember => + have hresources := resources.standalone hget hroute + obtain ⟨admittedWorld, hle, htrusted⟩ := + hresources.promotes resources.initialInv + resources.scopedLazyFault hrun + exact ⟨admittedWorld, hle, htrusted⟩ + | block blockAddr primary targets => + cases hdisposition with + | @coordinated concrete loaded routed block members kind hget hroute + hexact hmember haccepted => + have hselected := resources.routeMatches hget hroute + change (some block : Option (KId .anon)) = + some (⟨blockAddr, ()⟩ : KId .anon) at hselected + have hblockEq : block = (⟨blockAddr, ()⟩ : KId .anon) := + Option.some.inj hselected + subst block + obtain ⟨workMembers, hworkBlock, _hnonempty, _hprimary, + htargets⟩ := resources.workCatalog.block_targets + have hmembers : workMembers = members := + Option.some.inj (hworkBlock.symm.trans hexact.blockLookup) + subst workMembers + obtain ⟨admittedWorld, hle, hblock⟩ := haccepted.accepted + refine ⟨admittedWorld, hle, hblock, ?_⟩ + intro addr haddr + rw [htargets] at haddr + obtain ⟨member, hmemberArray, hmemberAddr⟩ := + Array.mem_map.mp haddr + have htrusted := + (hexact.rebaseWorld hle).trusted hblock hmemberArray + have hid : (⟨member.addr, ()⟩ : KId .anon) = member := by + cases member with + | mk memberAddr memberName => cases memberName; rfl + rw [← hmemberAddr, hid] + exact htrusted + | @standalone concrete loaded routed hget hroute hmember => + have hselected := resources.routeMatches hget hroute + change (none : Option (KId .anon)) = + some (⟨blockAddr, ()⟩ : KId .anon) at hselected + contradiction + +end SupportedCheckRun + +/-! ## Reusable fragment and E1 composition -/ + +/-- Exhaustive semantic resources accepted by the supported-fragment +adapter. `operational` is the full K3/E0 state-and-cache route. +`certificateBackedBlock` is the narrower E2 route for inductive/recursor +blocks whose exact raw representation already has an explicit oracle; it +does not manufacture a standalone recursive-method context. -/ +inductive SupportedCheckEvidence (world : VerifyWorld) : + AnonWorkItem → TcState .anon → Type + | operational {item initial} : + SupportedCheckRun world item initial → + SupportedCheckEvidence world item initial + | certificateBackedBlock {blockAddr primary targets initial} : + ResidualOracleBlockResources world blockAddr primary targets → + SupportedCheckEvidence world (.block blockAddr primary targets) initial + +namespace SupportedCheckEvidence + +theorem accepts + {world : VerifyWorld} {item : AnonWorkItem} + {initial after : TcState .anon} + (evidence : SupportedCheckEvidence world item initial) + (hrun : TcM.checkConst (⟨item.primary, ()⟩ : KId .anon) initial = + .ok () after) : + ∃ admittedWorld, world ≤ admittedWorld ∧ + WorkItemAccepted admittedWorld item := by + cases evidence with + | operational resources => exact resources.accepts hrun + | certificateBackedBlock resources => exact resources.accepts + +end SupportedCheckEvidence + +/-- A precisely scoped fragment provider. Resources are requested only when +the item is not already accepted in `current`; this keeps the pending/fresh +K3 premise honest while allowing E1 to reuse the rule at arbitrary monotone +world extensions. The provider may use the accepted external dependencies +to establish the run's cache and declaration premises, but cannot assume its +own `WorkItemAccepted` conclusion. -/ +structure SupportedCheckFragment (baseline : VerifyWorld) + (catalog : DependencyCatalog) (work : Array AnonWorkItem) : Type where + resources : ∀ item, item ∈ work → + ∀ {before : AnonCheckLoopState} {checker : TcState .anon}, + (TcM.checkConst + (⟨item.primary, ()⟩ : KId .anon)).run before.checker = + .ok () checker → + ∀ current, baseline ≤ current → + (∀ {target}, catalog.dependsOn item.root target → + catalog.blockOf target ≠ item.root → + current.AcceptsAddress target) → + ¬WorkItemAccepted current item → + SupportedCheckEvidence current item before.checker + +namespace SupportedCheckFragment + +/-- The concrete K3/E0 adapter demanded by E1. -/ +theorem checkSuccessSound + {baseline : VerifyWorld} {catalog : DependencyCatalog} + {work : Array AnonWorkItem} + (fragment : SupportedCheckFragment baseline catalog work) : + CheckSuccessSound baseline catalog work := by + intro item hitem before checker hrun current hcurrent hdeps + by_cases haccepted : WorkItemAccepted current item + · exact ⟨current, VerifyWorld.LE.rfl, haccepted⟩ + · have resources := fragment.resources item hitem hrun current hcurrent + hdeps haccepted + exact resources.accepts hrun + +end SupportedCheckFragment + +namespace AnonWorkEnvWF + +/-- E3-S supported-fragment composition theorem. Successful `checkEnvAnon` +rows imply `SubjectWF` for the exact enumerated work/subject sets and the explicit +assumption set, provided every still-pending successful call belongs to the +transparent supported fragment above. -/ +theorem checkEnvAnon_supported_subjectWF + {env : Ixon.Env} (h : AnonWorkEnvWF env) + (hblock : IxonEnv.BlockOfIdempotent env) + {baseline : VerifyWorld} {assumptions : FiniteAddressSet} + (hdeps : DepsClosed (IxonEnv.dependencyCatalog env hblock) + (expectedAnonWork env) h.subjects assumptions) + (hwf : WellFoundedBlocks (IxonEnv.dependencyCatalog env hblock) + (expectedAnonWork env) h.subjects) + (hassumptions : AssumptionsWF baseline assumptions) + (hdisjoint : h.subjects.Disjoint assumptions) + (fragment : SupportedCheckFragment baseline + (IxonEnv.dependencyCatalog env hblock) (expectedAnonWork env)) + (cfg : CheckCfg) {results : Array CheckResult} + (hrun : checkEnvAnon env cfg = .ok results) + (hresults : AllCheckResultsSucceeded results) : + SubjectWF baseline (IxonEnv.dependencyCatalog env hblock) + (expectedAnonWork env) h.subjects assumptions := by + exact h.checkEnvAnon_subjectWF hblock hdeps hwf hassumptions hdisjoint + fragment.checkSuccessSound cfg hrun hresults + +end AnonWorkEnvWF + +end Ix.Tc diff --git a/Ix/Tc/Verify/Driver/SupportedAcceptanceFixtures.lean b/Ix/Tc/Verify/Driver/SupportedAcceptanceFixtures.lean new file mode 100644 index 000000000..d173279f8 --- /dev/null +++ b/Ix/Tc/Verify/Driver/SupportedAcceptanceFixtures.lean @@ -0,0 +1,99 @@ +import Ix.Tc.Verify.Driver.Fixtures +import Ix.Tc.Verify.Driver.SupportedAcceptance +import Ix.Tc.Verify.Inductive.EnumerationAcceptance + +/-! +# Supported-acceptance adversarial and inductive fixtures + +These fixtures guard the two representation-sensitive edges of the E3-S +adapter. The first pair proves that a Muts work item cannot be discharged by +an unrouted call or a call routed to a different envelope. The second joins +E2b's concrete Boolean family execution to the adapter's oracle-backed body +constructor; the only remaining inputs are the explicitly advertised scoped +recursive context and active cache invariant. +-/ + +namespace Ix.Tc + +namespace SupportedAcceptanceFixture + +def blockItem : AnonWorkItem := + .block E1Fixture.first E1Fixture.second #[E1Fixture.second] + +/-- A Muts item can never be interpreted as an observed standalone route. -/ +theorem block_rejects_standalone_route : + ¬blockItem.SelectedBlockMatches none := by + simp [blockItem, AnonWorkItem.SelectedBlockMatches] + +/-- A successful route to a distinct block cannot certify this work item. -/ +theorem block_rejects_wrong_route : + ¬blockItem.SelectedBlockMatches + (some (⟨E1Fixture.external, ()⟩ : KId .anon)) := by + simp [blockItem, AnonWorkItem.SelectedBlockMatches] + +/-- Standalone source entries deliberately admit either operational branch: +axioms use K3 directly, while singleton definitions and recursors are +committed through E0. -/ +theorem standalone_allows_coordinated_route (selected : Option (KId .anon)) : + (AnonWorkItem.standalone E1Fixture.first).SelectedBlockMatches selected := + trivial + +/-! ## Concrete E2b body bridge -/ + +/-- E2b's actual Boolean family/constructor block inhabits the exact +oracle-backed constructor consumed by E3-S. This theorem is indexed by the +real production body states and exact physical member array from +`BooleanEnumerationFixture`; it does not replace them with an abstract +inductive environment. -/ +def booleanFamilyBodyResources + {requests : List WalkerRequest} {support : RunSupport} + (context : ScopedRecursiveMethodRunContext + BooleanEnumerationFixture.checkerInitial + (TcM.checkConst BooleanEnumerationFixture.familyId) + requests RawProjRel.none BooleanEnumerationFixture.world support) + (activePost : ActiveBlockStateWF + (kernelCacheSemantics context.model.keys RawProjRel.none) + RawProjRel.none BooleanEnumerationFixture.world support + BooleanEnumerationFixture.familyMembers + BooleanEnumerationFixture.familyBodyAfter) : + SupportedBlockBodyResources context + BooleanEnumerationFixture.familyBlockId + BooleanEnumerationFixture.familyId + BooleanEnumerationFixture.familyMembers .inductive' + BooleanEnumerationFixture.checkerInitial + BooleanEnumerationFixture.familyBodyAfter := + .oracleBacked + (BooleanEnumerationFixture.familyLink.blockResources activePost) + +/-- The adapter turns that E2b resource and the actual successful production +trace into E0's exact atomic-body certificate. -/ +theorem booleanFamilyBody_certified + {requests : List WalkerRequest} {support : RunSupport} + (context : ScopedRecursiveMethodRunContext + BooleanEnumerationFixture.checkerInitial + (TcM.checkConst BooleanEnumerationFixture.familyId) + requests RawProjRel.none BooleanEnumerationFixture.world support) + (activePost : ActiveBlockStateWF + (kernelCacheSemantics context.model.keys RawProjRel.none) + RawProjRel.none BooleanEnumerationFixture.world support + BooleanEnumerationFixture.familyMembers + BooleanEnumerationFixture.familyBodyAfter) : + CertifiedBlockBodySuccess + (kernelCacheSemantics context.model.keys RawProjRel.none) + RawProjRel.none BooleanEnumerationFixture.world support + (Ix.Tc.methodsN (m := .anon) + BooleanEnumerationFixture.checkerInitial.recFuel.toNat) + BooleanEnumerationFixture.familyBlockId + BooleanEnumerationFixture.familyId + BooleanEnumerationFixture.familyMembers .inductive' + BooleanEnumerationFixture.checkerInitial + BooleanEnumerationFixture.familyBodyAfter := by + apply (booleanFamilyBodyResources context activePost).certify + BooleanEnumerationFixture.exactFamilyBlock + simpa [BooleanEnumerationFixture.checkerInitial, + BooleanEnumerationFixture.checkerMethods] using + BooleanEnumerationFixture.familyBodyTrace + +end SupportedAcceptanceFixture + +end Ix.Tc diff --git a/Ix/Tc/Verify/Env.lean b/Ix/Tc/Verify/Env.lean index 15dc7a04c..28ef0fe92 100644 --- a/Ix/Tc/Verify/Env.lean +++ b/Ix/Tc/Verify/Env.lean @@ -275,9 +275,7 @@ theorem TrKEnv'.wf {safety : Ix.DefinitionSafety} | defn h1 h2 h3 h4 _ ih => have ⟨_, H⟩ := ih exact ⟨_, H.decl <| .def h3 h4⟩ - | induct h1 h2 _ ih => - have ⟨_, H⟩ := ih - exact ⟨_, H.decl <| .induct h1 h2.to_addInduct⟩ + | induct _ h2 _ _ => cases h2 theorem TrKEnv.wf {safety : Ix.DefinitionSafety} {nameOf : Address → Option Lean.Name} @@ -790,6 +788,35 @@ def Promotes (before : VerifyWorld) (ids : KId .anon → Prop) (after : VerifyWorld) : Prop := before ≤ after ∧ ∀ ⦃id⦄, ids id → after.trusted id +/-- An exact ghost promotion. Besides ordinary monotone growth, this pins +the complete post-trust predicate: the only newly trusted identifiers are +the requested identifiers. This stronger relation is needed at atomic +block boundaries; `Promotes` remains the consumer-facing monotone view. -/ +structure ExactPromotion (before : VerifyWorld) (ids : KId .anon → Prop) + (after : VerifyWorld) : Prop where + le : before ≤ after + trusted_iff : ∀ id, after.trusted id ↔ ids id ∨ before.trusted id + +namespace ExactPromotion + +/-- Forget exactness while retaining the ordinary promotion contract. -/ +theorem promotes {before after : VerifyWorld} {ids : KId .anon → Prop} + (h : ExactPromotion before ids after) : Promotes before ids after := by + refine ⟨h.le, ?_⟩ + intro id hid + exact (h.trusted_iff id).2 (.inl hid) + +/-- Exact promotion cannot introduce an unrelated trusted identifier. -/ +theorem newlyTrusted {before after : VerifyWorld} + {ids : KId .anon → Prop} (h : ExactPromotion before ids after) + {id : KId .anon} (hafter : after.trusted id) + (hbefore : ¬before.trusted id) : ids id := by + rcases (h.trusted_iff id).1 hafter with hnew | hold + · exact hnew + · exact False.elim (hbefore hold) + +end ExactPromotion + namespace Promotes theorem catalog {before after : VerifyWorld} {ids : KId .anon → Prop} @@ -816,17 +843,18 @@ theorem trans {a b c : VerifyWorld} {ids ids' : KId .anon → Prop} end Promotes -/-- Admit one pending standalone declaration. The declaration-WF argument is -unavoidable and explicit: it is the new fact supplied by checker success. -The concrete `KEnv` is not mutated. -/ -theorem TrustedCatalogRel.promote +/-- Admit one pending standalone declaration with an exact post-trust +predicate. This is the adversarially strong form of `promote`: the witness +world is the same one-declaration Theory transition, and no unrelated +catalog entry can become trusted as a side effect. -/ +theorem TrustedCatalogRel.promoteExact {trProj : RawProjRel} {world : VerifyWorld} {id : KId .anon} {d : VDecl} {venv' : VEnv} (hrel : TrustedCatalogRel trProj world) (hpending : PendingDecl trProj world id d) (hwf : VDecl.WF world.venv d venv') : ∃ world', - Promotes world (fun target => target = id) world' ∧ + ExactPromotion world (fun target => target = id) world' ∧ TrustedCatalogRel trProj world' ∧ TrustedDecl trProj world' id d := by obtain ⟨c, hcat, hraw, huntrusted, hclosed, hfresh⟩ := hpending @@ -836,6 +864,7 @@ theorem TrustedCatalogRel.promote trusted := TrustInsert world.trusted id venv := venv' nameOf := world.nameOf + blocks := world.blocks venvWF := by obtain ⟨ds, hds⟩ := world.venvWF exact ⟨_, .decl hwf hds⟩ @@ -847,16 +876,32 @@ theorem TrustedCatalogRel.promote exact ⟨c, hcat⟩ · exact world.trustedCatalogued hold } refine ⟨world', ?_, ?_, ?_⟩ - · refine ⟨⟨rfl, rfl, ?_, hle⟩, ?_⟩ + · refine ⟨⟨rfl, rfl, rfl, ?_, hle⟩, ?_⟩ · intro target hold exact TrustInsert.old hold - · intro target htarget - subst target - exact TrustInsert.self + · intro target + rfl · exact TrustedCatalogLog.promote hrel hcat hraw hclosed huntrusted hwf · exact ⟨c, world.venv, venv', hcat, hraw.mono hle, TrustInsert.self, hwf, VEnv.LE.rfl⟩ +/-- Admit one pending standalone declaration. The declaration-WF argument is +unavoidable and explicit: it is the new fact supplied by checker success. +The concrete `KEnv` is not mutated. -/ +theorem TrustedCatalogRel.promote + {trProj : RawProjRel} {world : VerifyWorld} {id : KId .anon} + {d : VDecl} {venv' : VEnv} + (hrel : TrustedCatalogRel trProj world) + (hpending : PendingDecl trProj world id d) + (hwf : VDecl.WF world.venv d venv') : + ∃ world', + Promotes world (fun target => target = id) world' ∧ + TrustedCatalogRel trProj world' ∧ + TrustedDecl trProj world' id d := by + obtain ⟨world', hexact, hworld, hdecl⟩ := + TrustedCatalogRel.promoteExact hrel hpending hwf + exact ⟨world', hexact.promotes, hworld, hdecl⟩ + /-- The G1b ill-typed pending world already satisfies the G1c trusted-log invariant: its catalog entry remains completely outside the empty log. -/ theorem IllTypedPending.trustedCatalogRel : diff --git a/Ix/Tc/Verify/Execution.lean b/Ix/Tc/Verify/Execution.lean index af5a00132..7c84bb886 100644 --- a/Ix/Tc/Verify/Execution.lean +++ b/Ix/Tc/Verify/Execution.lean @@ -89,6 +89,15 @@ inductive ExecutionRequests : {α : Type} → (hh : ∀ err s', x s = .error err s' → ExecutionRequests (handler err) s' caught) : ExecutionRequests (EStateM.tryCatch x handler) s (body ++ caught) + | runRec {s : TcState .anon} {x : RecM .anon α} + {requests : List WalkerRequest} + (hx : ExecutionRequests + (x.run (methodsN s.recFuel.toNat)) s requests) : + ExecutionRequests (TcM.runRec x) s requests + | isolateCheckErrors {s : TcState .anon} {x : TcM .anon α} + {requests : List WalkerRequest} + (hx : ExecutionRequests x s requests) : + ExecutionRequests (TcM.isolateCheckErrors x) s requests | weaken {s : TcState .anon} {x : TcM .anon α} {used planned : List WalkerRequest} (hx : ExecutionRequests x s used) @@ -101,6 +110,14 @@ inductive ExecutionRequests : {α : Type} → namespace ExecutionRequests +/-- Ordinary state modification is a silent execution step when its exact +state transformer leaves the intern table unchanged. -/ +theorem modify (s : TcState .anon) (f : TcState .anon → TcState .anon) + (hintern : (f s).env.intern = s.env.intern) : + ExecutionRequests (modify f : TcM .anon Unit) s [] := by + exact .of_eq (by rfl) + (.modifyGet s (fun state => (PUnit.unit, f state)) hintern) + theorem pure_weaken (s : TcState .anon) (a : α) (requests : List WalkerRequest) : ExecutionRequests (Pure.pure a : TcM .anon α) s requests := @@ -184,6 +201,19 @@ theorem intern_eq_of_nil {α : Type} {x : TcM .anon α} | .error err' s₂ => simp only [hhs] at hh' exact hh'.trans hx' + | runRec hx ihx => + simpa [TcM.runRec] using ihx hnil + | isolateCheckErrors hx ihx => + rename_i s x requests + have hx' := ihx hnil + unfold TcM.isolateCheckErrors + match hxs : x s with + | .ok a s' => + simp only [hxs] at hx' ⊢ + exact hx' + | .error err s' => + simp only [hxs] at hx' ⊢ + exact hx' | weaken hx hsub ihx => subst hnil exact ihx (List.eq_nil_iff_forall_not_mem.mpr diff --git a/Ix/Tc/Verify/Inductive.lean b/Ix/Tc/Verify/Inductive.lean index 567851e24..af8e9b2bd 100644 --- a/Ix/Tc/Verify/Inductive.lean +++ b/Ix/Tc/Verify/Inductive.lean @@ -1,15 +1,14 @@ import Ix.Tc.Verify.Decl +import Ix.Tc.Verify.Inductive.Certificate import Ix.Tc.Verify.Trans import Lean4Lean.Theory.Typing.Pattern /-! # Ambient inductive oracle -Lean4Lean currently leaves both `VInductDecl.WF` and `VEnv.addInduct` as -opaque `sorry` definitions. Requiring an equation involving that operation -here would make the ambient-inductive precondition impossible to instantiate -without adding another axiom. G2 therefore records the semantic consequences -needed by the checker directly: +G2 introduced this interface before Lean4Lean had a usable inductive +specification, so it records the semantic consequences needed by the checker +directly: * every admitted concrete inductive-family constant has an exact raw Theory translation and lookup; @@ -18,12 +17,17 @@ needed by the checker directly: * every concrete recursor rule has an explicit, well-formed Theory defeq witness headed by that recursor. -`InductiveOracle` is an explicit assumption boundary, not a claim that Ix's -inductive checker has already been verified. The later inductive milestone -must construct this interface from block checking and a completed -Lean4Lean `addInduct` specification. Keeping the interface in terms of -semantic consequences permits a closed Nat model with no new Lean axiom now, -while the recursor clause prevents future whnf proofs from treating +Pin A now provides Lean4Lean's proved normalized `GenerationCertificate` and +`addInductCertified` transaction. `Inductive/Certificate.lean` derives the +Theory-owned environment, lookup, freshness, and rule-registration facts from +that certificate. It intentionally cannot supply the Ix-owned catalog/name +translation, checker-execution, and recursor-pattern fields below. + +`InductiveOracle` therefore remains an explicit assumption boundary, not a +claim that Ix's inductive checker has already been verified. E2b must combine +the certificate facts with actual Ix block checking and pattern-generation +proofs. Keeping the interface in terms of semantic consequences permits a +closed Nat model while the recursor clause prevents WHNF proofs from treating computation rules as an unrecorded ambient fact. -/ @@ -84,8 +88,32 @@ theorem hasRecursorRule {c : KConst .anon} {index : Nat} case recr rules => exact Array.mem_of_getElem? h +/-- An exact array position selects at most one concrete rule. -/ +theorem unique {c : KConst .anon} {index : Nat} + {left right : RecRule .anon} + (hleft : c.RecursorRuleAt index left) + (hright : c.RecursorRuleAt index right) : left = right := by + cases c <;> simp only [KConst.RecursorRuleAt] at hleft hright + rw [hleft] at hright + exact Option.some.inj hright + end KConst.RecursorRuleAt +namespace KConst.HasRecursorRule + +/-- Ordinary rule membership retains some exact dispatch position. -/ +theorem exists_ruleAt {c : KConst .anon} {rule : RecRule .anon} + (h : c.HasRecursorRule rule) : + ∃ index, c.RecursorRuleAt index rule := by + cases c <;> + simp only [KConst.HasRecursorRule, KConst.RecursorRuleAt] at h ⊢ + case recr rules => + obtain ⟨index, hindex, hget⟩ := Array.mem_iff_getElem.mp h + exact ⟨index, (Array.getElem?_eq_getElem hindex).trans + (congrArg some hget)⟩ + +end KConst.HasRecursorRule + /-- Constructor metadata relevant to iota pattern matching. -/ def KConst.ConstructorAt (c : KConst .anon) (index : Nat) (params fields : UInt64) : Prop := @@ -101,6 +129,41 @@ inductive HeadConst (name : Lean.Name) : VExpr → Prop HeadConst name (.const name levels) | app {fn arg : VExpr} : HeadConst name fn → HeadConst name (.app fn arg) +/-- A closed rewrite equation may bind its complete rule telescope before +the recursor-headed application. Lean4Lean's generated iota equations and +production's stored `RecRule.rhs` both use exactly this closed-lambda shape; +requiring `HeadConst name defeq.lhs` at the outer node would reject every +nonempty generated rule telescope. -/ +inductive HeadConstUnderLambdas (name : Lean.Name) : VExpr → Prop + | head {body : VExpr} : HeadConst name body → + HeadConstUnderLambdas name body + | lam {type body : VExpr} : HeadConstUnderLambdas name body → + HeadConstUnderLambdas name (.lam type body) + +namespace HeadConst + +/-- Adding an application spine preserves its constant head. -/ +theorem appN {name : Lean.Name} {head : VExpr} + (h : HeadConst name head) : + ∀ arguments : List VExpr, HeadConst name (VExpr.appN head arguments) + | [] => h + | _ :: rest => (HeadConst.app h).appN rest + +end HeadConst + +namespace HeadConstUnderLambdas + +/-- Closing a recursor-headed body under an arbitrary rule telescope +produces the exact outer shape used by generated equations. -/ +theorem lamN {name : Lean.Name} {body : VExpr} + (h : HeadConst name body) : + ∀ binders : List VExpr, + HeadConstUnderLambdas name (VExpr.lamN binders body) + | [] => .head h + | _ :: rest => .lam (HeadConstUnderLambdas.lamN h rest) + +end HeadConstUnderLambdas + /-- 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. -/ @@ -210,7 +273,7 @@ def RegisteredRecursorRuleRhsRel (env : VEnv) env.constants name = some constant ∧ env.defeqs defeq ∧ defeq.WF env ∧ - HeadConst name defeq.lhs ∧ + HeadConstUnderLambdas name defeq.lhs ∧ RawExprRel env nameOf trProj [] rule.rhs defeq.rhs ∧ TrKExprS env defeq.uvars nameOf trProj [] rule.rhs defeq.rhs @@ -305,6 +368,54 @@ structure RecursorRulePattern where checks : (RecursorIotaPattern recursorName majorIdx constructorName (constructorParams.toNat + constructorFields.toNat)).Check +/-- Finite production metadata required by one recursor pattern, separated +from its semantic rewrite law so E2 adapters can show exactly which part is +discharged by catalog/layout correspondence. -/ +structure RawRecursorRulePatternMetadataRel (catalog : Catalog) + (nameOf : Address → Option Lean.Name) (id : KId .anon) + (c : KConst .anon) (rule : RecRule .anon) + (pattern : RecursorRulePattern) : Prop where + recursorName : nameOf id.addr = some pattern.recursorName + majorIdx : c.RecursorMajorIdx = some pattern.majorIdx + majorIdxCoherent : c.RecursorMajorIdxCoherent + ruleAt : c.RecursorRuleAt pattern.ruleIndex rule + constructorName : + nameOf pattern.constructorId.addr = some pattern.constructorName + constructorAt : ∃ ctor, + catalog pattern.constructorId = some ctor ∧ + ctor.ConstructorAt pattern.ruleIndex pattern.constructorParams + pattern.constructorFields + fields : rule.fields = pattern.constructorFields + +/-- The environment-parametric semantic half of a recursor pattern. + +`Params.pat_wf` has a well-formed environment in its class parameters, and +the Theory inversion/beta lemmas additionally require a well-formed local +context. Both premises are explicit here: a registered generated equation +cannot justify reduction in an arbitrary malformed extension or context. -/ +def RecursorRulePattern.Sound (env : VEnv) + (pattern : RecursorRulePattern) : Prop := + ∀ {env' : VEnv}, env ≤ env' → + env'.WF → + ∀ {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.OnCtx Gamma (env'.IsType uvars) → + 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) + /-- Proof-irrelevant semantic realization of exact iota-pattern data for one concrete rule. -/ def RawRecursorRulePatternRel (env : VEnv) (catalog : Catalog) @@ -322,6 +433,7 @@ def RawRecursorRulePatternRel (env : VEnv) (catalog : Catalog) pattern.constructorFields) ∧ rule.fields = pattern.constructorFields ∧ ∀ {env' : VEnv}, env ≤ env' → + env'.WF → ∀ {uvars : Nat} {Gamma : List VExpr} {source : VExpr} {levels : List Lean4Lean.VLevel} {captures : (RecursorIotaPattern pattern.recursorName pattern.majorIdx @@ -329,6 +441,7 @@ def RawRecursorRulePatternRel (env : VEnv) (catalog : Catalog) (pattern.constructorParams.toNat + pattern.constructorFields.toNat)).Path → VExpr} {A : VExpr}, + Lean4Lean.OnCtx Gamma (env'.IsType uvars) → Lean4Lean.Pattern.Matches (RecursorIotaPattern pattern.recursorName pattern.majorIdx pattern.constructorName @@ -342,6 +455,42 @@ def RawRecursorRulePatternRel (env : VEnv) (catalog : Catalog) namespace RawRecursorRulePatternRel +/-- Assemble the historical flat relation from its separately auditable +metadata and semantic halves. -/ +theorem of_metadata_sound + {env : VEnv} {catalog : Catalog} + {nameOf : Address → Option Lean.Name} {id : KId .anon} + {c : KConst .anon} {rule : RecRule .anon} + {pattern : RecursorRulePattern} + (metadata : RawRecursorRulePatternMetadataRel catalog nameOf id c rule + pattern) + (sound : pattern.Sound env) : + RawRecursorRulePatternRel env catalog nameOf id c rule pattern := + ⟨metadata.recursorName, metadata.majorIdx, metadata.majorIdxCoherent, + metadata.ruleAt, metadata.constructorName, metadata.constructorAt, + metadata.fields, sound⟩ + +/-- Project finite metadata from the historical flat relation. -/ +theorem metadata + {env : VEnv} {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) : + RawRecursorRulePatternMetadataRel catalog nameOf id c rule pattern := + ⟨h.1, h.2.1, h.2.2.1, h.2.2.2.1, h.2.2.2.2.1, + h.2.2.2.2.2.1, h.2.2.2.2.2.2.1⟩ + +/-- Project semantic soundness from the historical flat relation. -/ +theorem sound + {env : VEnv} {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) : + pattern.Sound env := + h.2.2.2.2.2.2.2 + /-- 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. -/ @@ -354,9 +503,10 @@ theorem mono {env env' : VEnv} (henv : env ≤ env') {catalog : Catalog} 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⟩ + intro future hfuture hfutureWF uvars Gamma source levels captures A + hGamma hmatches htype hchecks + exact hsound (henv.trans hfuture) hfutureWF hGamma hmatches htype + hchecks⟩ end RawRecursorRulePatternRel @@ -364,10 +514,10 @@ end RawRecursorRulePatternRel block. `members` is exact for this admission step; `fresh` prevents the oracle from re-certifying an existing trusted id. -The oracle records `before ≤ after` rather than an opaque -`before.addInduct = some after` equation. These are exactly the consequences -used before E2, and unlike the unfinished upstream operation they admit real -models. -/ +The oracle records `before ≤ after` rather than requiring every consumer to +carry a transaction equation. `CertifiedGenerationFacts` now derives this +Theory-owned portion; the remaining fields are the E2b Ix correspondence +boundary. -/ structure InductiveOracle (trProj : RawProjRel) (catalog : Catalog) (nameOf : Address → Option Lean.Name) (trusted : KId .anon → Prop) (before : VEnv) where @@ -395,6 +545,44 @@ structure InductiveOracle (trProj : RawProjRel) (catalog : Catalog) namespace InductiveOracle +/-- Transport an oracle across equality of the immutable catalog and naming +interpretation. World extension records these as equal fields, so making the +transport explicit keeps later residual-oracle proofs independent of opaque +dependent casts. -/ +def reindex + {trProj : RawProjRel} {catalog catalog' : Catalog} + {nameOf nameOf' : Address → Option Lean.Name} + {trusted : KId .anon → Prop} {before : VEnv} + (oracle : InductiveOracle trProj catalog nameOf trusted before) + (hcatalog : catalog = catalog') (hnameOf : nameOf = nameOf') : + InductiveOracle trProj catalog' nameOf' trusted before := by + subst catalog' + subst nameOf' + exact oracle + +@[simp] theorem reindex_members + {trProj : RawProjRel} {catalog catalog' : Catalog} + {nameOf nameOf' : Address → Option Lean.Name} + {trusted : KId .anon → Prop} {before : VEnv} + (oracle : InductiveOracle trProj catalog nameOf trusted before) + (hcatalog : catalog = catalog') (hnameOf : nameOf = nameOf') + (id : KId .anon) : + (oracle.reindex hcatalog hnameOf).members id ↔ oracle.members id := by + subst catalog' + subst nameOf' + rfl + +@[simp] theorem reindex_after + {trProj : RawProjRel} {catalog catalog' : Catalog} + {nameOf nameOf' : Address → Option Lean.Name} + {trusted : KId .anon → Prop} {before : VEnv} + (oracle : InductiveOracle trProj catalog nameOf trusted before) + (hcatalog : catalog = catalog') (hnameOf : nameOf = nameOf') : + (oracle.reindex hcatalog hnameOf).after = oracle.after := by + subst catalog' + subst nameOf' + rfl + /-- Add exactly this oracle block to the trusted predicate. -/ def TrustBlock {trProj : RawProjRel} {catalog : Catalog} {nameOf : Address → Option Lean.Name} {trusted : KId .anon → Prop} @@ -422,6 +610,61 @@ theorem catalogued {trProj : RawProjRel} {catalog : Catalog} obtain ⟨c, _, _, hcat, _⟩ := oracle.translateBlock h exact ⟨c, hcat⟩ +/-- Reuse a certified inductive interpretation in a later Theory +environment, admitting exactly the members which are not already trusted. + +This is the form needed by checked-set composition. A composition world may +already contain part of a physical block because another production check +validated a dependency first. Requiring the original oracle's whole member +set to remain fresh would make such a safe replay uninhabitable. The +residual oracle transports the semantic and generated-rule facts to +`current`, then makes freshness true by construction. `hmissing` prevents an +empty ghost transaction. -/ +def restageMissing + {trProj : RawProjRel} {catalog : Catalog} + {nameOf : Address → Option Lean.Name} + {trusted₀ : KId .anon → Prop} {before₀ : VEnv} + (oracle : InductiveOracle trProj catalog nameOf trusted₀ before₀) + {current : VEnv} (henv : oracle.after ≤ current) + (hcurrent : current.WF) (trusted : KId .anon → Prop) + (hmissing : ∃ id, oracle.members id ∧ ¬trusted id) : + InductiveOracle trProj catalog nameOf trusted current where + members := fun id => oracle.members id ∧ ¬trusted id + nonempty := hmissing + fresh := by + intro id hmember + exact hmember.2 + after := current + envLE := VEnv.LE.rfl + blockWF := hcurrent + translateBlock := by + intro id hmember + obtain ⟨concrete, name, constant, hcatalog, hraw, hlookup, hwf⟩ := + oracle.translateBlock hmember.1 + exact ⟨concrete, name, constant, hcatalog, hraw.mono henv, + henv.constants hlookup, hwf.mono henv⟩ + recursorFacts := by + intro id concrete rule hmember hcatalog hrule + exact (oracle.recursorFacts hmember.1 hcatalog hrule).mono henv + recursorPatterns := by + intro id concrete ruleIndex rule hmember hcatalog hrule + obtain ⟨pattern, hpattern, hindex⟩ := + oracle.recursorPatterns hmember.1 hcatalog hrule + exact ⟨pattern, hpattern.mono henv, hindex⟩ + +@[simp] theorem restageMissing_members_iff + {trProj : RawProjRel} {catalog : Catalog} + {nameOf : Address → Option Lean.Name} + {trusted₀ : KId .anon → Prop} {before₀ : VEnv} + (oracle : InductiveOracle trProj catalog nameOf trusted₀ before₀) + {current : VEnv} (henv : oracle.after ≤ current) + (hcurrent : current.WF) (trusted : KId .anon → Prop) + (hmissing : ∃ id, oracle.members id ∧ ¬trusted id) + (id : KId .anon) : + (oracle.restageMissing henv hcurrent trusted hmissing).members id ↔ + oracle.members id ∧ ¬trusted id := + Iff.rfl + end InductiveOracle end Ix.Tc diff --git a/Ix/Tc/Verify/Inductive/Certificate.lean b/Ix/Tc/Verify/Inductive/Certificate.lean new file mode 100644 index 000000000..f5b528be8 --- /dev/null +++ b/Ix/Tc/Verify/Inductive/Certificate.lean @@ -0,0 +1,105 @@ +import Lean4Lean.Theory.Typing.EnvLemmas + +/-! +# Certified inductive-generation transactions + +This module is the Theory-only consumer boundary for Lean4Lean's normalized +inductive-generation certificate. It deliberately imports no +`Lean4Lean.Verify` module and mentions no Ix catalog, address, checker state, +or recursor-pattern relation. + +`GenerationCertificate` proves that one exact normalized generation is +semantically valid in the input Theory environment. A successful +`addInductCertified` equation then determines the atomic output environment. +The adapter below packages that data and derives precisely the stable Theory +facts that Ix will later combine with its own catalog and execution proofs. + +In particular, this boundary does *not* construct `InductiveOracle`: a Theory +certificate cannot by itself establish which concrete Ix constants were +checked, how their addresses map to names, or that production iota metadata +matches the generated Theory rules. +-/ + +namespace Ix.Tc + +open Lean4Lean + +/-- One successful proof-carrying normalized inductive transaction, together +with the well-formed input environment needed to extend a Theory history. + +This is a data-bearing structure rather than a proposition so the exact +certificate/generation remains available to downstream adapters. -/ +structure CertifiedGenerationTransaction (source : VInductDecl) + (before after : VEnv) where + certificate : source.GenerationCertificate before + success : before.addInductCertified certificate = some after + beforeWF : before.WF + +/-- The complete Theory-owned consequences of a certified generation +transaction. All fields concern only the Lean4Lean source, generated +artifacts, and input/output `VEnv`s. -/ +structure CertifiedGenerationFacts {source : VInductDecl} + (before after : VEnv) (certificate : source.GenerationCertificate before) : + Prop where + envLE : before ≤ after + afterWF : after.WF + familyFresh : + before.constants certificate.generation.block.sourceType.name = none + familyLookup : + after.constants certificate.generation.block.sourceType.name = + some certificate.generation.block.sourceType.toVConstant + ctorFresh : ∀ {ctor}, + ctor ∈ certificate.generation.block.sourceType.ctors → + before.constants ctor.name = none + ctorLookup : ∀ {ctor}, + ctor ∈ certificate.generation.block.sourceType.ctors → + after.constants ctor.name = some ctor.toVConstant + recursorFresh : + before.constants + (.str certificate.generation.block.sourceType.name "rec") = none + recursorLookup : + after.constants + (.str certificate.generation.block.sourceType.name "rec") = + some certificate.generation.recursor + ruleMem : ∀ {rule}, rule ∈ certificate.generation.generatedRules → + after.defeqs rule + +namespace CertifiedGenerationTransaction + +/-- Recover the exact, proof-irrelevant intermediate-state trace of the +certified atomic transaction. -/ +theorem trace {source : VInductDecl} {before after : VEnv} + (tx : CertifiedGenerationTransaction source before after) : + Nonempty (VEnv.AddInductGenerationTrace before after + tx.certificate.generation) := + VEnv.addInductCertified_trace tx.success + +/-- Extend the input `VEnv.WF` history with the exact normalized inductive +declaration step carried by the certificate. -/ +theorem afterWF {source : VInductDecl} {before after : VEnv} + (tx : CertifiedGenerationTransaction source before after) : after.WF := by + rcases tx.beforeWF with ⟨decls, hdecls⟩ + refine ⟨.induct source :: decls, hdecls.decl (.induct tx.certificate.wf ?_)⟩ + simpa only [VEnv.addInductCertified_eq_addInductGeneration] using tx.success + +/-- Assemble every stable Theory consequence from the one successful trace. +No checker-specific provenance is introduced by this projection. -/ +theorem facts {source : VInductDecl} {before after : VEnv} + (tx : CertifiedGenerationTransaction source before after) : + CertifiedGenerationFacts before after tx.certificate := by + rcases tx.trace with ⟨trace⟩ + exact { + envLE := trace.le + afterWF := tx.afterWF + familyFresh := trace.family_fresh + familyLookup := trace.family_lookup + ctorFresh := fun hctor => trace.ctor_fresh hctor + ctorLookup := fun hctor => trace.ctor_lookup hctor + recursorFresh := trace.rec_fresh + recursorLookup := trace.rec_lookup + ruleMem := fun hrule => trace.rule_mem hrule + } + +end CertifiedGenerationTransaction + +end Ix.Tc diff --git a/Ix/Tc/Verify/Inductive/EnumerationAcceptance.lean b/Ix/Tc/Verify/Inductive/EnumerationAcceptance.lean new file mode 100644 index 000000000..9bdb75a95 --- /dev/null +++ b/Ix/Tc/Verify/Inductive/EnumerationAcceptance.lean @@ -0,0 +1,637 @@ +import Ix.Tc.Verify.Inductive.EnumerationFixture + +/-! +# Concrete singleton-enumeration checker acceptance + +This module runs the production coordinated-block body over the Boolean +ingress fixture. The family block is checked first so that production +constructs its canonical recursor cache; the separate recursor block is then +checked against that exact generated result. +-/ + +namespace Ix.Tc + +namespace BooleanEnumerationFixture + +local instance acceptanceAnonKIdDecidableEq : DecidableEq (KId .anon) := + fun left right => + if h : left == right then + .isTrue (eq_of_beq h) + else + .isFalse fun equality => h (by cases equality; exact beq_self_eq_true left) + +/-- Physical owner keys, distinct from the projected declaration ids stored +as block members. -/ +def familyBlockId : KId .anon := ⟨familyBlockAddress, ()⟩ +def recursorBlockId : KId .anon := ⟨recursorBlockAddress, ()⟩ + +def familyMembers : Array (KId .anon) := familyLink.members +def recursorMembers : Array (KId .anon) := recursorLink.members + +theorem familyMembers_eq : familyMembers = #[familyId, falseId, trueId] := by + rfl + +theorem recursorMembers_eq : recursorMembers = #[recursorId] := by + rfl + +/-- A finite production method table large enough for both concrete runs. +The value is fixture data, not a semantic assumption: both success equations +below are checked by native evaluation. -/ +def checkerFuel : UInt64 := 256 + +def checkerMethods : Methods .anon := methodsN checkerFuel.toNat + +def checkerInitial : TcState .anon := + { TcState.ofEnvAnon recursorIngressAfter with + recFuel := checkerFuel + fuelBudget := checkerFuel } + +private theorem familyBlockLoadedNative : + checkerInitial.env.getBlock? familyBlockId = some familyMembers := by + native_decide + +theorem familyBlockLoaded : + checkerInitial.env.getBlock? familyBlockId = some familyMembers := + familyBlockLoadedNative + +private theorem recursorBlockLoadedNative : + checkerInitial.env.getBlock? recursorBlockId = some recursorMembers := by + native_decide + +theorem recursorBlockLoaded : + checkerInitial.env.getBlock? recursorBlockId = some recursorMembers := + recursorBlockLoadedNative + +/-! ## Family production run -/ + +def familyBodyOutcome := + (RecM.checkBlockBody familyBlockId familyId).run checkerMethods + checkerInitial + +def familyBodyAfter : TcState .anon := + match familyBodyOutcome with + | .ok _ after => after + | .error _ failed => failed + +def familyBodySucceeded : Bool := + match familyBodyOutcome with + | .ok _ _ => true + | .error _ _ => false + +private theorem familyBodySucceededNative : familyBodySucceeded = true := by + native_decide + +theorem familyBodySucceeded_eq : familyBodySucceeded = true := + familyBodySucceededNative + +theorem familyBodyRun : + (RecM.checkBlockBody familyBlockId familyId).run checkerMethods + checkerInitial = .ok () familyBodyAfter := by + have success := familyBodySucceeded_eq + unfold familyBodySucceeded at success + unfold familyBodyAfter + generalize houtcome : familyBodyOutcome = outcome at success ⊢ + cases outcome <;> simp_all [familyBodyOutcome] + +def familyClassificationOutcome := + (RecM.classifyBlock familyMembers).run checkerMethods checkerInitial + +def familyClassifiedAfter : TcState .anon := + match familyClassificationOutcome with + | .ok _ after => after + | .error _ failed => failed + +def familyClassificationSucceeded : Bool := + match familyClassificationOutcome with + | .ok .inductive' _ => true + | .ok _ _ => false + | .error _ _ => false + +private theorem familyClassificationSucceededNative : + familyClassificationSucceeded = true := by + native_decide + +theorem familyClassificationSucceeded_eq : + familyClassificationSucceeded = true := + familyClassificationSucceededNative + +theorem familyClassificationRun : + familyClassificationOutcome = + .ok .inductive' familyClassifiedAfter := by + have success := familyClassificationSucceeded_eq + unfold familyClassificationSucceeded at success + unfold familyClassifiedAfter + generalize houtcome : familyClassificationOutcome = outcome at success ⊢ + cases outcome with + | error => simp at success + | ok kind after => + cases kind <;> simp_all + +/-- Exact production lookup, classification, and inductive branch trace. -/ +def familyBodyTrace : RecM.ExactBlockBodySuccessTrace checkerMethods + familyBlockId familyId familyMembers .inductive' checkerInitial + familyBodyAfter := by + obtain ⟨actualMembers, actualKind, trace⟩ := + RecM.checkBlockBody_success_trace familyBodyRun + cases trace with + | run loaded classified hlookup hclass hcheck => + have expectedLookup := TcM.tryGetBlock_of_loaded familyBlockLoaded + have hlookupEq := + EStateM.Result.ok.inj (hlookup.symm.trans expectedLookup) + have hmembers : actualMembers = familyMembers := + Option.some.inj hlookupEq.1 + have hloaded : loaded = checkerInitial := hlookupEq.2 + subst actualMembers + subst loaded + have hclassEq := EStateM.Result.ok.inj + (hclass.symm.trans familyClassificationRun) + have hkind : actualKind = .inductive' := hclassEq.1 + have hclassified : classified = familyClassifiedAfter := hclassEq.2 + subst actualKind + subst classified + exact .run checkerInitial familyClassifiedAfter expectedLookup + familyClassificationRun hcheck + +/-- The production inductive checker itself succeeds on the same physical +family array, independently of the surrounding classification wrapper. -/ +def familyKernelOutcome := + (RecM.checkInductiveBlock familyBlockId familyMembers).run checkerMethods + checkerInitial + +def familyKernelAfter : TcState .anon := + match familyKernelOutcome with + | .ok _ after => after + | .error _ failed => failed + +def familyKernelSucceeded : Bool := + match familyKernelOutcome with + | .ok _ _ => true + | .error _ _ => false + +private theorem familyKernelSucceededNative : + familyKernelSucceeded = true := by + native_decide + +theorem familyKernelSucceeded_eq : familyKernelSucceeded = true := + familyKernelSucceededNative + +theorem familyKernelRun : + (RecM.checkInductiveBlock familyBlockId familyMembers).run checkerMethods + checkerInitial = .ok () familyKernelAfter := by + have success := familyKernelSucceeded_eq + unfold familyKernelSucceeded at success + unfold familyKernelAfter + generalize houtcome : familyKernelOutcome = outcome at success ⊢ + cases outcome <;> simp_all [familyKernelOutcome] + +/-! ## Recursor production run -/ + +private theorem recursorBlockLoadedAfterFamilyNative : + familyBodyAfter.env.getBlock? recursorBlockId = some recursorMembers := by + native_decide + +theorem recursorBlockLoadedAfterFamily : + familyBodyAfter.env.getBlock? recursorBlockId = some recursorMembers := + recursorBlockLoadedAfterFamilyNative + +def recursorBodyOutcome := + (RecM.checkBlockBody recursorBlockId recursorId).run checkerMethods + familyBodyAfter + +def recursorBodyAfter : TcState .anon := + match recursorBodyOutcome with + | .ok _ after => after + | .error _ failed => failed + +def recursorBodySucceeded : Bool := + match recursorBodyOutcome with + | .ok _ _ => true + | .error _ _ => false + +private theorem recursorBodySucceededNative : + recursorBodySucceeded = true := by + native_decide + +theorem recursorBodySucceeded_eq : recursorBodySucceeded = true := + recursorBodySucceededNative + +theorem recursorBodyRun : + (RecM.checkBlockBody recursorBlockId recursorId).run checkerMethods + familyBodyAfter = .ok () recursorBodyAfter := by + have success := recursorBodySucceeded_eq + unfold recursorBodySucceeded at success + unfold recursorBodyAfter + generalize houtcome : recursorBodyOutcome = outcome at success ⊢ + cases outcome <;> simp_all [recursorBodyOutcome] + +def recursorClassificationOutcome := + (RecM.classifyBlock recursorMembers).run checkerMethods familyBodyAfter + +def recursorClassifiedAfter : TcState .anon := + match recursorClassificationOutcome with + | .ok _ after => after + | .error _ failed => failed + +def recursorClassificationSucceeded : Bool := + match recursorClassificationOutcome with + | .ok .recursor _ => true + | .ok _ _ => false + | .error _ _ => false + +private theorem recursorClassificationSucceededNative : + recursorClassificationSucceeded = true := by + native_decide + +theorem recursorClassificationSucceeded_eq : + recursorClassificationSucceeded = true := + recursorClassificationSucceededNative + +theorem recursorClassificationRun : + recursorClassificationOutcome = + .ok .recursor recursorClassifiedAfter := by + have success := recursorClassificationSucceeded_eq + unfold recursorClassificationSucceeded at success + unfold recursorClassifiedAfter + generalize houtcome : recursorClassificationOutcome = outcome + at success ⊢ + cases outcome with + | error => simp at success + | ok kind after => + cases kind <;> simp_all + +/-- Exact production lookup, classification, and recursor branch trace. -/ +def recursorBodyTrace : RecM.ExactBlockBodySuccessTrace checkerMethods + recursorBlockId recursorId recursorMembers .recursor familyBodyAfter + recursorBodyAfter := by + obtain ⟨actualMembers, actualKind, trace⟩ := + RecM.checkBlockBody_success_trace recursorBodyRun + cases trace with + | run loaded classified hlookup hclass hcheck => + have expectedLookup := + TcM.tryGetBlock_of_loaded recursorBlockLoadedAfterFamily + have hlookupEq := + EStateM.Result.ok.inj (hlookup.symm.trans expectedLookup) + have hmembers : actualMembers = recursorMembers := + Option.some.inj hlookupEq.1 + have hloaded : loaded = familyBodyAfter := hlookupEq.2 + subst actualMembers + subst loaded + have hclassEq := EStateM.Result.ok.inj + (hclass.symm.trans recursorClassificationRun) + have hkind : actualKind = .recursor := hclassEq.1 + have hclassified : classified = recursorClassifiedAfter := hclassEq.2 + subst actualKind + subst classified + exact .run familyBodyAfter recursorClassifiedAfter expectedLookup + recursorClassificationRun hcheck + +/-- The production recursor checker succeeds after the family run has +populated the canonical generated-recursor cache it consumes. -/ +def recursorKernelOutcome := + (RecM.checkRecursorBlock recursorBlockId recursorMembers).run checkerMethods + familyBodyAfter + +def recursorKernelAfter : TcState .anon := + match recursorKernelOutcome with + | .ok _ after => after + | .error _ failed => failed + +def recursorKernelSucceeded : Bool := + match recursorKernelOutcome with + | .ok _ _ => true + | .error _ _ => false + +private theorem recursorKernelSucceededNative : + recursorKernelSucceeded = true := by + native_decide + +theorem recursorKernelSucceeded_eq : recursorKernelSucceeded = true := + recursorKernelSucceededNative + +theorem recursorKernelRun : + (RecM.checkRecursorBlock recursorBlockId recursorMembers).run + checkerMethods familyBodyAfter = .ok () recursorKernelAfter := by + have success := recursorKernelSucceeded_eq + unfold recursorKernelSucceeded at success + unfold recursorKernelAfter + generalize houtcome : recursorKernelOutcome = outcome at success ⊢ + cases outcome <;> simp_all [recursorKernelOutcome] + +/-! ## Exact immutable block ownership -/ + +/-- Direct physical ownership of the family declaration. Constructors use +the catalogued parent relation below, so this discriminator intentionally +covers only the `.indc` case. -/ +private def IsDirectInductiveOwner (block : KId .anon) : + KConst .anon → Prop + | .indc (block := owner) .. => owner = block + | _ => False + +local instance directInductiveOwnerDecidable (block : KId .anon) + (concrete : KConst .anon) : + Decidable (IsDirectInductiveOwner block concrete) := by + cases concrete <;> simp only [IsDirectInductiveOwner] <;> infer_instance + +local instance recursorOwnerDecidable (block : KId .anon) + (concrete : KConst .anon) : + Decidable (concrete.IsRecursorMemberOf block) := by + cases concrete <;> + simp only [KConst.IsRecursorMemberOf] <;> infer_instance + +private theorem familyDirectOwnerNative : + IsDirectInductiveOwner familyBlockId familyConcrete := by + native_decide + +theorem familyDirectOwner : + IsDirectInductiveOwner familyBlockId familyConcrete := + familyDirectOwnerNative + +private theorem directInductiveOwner_inductiveMemberOf + {catalog : Catalog} {block : KId .anon} {concrete : KConst .anon} + (howner : IsDirectInductiveOwner block concrete) : + concrete.IsInductiveMemberOf catalog block := by + cases concrete <;> + simp_all [IsDirectInductiveOwner, KConst.IsInductiveMemberOf] + +theorem familyOwner : + familyConcrete.IsInductiveMemberOf catalog familyBlockId := + directInductiveOwner_inductiveMemberOf familyDirectOwner + +private theorem certifiedConstructor_inductiveMemberOf + {source : Lean4Lean.VInductDecl} {familyId block : KId .anon} + {index : Nat} {sourceConstructor : Lean4Lean.VConstVal} + {concrete familyConcrete : KConst .anon} {catalog : Catalog} + (hshape : concrete.IsCertifiedSingletonConstructor source familyId index + sourceConstructor) + (hcatalog : catalog familyId = some familyConcrete) + (hfamilyOwner : IsDirectInductiveOwner block familyConcrete) : + concrete.IsInductiveMemberOf catalog block := by + cases concrete <;> + simp_all [KConst.IsCertifiedSingletonConstructor, + KConst.IsInductiveMemberOf, IsDirectInductiveOwner] + exact hfamilyOwner + +theorem falseOwner : + falseConcrete.IsInductiveMemberOf catalog familyBlockId := + certifiedConstructor_inductiveMemberOf falseShape catalog_family + familyDirectOwner + +theorem trueOwner : + trueConcrete.IsInductiveMemberOf catalog familyBlockId := + certifiedConstructor_inductiveMemberOf trueShape catalog_family + familyDirectOwner + +private theorem recursorOwnerNative : + recursorConcrete.IsRecursorMemberOf recursorBlockId := by + native_decide + +theorem recursorOwner : + recursorConcrete.IsRecursorMemberOf recursorBlockId := + recursorOwnerNative + +private theorem certifiedRecursor_not_inductiveMemberOf + {source : Lean4Lean.VInductDecl} {generation : source.GenerationChecked} + {constructorIds : Array (KId .anon)} {concrete : KConst .anon} + {catalog : Catalog} {block : KId .anon} + (hshape : concrete.IsCertifiedSingletonRecursor source generation + constructorIds) : + ¬concrete.IsInductiveMemberOf catalog block := by + intro howner + cases concrete <;> + simp_all [KConst.IsCertifiedSingletonRecursor, + KConst.IsInductiveMemberOf] + +theorem recursorNotFamilyOwner : + ¬recursorConcrete.IsInductiveMemberOf catalog familyBlockId := + certifiedRecursor_not_inductiveMemberOf recursorShape + +private theorem certifiedFamily_not_recursorMemberOf + {source : Lean4Lean.VInductDecl} {generation : source.GenerationChecked} + {constructorIds : Array (KId .anon)} {concrete : KConst .anon} + {block : KId .anon} + (hshape : concrete.IsCertifiedSingletonFamily source generation + constructorIds) : + ¬concrete.IsRecursorMemberOf block := by + intro howner + cases concrete <;> + simp_all [KConst.IsCertifiedSingletonFamily, + KConst.IsRecursorMemberOf] + +theorem familyNotRecursorOwner : + ¬familyConcrete.IsRecursorMemberOf recursorBlockId := + certifiedFamily_not_recursorMemberOf familyShape + +private theorem certifiedConstructor_not_recursorMemberOf + {source : Lean4Lean.VInductDecl} {familyId : KId .anon} + {index : Nat} {sourceConstructor : Lean4Lean.VConstVal} + {concrete : KConst .anon} {block : KId .anon} + (hshape : concrete.IsCertifiedSingletonConstructor source familyId index + sourceConstructor) : + ¬concrete.IsRecursorMemberOf block := by + intro howner + cases concrete <;> + simp_all [KConst.IsCertifiedSingletonConstructor, + KConst.IsRecursorMemberOf] + +theorem falseNotRecursorOwner : + ¬falseConcrete.IsRecursorMemberOf recursorBlockId := + certifiedConstructor_not_recursorMemberOf falseShape + +theorem trueNotRecursorOwner : + ¬trueConcrete.IsRecursorMemberOf recursorBlockId := + certifiedConstructor_not_recursorMemberOf trueShape + +/-- Every successful lookup in the fixture's explicit semantic catalog is +one of its four declaration entries. -/ +theorem catalog_entry_cases {id : KId .anon} {concrete : KConst .anon} + (hcatalog : catalog id = some concrete) : + (id = familyId ∧ concrete = familyConcrete) ∨ + (id = falseId ∧ concrete = falseConcrete) ∨ + (id = trueId ∧ concrete = trueConcrete) ∨ + (id = recursorId ∧ concrete = recursorConcrete) := by + unfold catalog at hcatalog + split at hcatalog + · left + exact ⟨eq_of_beq (by assumption), (Option.some.inj hcatalog).symm⟩ + · split at hcatalog + · right; left + exact ⟨eq_of_beq (by assumption), (Option.some.inj hcatalog).symm⟩ + · split at hcatalog + · right; right; left + exact ⟨eq_of_beq (by assumption), + (Option.some.inj hcatalog).symm⟩ + · split at hcatalog + · right; right; right + exact ⟨eq_of_beq (by assumption), + (Option.some.inj hcatalog).symm⟩ + · contradiction + +theorem familyCoordinated_iff (id : KId .anon) : + id ∈ familyMembers ↔ + catalog.CoordinatedMember familyBlockId .inductive' id := by + constructor + · intro hmember + simp [familyMembers_eq] at hmember + rcases hmember with rfl | rfl | rfl + · exact ⟨familyConcrete, catalog_family, familyOwner⟩ + · exact ⟨falseConcrete, catalog_false, falseOwner⟩ + · exact ⟨trueConcrete, catalog_true, trueOwner⟩ + · rintro ⟨concrete, hcatalog, howner⟩ + rcases catalog_entry_cases hcatalog with + ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ + · simp [familyMembers_eq] + · simp [familyMembers_eq] + · simp [familyMembers_eq] + · exact False.elim (recursorNotFamilyOwner howner) + +theorem recursorCoordinated_iff (id : KId .anon) : + id ∈ recursorMembers ↔ + catalog.CoordinatedMember recursorBlockId .recursor id := by + constructor + · intro hmember + rw [recursorMembers_eq] at hmember + have hid : id = recursorId := by simpa using hmember + subst id + exact ⟨recursorConcrete, catalog_recursor, recursorOwner⟩ + · rintro ⟨concrete, hcatalog, howner⟩ + rcases catalog_entry_cases hcatalog with + ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ + · exact False.elim (familyNotRecursorOwner howner) + · exact False.elim (falseNotRecursorOwner howner) + · exact False.elim (trueNotRecursorOwner howner) + · simp [recursorMembers_eq] + +theorem world_family_block : + world.blocks familyBlockId = some familyMembers := by + change recursorIngressAfter.getBlock? familyBlockId = some familyMembers + simpa [checkerInitial] using familyBlockLoaded + +theorem world_recursor_block : + world.blocks recursorBlockId = some recursorMembers := by + change recursorIngressAfter.getBlock? recursorBlockId = some recursorMembers + simpa [checkerInitial] using recursorBlockLoaded + +def exactFamilyBlock : + ExactCheckBlock world familyBlockId familyMembers .inductive' where + blockLookup := world_family_block + nonempty := by rw [familyMembers_eq]; decide + memberIff := fun id => familyCoordinated_iff id + +def exactRecursorBlock : + ExactCheckBlock world recursorBlockId recursorMembers .recursor where + blockLookup := world_recursor_block + nonempty := by rw [recursorMembers_eq]; decide + memberIff := fun id => recursorCoordinated_iff id + +/-! ## Semantic admission of the checked blocks -/ + +/-- The family transaction exposed by the exact Ix/source catalog link. -/ +def familyBlockOracle : InductiveOracle RawProjRel.none world.catalog + world.nameOf world.trusted world.venv := + familyLink.oracle + +/-- The stable world obtained by admitting exactly the checked family array. -/ +def familyAcceptedWorld : VerifyWorld := + world.admitOracle familyBlockOracle + +/-- The production family array and the semantic family transaction have +exactly the same members. -/ +def familyBlockCertificate : OracleBlockCertificate RawProjRel.none world + familyBlockId familyMembers .inductive' where + oracleBacked := trivial + exactBlock := exactFamilyBlock + oracle := familyBlockOracle + memberIff := fun id => familyLink.oracle_members_iff id + +theorem familyAtomicAdmission : + AtomicBlockAdmission RawProjRel.none world familyAcceptedWorld + familyBlockId familyMembers .inductive' := + familyBlockCertificate.admit trustedCatalog + +theorem familyBlockAccepted : + familyAcceptedWorld.AcceptedBlock familyBlockId := + familyAtomicAdmission.accepted + +/-- The recursor transaction exposed by the exact Ix/source catalog link, +including both generated Boolean reduction equations. -/ +def recursorBlockOracle : InductiveOracle RawProjRel.none world.catalog + world.nameOf world.trusted world.venv := + recursorLink.oracle enumerationShape + +/-- The stable world obtained by admitting exactly the checked recursor +array. It is stated separately from `familyAcceptedWorld`: both physical +blocks interpret the same certified Lean4Lean generation transaction, while +their trust deltas are intentionally their distinct exact member arrays. -/ +def recursorAcceptedWorld : VerifyWorld := + world.admitOracle recursorBlockOracle + +def recursorBlockCertificate : OracleBlockCertificate RawProjRel.none world + recursorBlockId recursorMembers .recursor where + oracleBacked := trivial + exactBlock := exactRecursorBlock + oracle := recursorBlockOracle + memberIff := fun id => recursorLink.oracle_members_iff enumerationShape id + +theorem recursorAtomicAdmission : + AtomicBlockAdmission RawProjRel.none world recursorAcceptedWorld + recursorBlockId recursorMembers .recursor := + recursorBlockCertificate.admit trustedCatalog + +theorem recursorBlockAccepted : + recursorAcceptedWorld.AcceptedBlock recursorBlockId := + recursorAtomicAdmission.accepted + +/-! ## End-to-end executable witness -/ + +/-- The supported E2b fragment in one proposition. It starts with the two +actual anonymous-ingress calls, runs the production coordinated checker and +its concrete inductive/recursor branches, and ends in exact stable block +acceptance derived from the same catalog links. There is no reflection or +arbitrary-regeneration premise in this witness. -/ +structure EndToEndAcceptance : Prop where + familyIngress : familyIngressOutcome = + .ok familyIngressResult familyIngressAfter + recursorIngress : recursorIngressOutcome = + .ok recursorIngressResult recursorIngressAfter + familyBody : + (RecM.checkBlockBody familyBlockId familyId).run checkerMethods + checkerInitial = .ok () familyBodyAfter + recursorBody : + (RecM.checkBlockBody recursorBlockId recursorId).run checkerMethods + familyBodyAfter = .ok () recursorBodyAfter + familyTrace : RecM.ExactBlockBodySuccessTrace checkerMethods + familyBlockId familyId familyMembers .inductive' checkerInitial + familyBodyAfter + recursorTrace : RecM.ExactBlockBodySuccessTrace checkerMethods + recursorBlockId recursorId recursorMembers .recursor familyBodyAfter + recursorBodyAfter + familyKernel : + (RecM.checkInductiveBlock familyBlockId familyMembers).run checkerMethods + checkerInitial = .ok () familyKernelAfter + recursorKernel : + (RecM.checkRecursorBlock recursorBlockId recursorMembers).run + checkerMethods familyBodyAfter = .ok () recursorKernelAfter + exactFamily : + ExactCheckBlock world familyBlockId familyMembers .inductive' + exactRecursor : + ExactCheckBlock world recursorBlockId recursorMembers .recursor + acceptedFamily : familyAcceptedWorld.AcceptedBlock familyBlockId + acceptedRecursor : recursorAcceptedWorld.AcceptedBlock recursorBlockId + +theorem endToEndAcceptance : EndToEndAcceptance where + familyIngress := familyIngressRun + recursorIngress := recursorIngressRun + familyBody := familyBodyRun + recursorBody := recursorBodyRun + familyTrace := familyBodyTrace + recursorTrace := recursorBodyTrace + familyKernel := familyKernelRun + recursorKernel := recursorKernelRun + exactFamily := exactFamilyBlock + exactRecursor := exactRecursorBlock + acceptedFamily := familyBlockAccepted + acceptedRecursor := recursorBlockAccepted + +end BooleanEnumerationFixture + +end Ix.Tc diff --git a/Ix/Tc/Verify/Inductive/EnumerationFixture.lean b/Ix/Tc/Verify/Inductive/EnumerationFixture.lean new file mode 100644 index 000000000..166aebd4c --- /dev/null +++ b/Ix/Tc/Verify/Inductive/EnumerationFixture.lean @@ -0,0 +1,1259 @@ +import Ix.Tc.Verify.Check.SingletonInductive +import Ix.Tc.Verify.Check.PreTranslationCompatibility +import Lean4Lean.Theory.InductiveFixtures + +/-! +# Concrete singleton-enumeration fixture + +This module closes E2b's executable witness with a two-constructor Boolean +enumeration. The Theory side uses Lean4Lean's checked identity-generation +certificate; the concrete side below is built from the actual Ixon block +encoding and production anonymous ingress/checker functions. +-/ + +namespace Ix.Tc + +namespace BooleanEnumerationFixture + +open Lean4Lean +open Lean4Lean.InductiveFixtures +open VInductDecl + +local instance anonKIdDecidableEq : DecidableEq (KId .anon) := fun left right => + if h : left == right then + .isTrue (eq_of_beq h) + else + .isFalse fun equality => h (by cases equality; exact beq_self_eq_true left) + +/-! ## Lean4Lean certificate -/ + +def checked : boolDecl.Checked where + type := boolType + types_eq := rfl + params := [] + params_eq := rfl + indices := [] + indices_eq := rfl + resultLevel := .succ .zero + result_eq := rfl + elimination := .large + elimination_eq := rfl + names := VInductDecl.generatedNames boolType + names_eq := rfl + constructors := boolType.ctors.map + (VInductDecl.CheckedCtor.ofDirect 0 ``Bool 0 0) + constructors_eq := rfl + accepted := by decide + +def generation : GenerationChecked boolDecl := checked.identityGeneration + +theorem declarationWF : boolDecl.WF VEnv.empty := by + refine ⟨rfl, ?_⟩ + intro ty hty + have hty' : ty = boolType := + List.mem_singleton.1 (by simpa [boolDecl] using hty) + subst ty + refine ⟨?_, ?_⟩ + · trivial + · intro ctor hctor + simp [boolType] at hctor + rcases hctor with rfl | rfl <;> exact ⟨trivial, rfl⟩ + +theorem generationWF : generation.WF VEnv.empty := by + exact (checked.wf_of_decl declarationWF).identityGeneration .empty + +def certificate : boolDecl.GenerationCertificate VEnv.empty where + generation := generation + wf := generationWF + +def theoryAfter : VEnv := + (VEnv.empty.addInductCertified certificate).get (by decide) + +theorem theorySuccess : + VEnv.empty.addInductCertified certificate = some theoryAfter := rfl + +def transaction : CertifiedGenerationTransaction boolDecl VEnv.empty + theoryAfter where + certificate := certificate + success := theorySuccess + beforeWF := ⟨[], .empty⟩ + +private theorem enumerationShapeNative : + CertifiedSingletonGeneration.IsEnumeration generation := by + refine ⟨rfl, rfl, rfl, by decide, ?_⟩ + intro index normalized hnormalized + have hindex : index = 0 ∨ index = 1 := by + have hlt : index < generation.block.ctorPairs.length := + (List.getElem?_eq_some_iff.mp hnormalized).1 + change index < 2 at hlt + omega + rcases hindex with rfl | rfl + all_goals + simp [generation, checked, boolDecl, boolType, + VInductDecl.Checked.identityGeneration, + VInductDecl.Checked.identityBlock, + VInductDecl.Normalization.identity, + VInductDecl.NormalizedChecked.ctorPairs, + VInductDecl.pairNormalizedCtors, + VInductDecl.CheckedCtor.ofDirect] at hnormalized + cases hnormalized + native_decide + +theorem enumerationShape : + CertifiedSingletonGeneration.IsEnumeration generation := + enumerationShapeNative + +/-! ## Concrete Ixon family block -/ + +/-- Store a constant at its production content address. -/ +def storeConstant (env : Ixon.Env) (constant : Ixon.Constant) : + Ixon.Env × Address := + let address := Address.blake3 (Ixon.serConstant constant) + (env.storeConst address constant, address) + +/-- Store a Muts block together with every projection constant required by +anonymous ingress. This is the same physical layout emitted by the compiler. -/ +def storeBlockWithProjections (env : Ixon.Env) (block : Ixon.Constant) : + Ixon.Env × Address := Id.run do + let (env, blockAddress) := storeConstant env block + let mut env := env + let .muts members := block.info | return (env, blockAddress) + for h : index in [0:members.size] do + let memberIndex := index.toUInt64 + match members[index] with + | .defn _ => + env := (storeConstant env + ⟨.dPrj ⟨memberIndex, blockAddress⟩, #[], #[], #[]⟩).1 + | .recr _ => + env := (storeConstant env + ⟨.rPrj ⟨memberIndex, blockAddress⟩, #[], #[], #[]⟩).1 + | .indc ind => + env := (storeConstant env + ⟨.iPrj ⟨memberIndex, blockAddress⟩, #[], #[], #[]⟩).1 + for constructorIndex in [0:ind.ctors.size] do + env := (storeConstant env + ⟨.cPrj ⟨memberIndex, constructorIndex.toUInt64, blockAddress⟩, + #[], #[], #[]⟩).1 + return (env, blockAddress) + +def familyIxon : Ixon.Inductive := + ⟨false, 0, 0, 0, .sort 0, + #[⟨false, 0, 0, 0, 0, .recur 0 #[]⟩, + ⟨false, 0, 1, 0, 0, .recur 0 #[]⟩]⟩ + +def familyBlockConstant : Ixon.Constant := + ⟨.muts #[.indc familyIxon], #[], #[], #[.succ .zero]⟩ + +def familyStored : Ixon.Env × Address := + storeBlockWithProjections {} familyBlockConstant + +def familyIxonEnv : Ixon.Env := familyStored.1 +def familyBlockAddress : Address := familyStored.2 + +def familyId : KId .anon := ⟨indcProjAddr familyBlockAddress 0, ()⟩ +def falseId : KId .anon := ⟨ctorProjAddr familyBlockAddress 0 0, ()⟩ +def trueId : KId .anon := ⟨ctorProjAddr familyBlockAddress 0 1, ()⟩ +def constructorIds : Array (KId .anon) := #[falseId, trueId] + +/-! ## Concrete Ixon recursor block -/ + +/-- `Bool → Sort u`, encoded against the recursor block's first reference +(`Bool`) and its sole universe parameter. -/ +def motiveType : Ixon.Expr := + .all (.ref 0 #[]) (.sort 0) + +/-- The canonical enumeration recursor type +`∀ motive, motive false → motive true → ∀ value, motive value`. -/ +def recursorType : Ixon.Expr := + .all motiveType + (.all (.app (.var 0) (.ref 1 #[])) + (.all (.app (.var 1) (.ref 2 #[])) + (.all (.ref 0 #[]) (.app (.var 3) (.var 0))))) + +/-- The `false` equation selects the first minor. -/ +def falseRuleRhs : Ixon.Expr := + .lam motiveType + (.lam (.app (.var 0) (.ref 1 #[])) + (.lam (.app (.var 1) (.ref 2 #[])) (.var 1))) + +/-- The `true` equation selects the second minor. -/ +def trueRuleRhs : Ixon.Expr := + .lam motiveType + (.lam (.app (.var 0) (.ref 1 #[])) + (.lam (.app (.var 1) (.ref 2 #[])) (.var 0))) + +def recursorIxon : Ixon.Recursor := + ⟨false, false, 1, 0, 0, 1, 2, recursorType, + #[⟨0, falseRuleRhs⟩, ⟨0, trueRuleRhs⟩]⟩ + +def recursorBlockConstant : Ixon.Constant := + ⟨.muts #[.recr recursorIxon], #[], + #[familyId.addr, falseId.addr, trueId.addr], #[.var 0]⟩ + +def recursorStored : Ixon.Env × Address := + storeBlockWithProjections familyIxonEnv recursorBlockConstant + +def recursorIxonEnv : Ixon.Env := recursorStored.1 +def recursorBlockAddress : Address := recursorStored.2 +def recursorId : KId .anon := + ⟨recrProjAddr recursorBlockAddress 0, ()⟩ + +/-- The unmodified production ingress computation on the concrete family +block. Result and state selectors let the proof retain the actual opaque +hash-map state without postulating an equality for it. -/ +def familyIngressOutcome := + ingressAnonBlockWithTrace familyIxonEnv familyBlockConstant + familyBlockAddress ({} : AnonEnv) + +def familyIngressResult : AnonBlockIngressTrace := + match familyIngressOutcome with + | .ok result _ => result + | .error _ _ => default + +def familyIngressAfter : AnonEnv := + match familyIngressOutcome with + | .ok _ after => after + | .error _ failed => failed + +def familyIngressSucceeded : Bool := + match familyIngressOutcome with + | .ok _ _ => true + | .error _ _ => false + +private theorem familyIngressSucceededNative : + familyIngressSucceeded = true := by + native_decide + +theorem familyIngressSucceeded_eq : familyIngressSucceeded = true := + familyIngressSucceededNative + +theorem familyIngressRun : + familyIngressOutcome = .ok familyIngressResult familyIngressAfter := by + have success := familyIngressSucceeded_eq + unfold familyIngressSucceeded at success + unfold familyIngressResult familyIngressAfter + generalize houtcome : familyIngressOutcome = outcome at success ⊢ + cases outcome <;> simp_all + +def familyIngressExecution : AnonBlockIngressSuccessTrace familyIxonEnv + familyBlockConstant familyBlockAddress {} familyIngressAfter + familyIngressResult := + AnonBlockIngressSuccessTrace.of_run familyIngressRun + +private theorem familyMemberKidsNative : + familyIngressResult.memberKids = #[familyId] := by + native_decide + +theorem familyMemberKids : familyIngressResult.memberKids = #[familyId] := + familyMemberKidsNative + +private theorem familyEntryIdsNative : + familyIngressResult.allEntries.map (·.1) = + #[familyId] ++ constructorIds := by + native_decide + +theorem familyEntryIds : + familyIngressResult.allEntries.map (·.1) = + #[familyId] ++ constructorIds := + familyEntryIdsNative + +private theorem familyEntriesUniqueNative : + EntryKeysUnique familyIngressResult.allEntries := by + unfold EntryKeysUnique + native_decide + +theorem familyEntriesUnique : + EntryKeysUnique familyIngressResult.allEntries := + familyEntriesUniqueNative + +private theorem familyEntriesSizeNative : + familyIngressResult.allEntries.size = 3 := by + native_decide + +theorem familyEntriesSize : familyIngressResult.allEntries.size = 3 := + familyEntriesSizeNative + +private theorem familyIndexZero : + 0 < familyIngressResult.allEntries.size := by + rw [familyEntriesSize] + omega + +private theorem familyIndexOne : + 1 < familyIngressResult.allEntries.size := by + rw [familyEntriesSize] + omega + +private theorem familyIndexTwo : + 2 < familyIngressResult.allEntries.size := by + rw [familyEntriesSize] + omega + +def familyConcrete : KConst .anon := + (familyIngressResult.allEntries[0]'familyIndexZero).2 + +def falseConcrete : KConst .anon := + (familyIngressResult.allEntries[1]'familyIndexOne).2 + +def trueConcrete : KConst .anon := + (familyIngressResult.allEntries[2]'familyIndexTwo).2 + +private theorem familyEntryNative : + (familyId, familyConcrete) ∈ familyIngressResult.allEntries := by + have member : familyIngressResult.allEntries[0]'familyIndexZero ∈ + familyIngressResult.allEntries := + Array.getElem_mem familyIndexZero + have identifier : + (familyIngressResult.allEntries[0]'familyIndexZero).1 = familyId := by + native_decide + unfold familyConcrete + rw [← identifier] + exact member + +theorem familyEntry : + (familyId, familyConcrete) ∈ familyIngressResult.allEntries := + familyEntryNative + +private theorem falseEntryNative : + (falseId, falseConcrete) ∈ familyIngressResult.allEntries := by + have member : familyIngressResult.allEntries[1]'familyIndexOne ∈ + familyIngressResult.allEntries := + Array.getElem_mem familyIndexOne + have identifier : + (familyIngressResult.allEntries[1]'familyIndexOne).1 = falseId := by + native_decide + unfold falseConcrete + rw [← identifier] + exact member + +theorem falseEntry : + (falseId, falseConcrete) ∈ familyIngressResult.allEntries := + falseEntryNative + +private theorem trueEntryNative : + (trueId, trueConcrete) ∈ familyIngressResult.allEntries := by + have member : familyIngressResult.allEntries[2]'familyIndexTwo ∈ + familyIngressResult.allEntries := + Array.getElem_mem familyIndexTwo + have identifier : + (familyIngressResult.allEntries[2]'familyIndexTwo).1 = trueId := by + native_decide + unfold trueConcrete + rw [← identifier] + exact member + +theorem trueEntry : + (trueId, trueConcrete) ∈ familyIngressResult.allEntries := + trueEntryNative + +/-! ## Concrete recursor ingress -/ + +/-- The recursor is ingressed into the actual family post-state, matching the +two physical-block sequence used by production. -/ +def recursorIngressOutcome := + ingressAnonBlockWithTrace recursorIxonEnv recursorBlockConstant + recursorBlockAddress familyIngressAfter + +def recursorIngressResult : AnonBlockIngressTrace := + match recursorIngressOutcome with + | .ok result _ => result + | .error _ _ => default + +def recursorIngressAfter : AnonEnv := + match recursorIngressOutcome with + | .ok _ after => after + | .error _ failed => failed + +def recursorIngressSucceeded : Bool := + match recursorIngressOutcome with + | .ok _ _ => true + | .error _ _ => false + +private theorem recursorIngressSucceededNative : + recursorIngressSucceeded = true := by + native_decide + +theorem recursorIngressSucceeded_eq : recursorIngressSucceeded = true := + recursorIngressSucceededNative + +theorem recursorIngressRun : + recursorIngressOutcome = + .ok recursorIngressResult recursorIngressAfter := by + have success := recursorIngressSucceeded_eq + unfold recursorIngressSucceeded at success + unfold recursorIngressResult recursorIngressAfter + generalize houtcome : recursorIngressOutcome = outcome at success ⊢ + cases outcome <;> simp_all + +def recursorIngressExecution : AnonBlockIngressSuccessTrace recursorIxonEnv + recursorBlockConstant recursorBlockAddress familyIngressAfter + recursorIngressAfter recursorIngressResult := + AnonBlockIngressSuccessTrace.of_run recursorIngressRun + +private theorem recursorMemberKidsNative : + recursorIngressResult.memberKids = #[recursorId] := by + native_decide + +theorem recursorMemberKids : + recursorIngressResult.memberKids = #[recursorId] := + recursorMemberKidsNative + +private theorem recursorEntryIdsNative : + recursorIngressResult.allEntries.map (·.1) = #[recursorId] := by + native_decide + +theorem recursorEntryIds : + recursorIngressResult.allEntries.map (·.1) = #[recursorId] := + recursorEntryIdsNative + +private theorem recursorEntriesUniqueNative : + EntryKeysUnique recursorIngressResult.allEntries := by + unfold EntryKeysUnique + native_decide + +theorem recursorEntriesUnique : + EntryKeysUnique recursorIngressResult.allEntries := + recursorEntriesUniqueNative + +private theorem recursorEntriesSizeNative : + recursorIngressResult.allEntries.size = 1 := by + native_decide + +theorem recursorEntriesSize : recursorIngressResult.allEntries.size = 1 := + recursorEntriesSizeNative + +private theorem recursorIndexZero : + 0 < recursorIngressResult.allEntries.size := by + rw [recursorEntriesSize] + omega + +def recursorConcrete : KConst .anon := + (recursorIngressResult.allEntries[0]'recursorIndexZero).2 + +private theorem recursorEntryNative : + (recursorId, recursorConcrete) ∈ recursorIngressResult.allEntries := by + have member : recursorIngressResult.allEntries[0]'recursorIndexZero ∈ + recursorIngressResult.allEntries := + Array.getElem_mem recursorIndexZero + have identifier : + (recursorIngressResult.allEntries[0]'recursorIndexZero).1 = + recursorId := by + native_decide + unfold recursorConcrete + rw [← identifier] + exact member + +theorem recursorEntry : + (recursorId, recursorConcrete) ∈ recursorIngressResult.allEntries := + recursorEntryNative + +/-- A proof-relevant structural discriminator which never equates expressions +by their content addresses. -/ +def IsSortOne : KExpr .anon → Prop + | .sort (.succ (.zero _) _) _ => True + | _ => False + +/-- Likewise, recognize a universe-free reference by constructor shape and +exact declaration id, not by expression-address equality. -/ +def IsConstZero (expected : KId .anon) : KExpr .anon → Prop + | .const actual universes _ => actual = expected ∧ universes.size = 0 + | _ => False + +local instance isSortOneDecidable (expression : KExpr .anon) : + Decidable (IsSortOne expression) := by + cases expression <;> try exact .isFalse id + next level _ => + cases level <;> try exact .isFalse id + next inner _ => + cases inner <;> try exact .isFalse id + exact .isTrue trivial + +local instance isConstZeroDecidable (expected : KId .anon) + (expression : KExpr .anon) : Decidable (IsConstZero expected expression) := by + cases expression <;> simp only [IsConstZero] <;> infer_instance + +local instance certifiedSingletonFamilyDecidable + (source : VInductDecl) (sourceGeneration : source.GenerationChecked) + (ids : Array (KId .anon)) (concrete : KConst .anon) : + Decidable + (concrete.IsCertifiedSingletonFamily source sourceGeneration ids) := by + cases concrete <;> + simp only [KConst.IsCertifiedSingletonFamily] <;> infer_instance + +local instance certifiedSingletonConstructorDecidable + (source : VInductDecl) (inductiveId : KId .anon) (index : Nat) + (sourceConstructor : VConstVal) (concrete : KConst .anon) : + Decidable (concrete.IsCertifiedSingletonConstructor source inductiveId + index sourceConstructor) := by + cases concrete <;> + simp only [KConst.IsCertifiedSingletonConstructor] <;> infer_instance + +local instance recursorMajorIdxCoherentDecidable (concrete : KConst .anon) : + Decidable concrete.RecursorMajorIdxCoherent := by + cases concrete <;> + simp only [KConst.RecursorMajorIdxCoherent] <;> infer_instance + +local instance certifiedSingletonRecursorDecidable + (source : VInductDecl) (sourceGeneration : source.GenerationChecked) + (ids : Array (KId .anon)) (concrete : KConst .anon) : + Decidable + (concrete.IsCertifiedSingletonRecursor source sourceGeneration ids) := by + cases concrete <;> + simp only [KConst.IsCertifiedSingletonRecursor] <;> infer_instance + +/-- Executable counterpart of the proof-only universe-scoping predicate. -/ +private def scopedUnivB (bound : Nat) : KUniv .anon → Bool + | .zero _ => true + | .succ u _ => scopedUnivB bound u + | .max a b _ | .imax a b _ => + scopedUnivB bound a && scopedUnivB bound b + | .param index _ _ => decide (index.toNat < bound) + +/-- Executable counterpart of the proof-only expression-scoping predicate. +Keeping this checker explicit makes the concrete fixture suitable for +`native_decide` without adding a classical `Decidable` instance. -/ +private def scopedExprB (depth : UInt64) (levelBound : Nat) : + KExpr .anon → Bool + | .var index _ _ => decide (index < depth) + | .fvar .. => true + | .sort u _ => scopedUnivB levelBound u + | .const _ us _ => us.all (scopedUnivB levelBound) + | .app fn argument _ => + scopedExprB depth levelBound fn && + scopedExprB depth levelBound argument + | .lam _ _ type body _ | .all _ _ type body _ => + scopedExprB depth levelBound type && + scopedExprB (depth + 1) levelBound body + | .letE _ type value body _ _ => + scopedExprB depth levelBound type && + scopedExprB depth levelBound value && + scopedExprB (depth + 1) levelBound body + | .prj _ _ value _ => scopedExprB depth levelBound value + | .nat .. | .str .. => true + +private theorem scopedUnivB_eq_true_iff (bound : Nat) (u : KUniv .anon) : + scopedUnivB bound u = true ↔ u.Scoped bound := by + induction u with + | zero => simp [scopedUnivB, KUniv.Scoped] + | succ u _ ih => simpa [scopedUnivB, KUniv.Scoped] using ih + | max a b _ iha ihb => + simp [scopedUnivB, KUniv.Scoped, iha, ihb] + | imax a b _ iha ihb => + simp [scopedUnivB, KUniv.Scoped, iha, ihb] + | param => simp [scopedUnivB, KUniv.Scoped] + +private theorem scopedExprB_eq_true_iff (depth : UInt64) + (levelBound : Nat) (expression : KExpr .anon) : + scopedExprB depth levelBound expression = true ↔ + expression.Scoped depth levelBound := by + induction expression generalizing depth with + | var => simp [scopedExprB, KExpr.Scoped] + | fvar => simp [scopedExprB, KExpr.Scoped] + | sort => simp [scopedExprB, KExpr.Scoped, scopedUnivB_eq_true_iff] + | const => + simp only [scopedExprB, Array.all_eq_true, + scopedUnivB_eq_true_iff, KExpr.Scoped] + constructor + · intro h u hu + obtain ⟨index, hindex, rfl⟩ := Array.mem_iff_getElem.mp hu + exact h index hindex + · intro h index hindex + exact h _ (Array.getElem_mem hindex) + | app fn argument _ ihFn ihArgument => + simp [scopedExprB, KExpr.Scoped, ihFn, ihArgument] + | lam _ _ type body _ ihType ihBody => + simp [scopedExprB, KExpr.Scoped, ihType, ihBody] + | all _ _ type body _ ihType ihBody => + simp [scopedExprB, KExpr.Scoped, ihType, ihBody] + | letE _ type value body _ _ ihType ihValue ihBody => + simp [scopedExprB, KExpr.Scoped, ihType, ihValue, ihBody, and_assoc] + | prj _ _ value _ ihValue => + simp [scopedExprB, KExpr.Scoped, ihValue] + | nat => simp [scopedExprB, KExpr.Scoped] + | str => simp [scopedExprB, KExpr.Scoped] + +local instance kExprScopedDecidable (depth : UInt64) (levelBound : Nat) + (expression : KExpr .anon) : + Decidable (expression.Scoped depth levelBound) := + if h : scopedExprB depth levelBound expression = true then + .isTrue ((scopedExprB_eq_true_iff depth levelBound expression).mp h) + else + .isFalse fun hscoped => + h ((scopedExprB_eq_true_iff depth levelBound expression).mpr hscoped) + +theorem rawSortOne {nameOf : Address → Option Lean.Name} + {expression : KExpr .anon} + (shape : IsSortOne expression) : + RawExprRel theoryAfter nameOf RawProjRel.none [] expression + (.sort (.succ .zero)) := by + cases expression <;> simp [IsSortOne] at shape + next u _ => + cases u with + | zero _ => simp at shape + | max _ _ _ => simp at shape + | imax _ _ _ => simp at shape + | param _ _ _ => simp at shape + | succ inner _ => + cases inner with + | zero _ => exact RawExprRel.sort + | succ _ _ => simp at shape + | max _ _ _ => simp at shape + | imax _ _ _ => simp at shape + | param _ _ _ => simp at shape + +/-- The fixture's deliberate address-to-name interpretation. The computed +projection addresses are checked distinct below; no hash injectivity theorem +is assumed. -/ +def nameOf (address : Address) : Option Lean.Name := + if address == recursorId.addr then some ``Bool.rec + else if address == familyId.addr then some ``Bool + else if address == falseId.addr then some ``Bool.false + else if address == trueId.addr then some ``Bool.true + else none + +private theorem nameOfRecursorNative : + nameOf recursorId.addr = some ``Bool.rec := by + native_decide + +theorem nameOf_recursor : nameOf recursorId.addr = some ``Bool.rec := + nameOfRecursorNative + +private theorem nameOfFamilyNative : + nameOf familyId.addr = some ``Bool := by + native_decide + +theorem nameOf_family : nameOf familyId.addr = some ``Bool := + nameOfFamilyNative + +private theorem nameOfFalseNative : + nameOf falseId.addr = some ``Bool.false := by + native_decide + +theorem nameOf_false : nameOf falseId.addr = some ``Bool.false := + nameOfFalseNative + +private theorem nameOfTrueNative : + nameOf trueId.addr = some ``Bool.true := by + native_decide + +theorem nameOf_true : nameOf trueId.addr = some ``Bool.true := + nameOfTrueNative + +/-- Turn the structural reference discriminator into raw translation once +the corresponding Theory constant and universe arity are known. -/ +theorem rawConstZero {expected : KId .anon} {expression : KExpr .anon} + (shape : IsConstZero expected expression) + {name : Lean.Name} {constant : VConstant} + (hname : nameOf expected.addr = some name) + (hlookup : theoryAfter.constants name = some constant) + (hlevels : constant.uvars = 0) : + RawExprRel theoryAfter nameOf RawProjRel.none [] expression + (.const name []) := by + cases expression <;> simp [IsConstZero] at shape + next actual universes _ => + rcases shape with ⟨rfl, hsize⟩ + subst universes + exact RawExprRel.const hname hlookup (by simpa using hlevels.symm) + +/-! ## Executable raw translation for the fixture's core syntax -/ + +/-- Translate the closed core syntax used by the Boolean family and recursor. +The partiality is intentional: free variables, lets, projections, and +literals are outside this E2b fixture. Constant translation consults the +same immutable Theory environment and address-to-name interpretation used by +`RawExprRel`. -/ +def translateCore? : KExpr .anon → Option VExpr + | .var index _ _ => some (.bvar index.toNat) + | .sort level _ => some (.sort level.toVLevel) + | .const id levels _ => + match nameOf id.addr with + | none => none + | some name => + match theoryAfter.constants name with + | none => none + | some constant => + if levels.size = constant.uvars then + some (.const name (levels.toList.map KUniv.toVLevel)) + else none + | .app fn argument _ => do + return .app (← translateCore? fn) (← translateCore? argument) + | .lam _ _ type body _ => do + return .lam (← translateCore? type) (← translateCore? body) + | .all _ _ type body _ => do + return .forallE (← translateCore? type) (← translateCore? body) + | _ => none + +/-- Successful executable translation is proof-relevant raw translation. +This theorem lets native evaluation establish only the finite syntax shape; +the trusted conclusion is assembled constructor by constructor. -/ +theorem translateCore?_raw {ctx : List VExpr} {source : KExpr .anon} + {target : VExpr} (success : translateCore? source = some target) : + RawExprRel theoryAfter nameOf RawProjRel.none ctx source target := by + induction source generalizing ctx target with + | var index name info => + simp only [translateCore?, Option.some.injEq] at success + subst target + exact .var + | fvar => simp [translateCore?] at success + | sort level info => + simp only [translateCore?, Option.some.injEq] at success + subst target + exact .sort + | const id levels info => + simp only [translateCore?] at success + split at success + · contradiction + · rename_i name hname + split at success + · contradiction + · rename_i constant hconstant + split at success + · rename_i harity + cases success + exact .const hname hconstant harity + · contradiction + | app fn argument info ihFn ihArgument => + simp only [translateCore?] at success + obtain ⟨fnTarget, hfn, success⟩ := + Option.bind_eq_some_iff.mp success + obtain ⟨argumentTarget, hargument, success⟩ := + Option.bind_eq_some_iff.mp success + cases success + exact .app (ihFn hfn) (ihArgument hargument) + | lam name bi type body info ihType ihBody => + simp only [translateCore?] at success + obtain ⟨typeTarget, htype, success⟩ := + Option.bind_eq_some_iff.mp success + obtain ⟨bodyTarget, hbody, success⟩ := + Option.bind_eq_some_iff.mp success + cases success + exact .lam (ihType htype) (ihBody hbody) + | all name bi type body info ihType ihBody => + simp only [translateCore?] at success + obtain ⟨typeTarget, htype, success⟩ := + Option.bind_eq_some_iff.mp success + obtain ⟨bodyTarget, hbody, success⟩ := + Option.bind_eq_some_iff.mp success + cases success + exact .all (ihType htype) (ihBody hbody) + | letE => simp [translateCore?] at success + | prj => simp [translateCore?] at success + | nat => simp [translateCore?] at success + | str => simp [translateCore?] at success + +/-! ## Concrete recursor interpretation -/ + +private theorem recursorShapeNative : + recursorConcrete.IsCertifiedSingletonRecursor boolDecl generation + constructorIds := by + native_decide + +theorem recursorShape : + recursorConcrete.IsCertifiedSingletonRecursor boolDecl generation + constructorIds := + recursorShapeNative + +/-- The physical rule array selected from the converted recursor. -/ +def recursorRules : Array (RecRule .anon) := + match recursorConcrete with + | .recr (rules := rules) .. => rules + | _ => #[] + +private theorem recursorRulesSizeNative : recursorRules.size = 2 := by + native_decide + +theorem recursorRulesSize : recursorRules.size = 2 := + recursorRulesSizeNative + +/-- Total finite selector; the accompanying size theorem proves that E2b +uses it only at actual rule positions. -/ +def concreteRuleAt (index : Nat) : RecRule .anon := recursorRules[index]! + +theorem recursorRuleAt_iff {index : Nat} {rule : RecRule .anon} : + recursorConcrete.RecursorRuleAt index rule ↔ + recursorRules[index]? = some rule := by + unfold KConst.RecursorRuleAt recursorRules + cases recursorConcrete <;> simp + +theorem concreteRuleAt_ruleAt (index : Nat) (hindex : index < 2) : + recursorConcrete.RecursorRuleAt index (concreteRuleAt index) := by + rw [recursorRuleAt_iff] + have hposition : index < recursorRules.size := by + rw [recursorRulesSize] + exact hindex + rw [Array.getElem?_eq_getElem hposition] + congr 1 + exact (getElem!_pos recursorRules index hposition).symm + +private theorem generationCtorPairZero : + 0 < generation.block.ctorPairs.length := by + native_decide + +private theorem generationCtorPairOne : + 1 < generation.block.ctorPairs.length := by + native_decide + +def falseNormalized : VInductDecl.NormalizedCtor := + generation.block.ctorPairs[0]'generationCtorPairZero + +def trueNormalized : VInductDecl.NormalizedCtor := + generation.block.ctorPairs[1]'generationCtorPairOne + +theorem falseNormalizedAt : + generation.block.ctorPairs[0]? = some falseNormalized := by + rfl + +theorem trueNormalizedAt : + generation.block.ctorPairs[1]? = some trueNormalized := by + rfl + +private theorem recursorTypeRawNative : + RawExprRel theoryAfter nameOf RawProjRel.none [] recursorConcrete.ty + generation.recursor.type := by + apply translateCore?_raw + native_decide + +theorem recursorTypeRaw : + RawExprRel theoryAfter nameOf RawProjRel.none [] recursorConcrete.ty + generation.recursor.type := + recursorTypeRawNative + +private theorem falseRuleRawNative : + RawExprRel theoryAfter nameOf RawProjRel.none [] + (concreteRuleAt 0).rhs (generation.rule 0 falseNormalized).rhs := by + apply translateCore?_raw + native_decide + +theorem falseRuleRaw : + RawExprRel theoryAfter nameOf RawProjRel.none [] + (concreteRuleAt 0).rhs (generation.rule 0 falseNormalized).rhs := + falseRuleRawNative + +private theorem trueRuleRawNative : + RawExprRel theoryAfter nameOf RawProjRel.none [] + (concreteRuleAt 1).rhs (generation.rule 1 trueNormalized).rhs := by + apply translateCore?_raw + native_decide + +theorem trueRuleRaw : + RawExprRel theoryAfter nameOf RawProjRel.none [] + (concreteRuleAt 1).rhs (generation.rule 1 trueNormalized).rhs := + trueRuleRawNative + +private theorem falseRuleFieldsNative : + (concreteRuleAt 0).fields.toNat = + (falseNormalized.fieldsR boolDecl.uvars boolDecl.nparams).length := by + native_decide + +theorem falseRuleFields : + (concreteRuleAt 0).fields.toNat = + (falseNormalized.fieldsR boolDecl.uvars boolDecl.nparams).length := + falseRuleFieldsNative + +private theorem trueRuleFieldsNative : + (concreteRuleAt 1).fields.toNat = + (trueNormalized.fieldsR boolDecl.uvars boolDecl.nparams).length := by + native_decide + +theorem trueRuleFields : + (concreteRuleAt 1).fields.toNat = + (trueNormalized.fieldsR boolDecl.uvars boolDecl.nparams).length := + trueRuleFieldsNative + +private theorem falseRuleBinderCoreNative : + (concreteRuleAt 0).rhs.binderCore = true := by + native_decide + +theorem falseRuleBinderCore : (concreteRuleAt 0).rhs.binderCore = true := + falseRuleBinderCoreNative + +private theorem trueRuleBinderCoreNative : + (concreteRuleAt 1).rhs.binderCore = true := by + native_decide + +theorem trueRuleBinderCore : (concreteRuleAt 1).rhs.binderCore = true := + trueRuleBinderCoreNative + +private theorem falseRuleScopedNative : + (concreteRuleAt 0).rhs.Scoped 0 + (generation.rule 0 falseNormalized).uvars := by + native_decide + +theorem falseRuleScoped : + (concreteRuleAt 0).rhs.Scoped 0 + (generation.rule 0 falseNormalized).uvars := + falseRuleScopedNative + +private theorem trueRuleScopedNative : + (concreteRuleAt 1).rhs.Scoped 0 + (generation.rule 1 trueNormalized).uvars := by + native_decide + +theorem trueRuleScoped : + (concreteRuleAt 1).rhs.Scoped 0 + (generation.rule 1 trueNormalized).uvars := + trueRuleScopedNative + +private theorem falseRuleSizeBoundNative : + (concreteRuleAt 0).rhs.size < UInt64.size := by + native_decide + +theorem falseRuleSizeBound : + (concreteRuleAt 0).rhs.size < UInt64.size := + falseRuleSizeBoundNative + +private theorem trueRuleSizeBoundNative : + (concreteRuleAt 1).rhs.size < UInt64.size := by + native_decide + +theorem trueRuleSizeBound : + (concreteRuleAt 1).rhs.size < UInt64.size := + trueRuleSizeBoundNative + +def falseRulePre : PreTrKExprS theoryAfter + (generation.rule 0 falseNormalized).uvars nameOf RawProjRel.none [] + (concreteRuleAt 0).rhs (generation.rule 0 falseNormalized).rhs := + falseRuleRaw.toPreBinderCore_of_scoped falseRuleBinderCore + falseRuleScoped falseRuleSizeBound + +def trueRulePre : PreTrKExprS theoryAfter + (generation.rule 1 trueNormalized).uvars nameOf RawProjRel.none [] + (concreteRuleAt 1).rhs (generation.rule 1 trueNormalized).rhs := + trueRuleRaw.toPreBinderCore_of_scoped trueRuleBinderCore + trueRuleScoped trueRuleSizeBound + +theorem falseGeneratedRuleMem : + generation.rule 0 falseNormalized ∈ generation.generatedRules := by + exact List.mem_of_getElem? + (CertifiedSingletonGeneration.generatedRuleAt generation falseNormalizedAt) + +theorem trueGeneratedRuleMem : + generation.rule 1 trueNormalized ∈ generation.generatedRules := by + exact List.mem_of_getElem? + (CertifiedSingletonGeneration.generatedRuleAt generation trueNormalizedAt) + +theorem falseGeneratedRuleWF : + (generation.rule 0 falseNormalized).WF theoryAfter := + transaction.facts.afterWF.ordered.defEqWF + (transaction.facts.ruleMem falseGeneratedRuleMem) + +theorem trueGeneratedRuleWF : + (generation.rule 1 trueNormalized).WF theoryAfter := + transaction.facts.afterWF.ordered.defEqWF + (transaction.facts.ruleMem trueGeneratedRuleMem) + +theorem falseRuleTyped : TrKExprS theoryAfter + (generation.rule 0 falseNormalized).uvars nameOf RawProjRel.none [] + (concreteRuleAt 0).rhs (generation.rule 0 falseNormalized).rhs := by + exact falseRulePre.upgradeBinderCoreOfWF transaction.facts.afterWF + (Delta := []) (hDelta := trivial) falseRuleBinderCore + ⟨_, falseGeneratedRuleWF.2⟩ + +theorem trueRuleTyped : TrKExprS theoryAfter + (generation.rule 1 trueNormalized).uvars nameOf RawProjRel.none [] + (concreteRuleAt 1).rhs (generation.rule 1 trueNormalized).rhs := by + exact trueRulePre.upgradeBinderCoreOfWF transaction.facts.afterWF + (Delta := []) (hDelta := trivial) trueRuleBinderCore + ⟨_, trueGeneratedRuleWF.2⟩ + +private theorem familyShapeNative : + familyConcrete.IsCertifiedSingletonFamily boolDecl generation + constructorIds := by + native_decide + +theorem familyShape : + familyConcrete.IsCertifiedSingletonFamily boolDecl generation + constructorIds := + familyShapeNative + +private theorem familyTypeNative : + RawExprRel theoryAfter nameOf RawProjRel.none [] familyConcrete.ty + generation.block.sourceType.type := by + apply rawSortOne + native_decide + +theorem familyType : + RawExprRel theoryAfter nameOf RawProjRel.none [] familyConcrete.ty + generation.block.sourceType.type := + familyTypeNative + +private theorem sourceConstructorZero : + 0 < generation.block.sourceType.ctors.length := by + native_decide + +private theorem sourceConstructorOne : + 1 < generation.block.sourceType.ctors.length := by + native_decide + +def falseSource : VConstVal := + generation.block.sourceType.ctors[0]'sourceConstructorZero + +def trueSource : VConstVal := + generation.block.sourceType.ctors[1]'sourceConstructorOne + +theorem falseSourceAt : + generation.block.sourceType.ctors[0]? = some falseSource := by + rfl + +theorem trueSourceAt : + generation.block.sourceType.ctors[1]? = some trueSource := by + rfl + +private theorem falseSourceTypeNative : + falseSource.type = .const ``Bool [] := by + native_decide + +theorem falseSourceType : falseSource.type = .const ``Bool [] := + falseSourceTypeNative + +private theorem trueSourceTypeNative : + trueSource.type = .const ``Bool [] := by + native_decide + +theorem trueSourceType : trueSource.type = .const ``Bool [] := + trueSourceTypeNative + +private theorem falseShapeNative : + falseConcrete.IsCertifiedSingletonConstructor boolDecl familyId 0 + falseSource := by + native_decide + +theorem falseShape : + falseConcrete.IsCertifiedSingletonConstructor boolDecl familyId 0 + falseSource := + falseShapeNative + +private theorem trueShapeNative : + trueConcrete.IsCertifiedSingletonConstructor boolDecl familyId 1 + trueSource := by + native_decide + +theorem trueShape : + trueConcrete.IsCertifiedSingletonConstructor boolDecl familyId 1 + trueSource := + trueShapeNative + +private theorem falseTypeNative : + RawExprRel theoryAfter nameOf RawProjRel.none [] falseConcrete.ty + falseSource.type := by + rw [falseSourceType] + apply rawConstZero (expected := familyId) + · native_decide + · exact nameOf_family + · exact transaction.facts.familyLookup + · native_decide + +theorem falseType : + RawExprRel theoryAfter nameOf RawProjRel.none [] falseConcrete.ty + falseSource.type := + falseTypeNative + +private theorem trueTypeNative : + RawExprRel theoryAfter nameOf RawProjRel.none [] trueConcrete.ty + trueSource.type := by + rw [trueSourceType] + apply rawConstZero (expected := familyId) + · native_decide + · exact nameOf_family + · exact transaction.facts.familyLookup + · native_decide + +theorem trueType : + RawExprRel theoryAfter nameOf RawProjRel.none [] trueConcrete.ty + trueSource.type := + trueTypeNative + +private theorem familyConstructorCountNative : + constructorIds.size = + generation.block.sourceType.ctors.length := by + native_decide + +/-- The actual family ingress result, interpreted positionally as the +certificate's Boolean family and its two constructors. -/ +def familyInterpretation : SingletonFamilyIngressInterpretation + RawProjRel.none nameOf familyIngressResult transaction where + familyId := familyId + constructorIds := constructorIds + memberKids := familyMemberKids + entryIds := familyEntryIds + entriesUnique := familyEntriesUnique + constructorCount := familyConstructorCountNative + familyConcrete := familyConcrete + familyEntry := familyEntry + familyShape := familyShape + familyName := nameOf_family + familyType := familyType + constructor := by + intro index hindex + change index < 2 at hindex + have hcases : index = 0 ∨ index = 1 := by omega + rcases hcases with rfl | rfl + · refine ⟨falseSource, falseConcrete, falseSourceAt, ?_, falseShape, + ?_, falseType⟩ + · simpa [constructorIds] using falseEntry + · simpa [constructorIds, falseSource] using nameOf_false + · refine ⟨trueSource, trueConcrete, trueSourceAt, ?_, trueShape, + ?_, trueType⟩ + · simpa [constructorIds] using trueEntry + · simpa [constructorIds, trueSource] using nameOf_true + +/-! ## One immutable world for both physical blocks -/ + +/-- The immutable semantic catalog records exactly the four declarations +identified by the two successful ingress traces. Stating this finite map +directly keeps its proof boundary at declaration ids: it does not require a +decidable equality for full kernel constants or any injectivity property of +their content addresses. -/ +def catalog : Catalog := fun id => + if id == familyId then some familyConcrete + else if id == falseId then some falseConcrete + else if id == trueId then some trueConcrete + else if id == recursorId then some recursorConcrete + else none + +/-- Likewise, retain the block table published by those same calls. -/ +def blockCatalog : BlockCatalog := fun id => + recursorIngressAfter.getBlock? id + +def world : VerifyWorld where + catalog := catalog + trusted := fun _ => False + venv := .empty + nameOf := nameOf + venvWF := ⟨[], .empty⟩ + trustedCatalogued := fun {_} h => False.elim h + blocks := blockCatalog + +theorem trustedCatalog : TrustedCatalogRel RawProjRel.none world := + TrustedCatalogLog.empty + +private theorem catalogFamilyNative : + catalog familyId = some familyConcrete := by + unfold catalog + rw [if_pos (by native_decide)] + +theorem catalog_family : catalog familyId = some familyConcrete := + catalogFamilyNative + +private theorem catalogFalseNative : + catalog falseId = some falseConcrete := by + unfold catalog + rw [if_neg (by native_decide), if_pos (by native_decide)] + +theorem catalog_false : catalog falseId = some falseConcrete := + catalogFalseNative + +private theorem catalogTrueNative : + catalog trueId = some trueConcrete := by + unfold catalog + rw [if_neg (by native_decide), if_neg (by native_decide), + if_pos (by native_decide)] + +theorem catalog_true : catalog trueId = some trueConcrete := + catalogTrueNative + +private theorem catalogRecursorNative : + catalog recursorId = some recursorConcrete := by + unfold catalog + rw [if_neg (by native_decide), if_neg (by native_decide), + if_neg (by native_decide), if_pos (by native_decide)] + +theorem catalog_recursor : catalog recursorId = some recursorConcrete := + catalogRecursorNative + +private theorem familyEntryAtZeroNative : + familyIngressResult.allEntries[0]'familyIndexZero = + (familyId, familyConcrete) := by + apply Prod.ext + · native_decide + · rfl + +theorem familyEntryAtZero : + familyIngressResult.allEntries[0]'familyIndexZero = + (familyId, familyConcrete) := + familyEntryAtZeroNative + +private theorem familyEntryAtOneNative : + familyIngressResult.allEntries[1]'familyIndexOne = + (falseId, falseConcrete) := by + apply Prod.ext + · native_decide + · rfl + +theorem familyEntryAtOne : + familyIngressResult.allEntries[1]'familyIndexOne = + (falseId, falseConcrete) := + familyEntryAtOneNative + +private theorem familyEntryAtTwoNative : + familyIngressResult.allEntries[2]'familyIndexTwo = + (trueId, trueConcrete) := by + apply Prod.ext + · native_decide + · rfl + +theorem familyEntryAtTwo : + familyIngressResult.allEntries[2]'familyIndexTwo = + (trueId, trueConcrete) := + familyEntryAtTwoNative + +theorem familyCatalogEntry {id : KId .anon} {concrete : KConst .anon} + (hentry : (id, concrete) ∈ familyIngressResult.allEntries) : + catalog id = some concrete := by + obtain ⟨index, hindex, hget⟩ := Array.mem_iff_getElem.mp hentry + rw [familyEntriesSize] at hindex + have hcases : index = 0 ∨ index = 1 ∨ index = 2 := by omega + rcases hcases with rfl | rfl | rfl + · rw [familyEntryAtZero] at hget + cases hget + exact catalog_family + · rw [familyEntryAtOne] at hget + cases hget + exact catalog_false + · rw [familyEntryAtTwo] at hget + cases hget + exact catalog_true + +def familyLink : SingletonFamilyCatalogLink RawProjRel.none world.catalog + world.nameOf world.trusted transaction := + familyInterpretation.toCatalogLinkOfEntries familyIngressExecution + familyCatalogEntry trustedCatalog + +/-- The successful recursor ingress result interpreted against the same +Boolean generation certificate and the already-linked family block. The +rule proof splits only on the two physically present array positions. -/ +def recursorInterpretation : SingletonRecursorIngressInterpretation + RawProjRel.none world.nameOf recursorIngressResult transaction + familyLink where + recursorId := recursorId + memberKids := recursorMemberKids + entryIds := recursorEntryIds + entriesUnique := recursorEntriesUnique + recursorConcrete := recursorConcrete + recursorEntry := recursorEntry + recursorShape := recursorShape + recursorName := nameOf_recursor + recursorType := recursorTypeRaw + rule := by + intro index hindex + change index < 2 at hindex + have hcases : index = 0 ∨ index = 1 := by omega + rcases hcases with rfl | rfl + · exact ⟨concreteRuleAt 0, falseNormalized, + concreteRuleAt_ruleAt 0 (by omega), falseNormalizedAt, + falseRuleFields, falseRuleRaw, falseRuleTyped⟩ + · exact ⟨concreteRuleAt 1, trueNormalized, + concreteRuleAt_ruleAt 1 (by omega), trueNormalizedAt, + trueRuleFields, trueRuleRaw, trueRuleTyped⟩ + +/-- One immutable semantic catalog now contains the exact family, +constructors, recursor, and both registered Boolean equations produced by +the two physical ingress calls. -/ +def recursorLink : SingletonRecursorCatalogLink RawProjRel.none world.catalog + world.nameOf world.trusted transaction familyLink := + recursorInterpretation.toCatalogLinkOfEntry recursorIngressExecution + catalog_recursor trustedCatalog + + +end BooleanEnumerationFixture + +end Ix.Tc diff --git a/Ix/Tc/Verify/Inductive/IngressExecution.lean b/Ix/Tc/Verify/Inductive/IngressExecution.lean new file mode 100644 index 000000000..0222030a1 --- /dev/null +++ b/Ix/Tc/Verify/Inductive/IngressExecution.lean @@ -0,0 +1,506 @@ +import Ix.Tc.Ingress +import Ix.Tc.Verify.Inductive.SingletonIngress + +/-! +# Anonymous inductive-block ingress execution + +This module exposes the successful execution shape of production anonymous +block ingress. Conversion remains an arbitrary effectful computation; the +only fact extracted from `ingressAnonBlockWithTrace` is its exact final +publication step. Consequently the proof does not reimplement the ingress +stack machine or assume that conversion succeeded. + +The flat entry array is inserted with last-write-wins hash-map semantics. +`EntryKeysUnique` is therefore an explicit premise of the theorem which turns +entry-array membership into a post-state lookup. Concrete fixtures must +discharge it for their actual projection addresses; no Blake3 injectivity is +smuggled into the model. +-/ + +namespace Ix.Tc + +/-! ## Flat insertion semantics -/ + +/-- No two converted entries use the same anonymous id. -/ +def EntryKeysUnique (entries : Array Entry) : Prop := + (entries.toList.map (·.1)).Nodup + +/-- Folding insertions at keys other than `id` preserves its lookup. -/ +private theorem foldl_insert_get?_of_key_not_mem + (entries : List Entry) (env : AnonEnv) (id : KId .anon) + (hnot : id ∉ entries.map (·.1)) : + (entries.foldl (fun env (entryId, concrete) => + env.insert entryId concrete) env).get? id = env.get? id := by + induction entries generalizing env with + | nil => rfl + | cons first rest ih => + rcases first with ⟨firstId, firstConcrete⟩ + simp only [List.map_cons, List.mem_cons, not_or] at hnot + rw [List.foldl_cons, ih _ hnot.2] + simp only [KEnv.get?, KEnv.insert, Std.HashMap.getElem?_insert] + split + · next heq => + exact False.elim (hnot.1 (eq_of_beq heq).symm) + · rfl + +/-- Under key uniqueness, every pair in a left-to-right insertion fold is +the exact lookup retained by the final constant map. -/ +private theorem foldl_insert_get?_of_mem + (entries : List Entry) (env : AnonEnv) + (hunique : (entries.map (·.1)).Nodup) + {id : KId .anon} {concrete : KConst .anon} + (hmem : (id, concrete) ∈ entries) : + (entries.foldl (fun env (entryId, value) => + env.insert entryId value) env).get? id = some concrete := by + induction entries generalizing env with + | nil => simp at hmem + | cons first rest ih => + rcases first with ⟨firstId, firstConcrete⟩ + have hunique' := List.nodup_cons.mp hunique + rcases List.mem_cons.mp hmem with hfirst | hrest + · cases hfirst + rw [List.foldl_cons, + foldl_insert_get?_of_key_not_mem rest _ id hunique'.1] + simp [KEnv.get?, KEnv.insert] + · rw [List.foldl_cons] + exact ih _ hunique'.2 hrest + +/-- Every uniquely keyed entry is loaded by the pure production insertion +transition. Block-map insertion is irrelevant because it leaves the +constant map unchanged. -/ +theorem insertMutsEntriesState_loaded + {before : AnonEnv} {entries : Array Entry} + (hunique : EntryKeysUnique entries) + {id : KId .anon} {concrete : KConst .anon} + (hmem : (id, concrete) ∈ entries) : + (insertMutsEntriesState before entries).get? id = some concrete := by + unfold insertMutsEntriesState insertEntriesState + exact foldl_insert_get?_of_mem entries.toList _ hunique + (by simpa using hmem) + +/-! ## Successful publication traces -/ + +/-- A successful publication call consists of a successful reserved-address +guard followed by the exact pure insertion transition. -/ +inductive InsertMutsEntriesSuccessTrace + (entries : Array Entry) (before after : AnonEnv) : Prop + | run (guarded : AnonEnv) : + guardReserved entries before = .ok () guarded → + after = insertMutsEntriesState guarded entries → + InsertMutsEntriesSuccessTrace entries before after + +namespace InsertMutsEntriesSuccessTrace + +/-- Invert the production effectful wrapper without assuming guard success. -/ +theorem of_run + {entries : Array Entry} {before after : AnonEnv} + (hrun : insertMutsEntries entries before = .ok () after) : + InsertMutsEntriesSuccessTrace entries before after := by + unfold insertMutsEntries at hrun + change EStateM.bind (guardReserved entries) _ before = .ok () after at hrun + unfold EStateM.bind at hrun + cases hguard : guardReserved entries before with + | error err failed => + rw [hguard] at hrun + contradiction + | ok value guarded => + rw [hguard] at hrun + simp only at hrun + have hresult := EStateM.Result.ok.inj hrun + exact .run guarded hguard hresult.2.symm + +/-- Uniquely keyed published entries are exact post-state lookups. -/ +theorem loaded + {entries : Array Entry} {before after : AnonEnv} + (trace : InsertMutsEntriesSuccessTrace entries before after) + (hunique : EntryKeysUnique entries) + {id : KId .anon} {concrete : KConst .anon} + (hmem : (id, concrete) ∈ entries) : + after.get? id = some concrete := by + cases trace with + | run guarded hguard hafter => + rw [hafter] + exact insertMutsEntriesState_loaded hunique hmem + +end InsertMutsEntriesSuccessTrace + +/-- Exact successful decomposition of the traced block ingress wrapper. +`prepareAnonBlock` owns all conversion and deterministic address generation; +`publication` is the sole insertion that follows it. -/ +inductive AnonBlockIngressSuccessTrace + (ixonEnv : Ixon.Env) (blockConstant : Ixon.Constant) + (blockAddr : Address) (before after : AnonEnv) + (result : AnonBlockIngressTrace) : Prop + | run (converted : AnonEnv) : + prepareAnonBlock ixonEnv blockConstant blockAddr before = + .ok result converted → + InsertMutsEntriesSuccessTrace result.allEntries converted after → + AnonBlockIngressSuccessTrace ixonEnv blockConstant blockAddr before + after result + +namespace AnonBlockIngressSuccessTrace + +/-- Invert one actual successful production block-ingress execution. -/ +theorem of_run + {ixonEnv : Ixon.Env} {blockConstant : Ixon.Constant} + {blockAddr : Address} {before after : AnonEnv} + {result : AnonBlockIngressTrace} + (hrun : ingressAnonBlockWithTrace ixonEnv blockConstant blockAddr before = + .ok result after) : + AnonBlockIngressSuccessTrace ixonEnv blockConstant blockAddr before after + result := by + unfold ingressAnonBlockWithTrace at hrun + change EStateM.bind + (prepareAnonBlock ixonEnv blockConstant blockAddr) _ before = + .ok result after at hrun + unfold EStateM.bind at hrun + cases hprepare : prepareAnonBlock ixonEnv blockConstant blockAddr before with + | error err failed => + rw [hprepare] at hrun + contradiction + | ok prepared converted => + rw [hprepare] at hrun + simp only at hrun + change EStateM.bind (insertMutsEntries prepared.allEntries) _ converted = + .ok result after at hrun + unfold EStateM.bind at hrun + cases hinsert : insertMutsEntries prepared.allEntries converted with + | error err failed => + rw [hinsert] at hrun + contradiction + | ok value inserted => + rw [hinsert] at hrun + have hresult := EStateM.Result.ok.inj hrun + rcases hresult with ⟨rfl, rfl⟩ + cases value + exact .run converted hprepare + (InsertMutsEntriesSuccessTrace.of_run hinsert) + +/-- Every uniquely keyed entry returned by successful traced ingress is +loaded in its actual production post-state. -/ +theorem loaded + {ixonEnv : Ixon.Env} {blockConstant : Ixon.Constant} + {blockAddr : Address} {before after : AnonEnv} + {result : AnonBlockIngressTrace} + (trace : AnonBlockIngressSuccessTrace ixonEnv blockConstant blockAddr + before after result) + (hunique : EntryKeysUnique result.allEntries) + {id : KId .anon} {concrete : KConst .anon} + (hmem : (id, concrete) ∈ result.allEntries) : + after.get? id = some concrete := by + cases trace with + | run converted hprepare publication => + exact publication.loaded hunique hmem + +end AnonBlockIngressSuccessTrace + +/-! ## Singleton source interpretations -/ + +open Lean4Lean (VEnv VInductDecl) + +/-- Ghost interpretation of one production family-block conversion result. + +Anonymous ingress cannot recover Lean names from its input, so name and raw +Theory-expression relations are intentionally explicit. Everything about +concrete loading is instead phrased as membership in the actual converted +entry array. `entryIds` also pins the exact flat physical block order used by +production registration. -/ +structure SingletonFamilyIngressInterpretation + (trProj : RawProjRel) (nameOf : Address → Option Lean.Name) + (result : AnonBlockIngressTrace) + {source : VInductDecl} {before theoryAfter : VEnv} + (tx : CertifiedGenerationTransaction source before theoryAfter) where + familyId : KId .anon + constructorIds : Array (KId .anon) + memberKids : result.memberKids = #[familyId] + entryIds : result.allEntries.map (·.1) = #[familyId] ++ constructorIds + entriesUnique : EntryKeysUnique result.allEntries + constructorCount : + constructorIds.size = + tx.certificate.generation.block.sourceType.ctors.length + familyConcrete : KConst .anon + familyEntry : (familyId, familyConcrete) ∈ result.allEntries + familyShape : familyConcrete.IsCertifiedSingletonFamily source + tx.certificate.generation constructorIds + familyName : nameOf familyId.addr = + some tx.certificate.generation.block.sourceType.name + familyType : RawExprRel theoryAfter nameOf trProj [] familyConcrete.ty + tx.certificate.generation.block.sourceType.type + constructor : ∀ (index : Nat) (hindex : index < constructorIds.size), + ∃ sourceConstructor concrete, + tx.certificate.generation.block.sourceType.ctors[index]? = + some sourceConstructor ∧ + (constructorIds[index], concrete) ∈ result.allEntries ∧ + concrete.IsCertifiedSingletonConstructor source familyId index + sourceConstructor ∧ + nameOf constructorIds[index].addr = some sourceConstructor.name ∧ + RawExprRel theoryAfter nameOf trProj [] concrete.ty sourceConstructor.type + +namespace SingletonFamilyIngressInterpretation + +/-- Actual successful ingress turns entry-array interpretation into the +loaded-state family view consumed by the catalog adapter. -/ +def toIngressView + {trProj : RawProjRel} {nameOf : Address → Option Lean.Name} + {result : AnonBlockIngressTrace} + {source : VInductDecl} {before theoryAfter : VEnv} + {tx : CertifiedGenerationTransaction source before theoryAfter} + (interpretation : SingletonFamilyIngressInterpretation trProj nameOf + result tx) + {ixonEnv : Ixon.Env} {blockConstant : Ixon.Constant} + {blockAddr : Address} {ingressBefore ingressAfter : AnonEnv} + (execution : AnonBlockIngressSuccessTrace ixonEnv blockConstant blockAddr + ingressBefore ingressAfter result) : + SingletonFamilyIngressView trProj ingressAfter nameOf tx where + familyId := interpretation.familyId + constructorIds := interpretation.constructorIds + constructorCount := interpretation.constructorCount + familyConcrete := interpretation.familyConcrete + familyLoaded := execution.loaded interpretation.entriesUnique + interpretation.familyEntry + familyShape := interpretation.familyShape + familyName := interpretation.familyName + familyType := interpretation.familyType + constructor := by + intro index hindex + obtain ⟨sourceConstructor, concrete, hsource, hentry, hshape, + hname, htype⟩ := interpretation.constructor index hindex + exact ⟨sourceConstructor, concrete, hsource, + execution.loaded interpretation.entriesUnique hentry, + hshape, hname, htype⟩ + +@[simp] theorem toIngressView_members + {trProj : RawProjRel} {nameOf : Address → Option Lean.Name} + {result : AnonBlockIngressTrace} + {source : VInductDecl} {before theoryAfter : VEnv} + {tx : CertifiedGenerationTransaction source before theoryAfter} + (interpretation : SingletonFamilyIngressInterpretation trProj nameOf + result tx) + {ixonEnv : Ixon.Env} {blockConstant : Ixon.Constant} + {blockAddr : Address} {ingressBefore ingressAfter : AnonEnv} + (execution : AnonBlockIngressSuccessTrace ixonEnv blockConstant blockAddr + ingressBefore ingressAfter result) : + (interpretation.toIngressView execution).members = + result.allEntries.map (·.1) := by + exact interpretation.entryIds.symm + +/-- Complete production-ingress-to-catalog bridge for the family block. +Catalog agreement remains an invariant of the actual ingress post-state; +semantic freshness is derived by `toCatalogLink` from the trusted log. -/ +def toCatalogLink + {trProj : RawProjRel} {world : VerifyWorld} + {result : AnonBlockIngressTrace} + {source : VInductDecl} {theoryAfter : VEnv} + {tx : CertifiedGenerationTransaction source world.venv theoryAfter} + (interpretation : SingletonFamilyIngressInterpretation trProj + world.nameOf result tx) + {ixonEnv : Ixon.Env} {blockConstant : Ixon.Constant} + {blockAddr : Address} {ingressBefore ingressAfter : AnonEnv} + (execution : AnonBlockIngressSuccessTrace ixonEnv blockConstant blockAddr + ingressBefore ingressAfter result) + (loaded : LoadedAgrees world.catalog ingressAfter) + (trustedCatalog : TrustedCatalogRel trProj world) : + SingletonFamilyCatalogLink trProj world.catalog world.nameOf world.trusted + tx := + (interpretation.toIngressView execution).toCatalogLink loaded trustedCatalog + +/-- A narrower catalog bridge for callers which retain exact catalog facts +for the converted entry array but do not need a global `LoadedAgrees` +invariant for the intermediate ingress state. The successful execution index +still prevents a fabricated conversion result from being linked. -/ +def toCatalogLinkOfEntries + {trProj : RawProjRel} {world : VerifyWorld} + {result : AnonBlockIngressTrace} + {source : VInductDecl} {theoryAfter : VEnv} + {tx : CertifiedGenerationTransaction source world.venv theoryAfter} + (interpretation : SingletonFamilyIngressInterpretation trProj + world.nameOf result tx) + {ixonEnv : Ixon.Env} {blockConstant : Ixon.Constant} + {blockAddr : Address} {ingressBefore ingressAfter : AnonEnv} + (_execution : AnonBlockIngressSuccessTrace ixonEnv blockConstant blockAddr + ingressBefore ingressAfter result) + (catalogEntry : ∀ {id concrete}, + (id, concrete) ∈ result.allEntries → + world.catalog id = some concrete) + (trustedCatalog : TrustedCatalogRel trProj world) : + SingletonFamilyCatalogLink trProj world.catalog world.nameOf world.trusted + tx where + familyId := interpretation.familyId + constructorIds := interpretation.constructorIds + constructorCount := interpretation.constructorCount + familyConcrete := interpretation.familyConcrete + familyCatalog := catalogEntry interpretation.familyEntry + familyShape := interpretation.familyShape + familyName := interpretation.familyName + familyType := interpretation.familyType + constructor := by + intro index hindex + obtain ⟨sourceConstructor, concrete, hsource, hentry, hshape, + hname, htype⟩ := interpretation.constructor index hindex + exact ⟨sourceConstructor, concrete, hsource, catalogEntry hentry, + hshape, hname, htype⟩ + fresh := by + intro id hmember + simp only [Array.mem_append, Array.mem_singleton] at hmember + rcases hmember with rfl | hconstructor + · exact (interpretation.toIngressView _execution).familyFresh + trustedCatalog + · obtain ⟨index, hindex, hid⟩ := + Array.mem_iff_getElem.mp hconstructor + subst id + exact (interpretation.toIngressView _execution).constructorFresh + trustedCatalog index hindex + +@[simp] theorem toCatalogLink_members + {trProj : RawProjRel} {world : VerifyWorld} + {result : AnonBlockIngressTrace} + {source : VInductDecl} {theoryAfter : VEnv} + {tx : CertifiedGenerationTransaction source world.venv theoryAfter} + (interpretation : SingletonFamilyIngressInterpretation trProj + world.nameOf result tx) + {ixonEnv : Ixon.Env} {blockConstant : Ixon.Constant} + {blockAddr : Address} {ingressBefore ingressAfter : AnonEnv} + (execution : AnonBlockIngressSuccessTrace ixonEnv blockConstant blockAddr + ingressBefore ingressAfter result) + (loaded : LoadedAgrees world.catalog ingressAfter) + (trustedCatalog : TrustedCatalogRel trProj world) : + (interpretation.toCatalogLink execution loaded trustedCatalog).members = + result.allEntries.map (·.1) := by + exact interpretation.entryIds.symm + +end SingletonFamilyIngressInterpretation + +/-- Ghost interpretation of one production recursor-block conversion result. +The preceding family link fixes the constructor and generated-rule order. -/ +structure SingletonRecursorIngressInterpretation + (trProj : RawProjRel) (nameOf : Address → Option Lean.Name) + (result : AnonBlockIngressTrace) + {source : VInductDecl} {before theoryAfter : VEnv} + (tx : CertifiedGenerationTransaction source before theoryAfter) + {trusted : KId .anon → Prop} {catalog : Catalog} + (family : SingletonFamilyCatalogLink trProj catalog nameOf trusted tx) where + recursorId : KId .anon + memberKids : result.memberKids = #[recursorId] + entryIds : result.allEntries.map (·.1) = #[recursorId] + entriesUnique : EntryKeysUnique result.allEntries + recursorConcrete : KConst .anon + recursorEntry : (recursorId, recursorConcrete) ∈ result.allEntries + recursorShape : recursorConcrete.IsCertifiedSingletonRecursor source + tx.certificate.generation family.constructorIds + recursorName : nameOf recursorId.addr = + some (.str tx.certificate.generation.block.sourceType.name "rec") + recursorType : RawExprRel theoryAfter nameOf trProj [] recursorConcrete.ty + tx.certificate.generation.recursor.type + rule : ∀ (index : Nat) (_hindex : index < family.constructorIds.size), + ∃ concreteRule normalizedConstructor, + recursorConcrete.RecursorRuleAt index concreteRule ∧ + tx.certificate.generation.block.ctorPairs[index]? = + some normalizedConstructor ∧ + concreteRule.fields.toNat = + (normalizedConstructor.fieldsR source.uvars source.nparams).length ∧ + RawExprRel theoryAfter nameOf trProj [] concreteRule.rhs + (tx.certificate.generation.rule index normalizedConstructor).rhs ∧ + TrKExprS theoryAfter + (tx.certificate.generation.rule index normalizedConstructor).uvars + nameOf trProj [] concreteRule.rhs + (tx.certificate.generation.rule index normalizedConstructor).rhs + +namespace SingletonRecursorIngressInterpretation + +/-- Successful recursor ingress supplies the exact concrete lookup missing +from the source interpretation. -/ +def toIngressView + {trProj : RawProjRel} {nameOf : Address → Option Lean.Name} + {result : AnonBlockIngressTrace} + {source : VInductDecl} {before theoryAfter : VEnv} + {tx : CertifiedGenerationTransaction source before theoryAfter} + {trusted : KId .anon → Prop} {catalog : Catalog} + {family : SingletonFamilyCatalogLink trProj catalog nameOf trusted tx} + (interpretation : SingletonRecursorIngressInterpretation trProj nameOf + result tx family) + {ixonEnv : Ixon.Env} {blockConstant : Ixon.Constant} + {blockAddr : Address} {ingressBefore ingressAfter : AnonEnv} + (execution : AnonBlockIngressSuccessTrace ixonEnv blockConstant blockAddr + ingressBefore ingressAfter result) : + SingletonRecursorIngressView trProj ingressAfter nameOf tx family where + recursorId := interpretation.recursorId + recursorConcrete := interpretation.recursorConcrete + recursorLoaded := execution.loaded interpretation.entriesUnique + interpretation.recursorEntry + recursorShape := interpretation.recursorShape + recursorName := interpretation.recursorName + recursorType := interpretation.recursorType + rule := interpretation.rule + +@[simp] theorem toIngressView_members + {trProj : RawProjRel} {nameOf : Address → Option Lean.Name} + {result : AnonBlockIngressTrace} + {source : VInductDecl} {before theoryAfter : VEnv} + {tx : CertifiedGenerationTransaction source before theoryAfter} + {trusted : KId .anon → Prop} {catalog : Catalog} + {family : SingletonFamilyCatalogLink trProj catalog nameOf trusted tx} + (interpretation : SingletonRecursorIngressInterpretation trProj nameOf + result tx family) + {ixonEnv : Ixon.Env} {blockConstant : Ixon.Constant} + {blockAddr : Address} {ingressBefore ingressAfter : AnonEnv} + (execution : AnonBlockIngressSuccessTrace ixonEnv blockConstant blockAddr + ingressBefore ingressAfter result) : + (interpretation.toIngressView execution).members = + result.allEntries.map (·.1) := by + exact interpretation.entryIds.symm + +/-- Complete production-ingress-to-catalog bridge for the recursor block. -/ +def toCatalogLink + {trProj : RawProjRel} {world : VerifyWorld} + {result : AnonBlockIngressTrace} + {source : VInductDecl} {theoryAfter : VEnv} + {tx : CertifiedGenerationTransaction source world.venv theoryAfter} + {family : SingletonFamilyCatalogLink trProj world.catalog world.nameOf + world.trusted tx} + (interpretation : SingletonRecursorIngressInterpretation trProj + world.nameOf result tx family) + {ixonEnv : Ixon.Env} {blockConstant : Ixon.Constant} + {blockAddr : Address} {ingressBefore ingressAfter : AnonEnv} + (execution : AnonBlockIngressSuccessTrace ixonEnv blockConstant blockAddr + ingressBefore ingressAfter result) + (loaded : LoadedAgrees world.catalog ingressAfter) + (trustedCatalog : TrustedCatalogRel trProj world) : + SingletonRecursorCatalogLink trProj world.catalog world.nameOf + world.trusted tx family := + (interpretation.toIngressView execution).toCatalogLink loaded trustedCatalog + +/-- Exact-entry counterpart of `toCatalogLink`. This is useful when the +recursor was loaded after its family and the final immutable catalog is known +at the returned recursor entry, without requiring a global agreement theorem +for every unrelated constant in the final state. -/ +def toCatalogLinkOfEntry + {trProj : RawProjRel} {world : VerifyWorld} + {result : AnonBlockIngressTrace} + {source : VInductDecl} {theoryAfter : VEnv} + {tx : CertifiedGenerationTransaction source world.venv theoryAfter} + {family : SingletonFamilyCatalogLink trProj world.catalog world.nameOf + world.trusted tx} + (interpretation : SingletonRecursorIngressInterpretation trProj + world.nameOf result tx family) + {ixonEnv : Ixon.Env} {blockConstant : Ixon.Constant} + {blockAddr : Address} {ingressBefore ingressAfter : AnonEnv} + (_execution : AnonBlockIngressSuccessTrace ixonEnv blockConstant blockAddr + ingressBefore ingressAfter result) + (catalogEntry : world.catalog interpretation.recursorId = + some interpretation.recursorConcrete) + (trustedCatalog : TrustedCatalogRel trProj world) : + SingletonRecursorCatalogLink trProj world.catalog world.nameOf + world.trusted tx family where + recursorId := interpretation.recursorId + recursorConcrete := interpretation.recursorConcrete + recursorCatalog := catalogEntry + recursorShape := interpretation.recursorShape + recursorName := interpretation.recursorName + recursorType := interpretation.recursorType + rule := interpretation.rule + fresh := (interpretation.toIngressView _execution).recursorFresh + trustedCatalog + +end SingletonRecursorIngressInterpretation + +end Ix.Tc diff --git a/Ix/Tc/Verify/Inductive/IotaPattern.lean b/Ix/Tc/Verify/Inductive/IotaPattern.lean new file mode 100644 index 000000000..545074c42 --- /dev/null +++ b/Ix/Tc/Verify/Inductive/IotaPattern.lean @@ -0,0 +1,145 @@ +import Ix.Tc.Verify.Inductive.RuleApplication + +/-! +# Constructive iota-pattern paths + +`Pattern.varN` captures application arguments from left to right, but its +dependent `Path` type represents the newest argument as `none` and every +older argument under another `some`. The definitions and proofs below make +that ordering explicit. E2b uses them to select the certified minor premise +at a constructor's exact rule index; an off-by-one or reversed-spine adapter +cannot satisfy the positional theorem. +-/ + +namespace Ix.Tc + +open Lean4Lean + +/-- The dependent path of the `index`-th (left-to-right) argument captured by +`pattern.varN arity`. -/ +def IotaVarPath (pattern : Lean4Lean.Pattern) : + (arity : Nat) → Fin arity → + (Lean4Lean.Pattern.varN pattern arity).Path + | 0, index => Fin.elim0 index + | arity + 1, index => + if h : index.val < arity then + some (IotaVarPath pattern arity ⟨index.val, h⟩) + else + none + +/-- Invert a `varN` match to the exact constant-headed argument list and +identify every dependent capture path with its positional list entry. -/ +theorem iotaVarMatch_spine + {name : Lean.Name} {arity : Nat} {source : Lean4Lean.VExpr} + {levels : List Lean4Lean.VLevel} + {captures : ((Lean4Lean.Pattern.const name).varN arity).Path → + Lean4Lean.VExpr} + (hmatch : Lean4Lean.Pattern.Matches + ((Lean4Lean.Pattern.const name).varN arity) + source levels captures) : + ∃ arguments : List Lean4Lean.VExpr, + arguments.length = arity ∧ + source = Lean4Lean.VExpr.appN (.const name levels) arguments ∧ + ∀ index : Fin arity, + arguments[index.val]? = some + (captures (IotaVarPath (.const name) arity index)) := by + induction arity generalizing source with + | zero => + change Lean4Lean.Pattern.Matches (.const name) + source levels captures at hmatch + cases hmatch + exact ⟨[], rfl, rfl, fun index => Fin.elim0 index⟩ + | succ arity ih => + change Lean4Lean.Pattern.Matches + (.var ((Lean4Lean.Pattern.const name).varN arity)) + source levels captures at hmatch + cases hmatch with + | var hprefix => + rename_i fn argument prefixCaptures + obtain ⟨arguments, hlength, rfl, hcaptures⟩ := ih hprefix + refine ⟨arguments ++ [argument], by simp [hlength], ?_, ?_⟩ + · rw [Lean4Lean.VExpr.appN_append] + rfl + · intro index + by_cases hlt : index.val < arity + · rw [List.getElem?_append_left + (by simpa [hlength] using hlt)] + simpa [IotaVarPath, hlt] using + hcaptures ⟨index.val, hlt⟩ + · have heq : index.val = arity := by omega + have hindex : index = Fin.last arity := Fin.ext heq + subst index + rw [List.getElem?_append_right (by simp [hlength])] + simp [IotaVarPath, hlength] + +namespace RecursorIotaPattern + +/-- Path of a recursor-prefix argument within the complete iota pattern. -/ +def recursorArgumentPath + (recursorName : Lean.Name) (majorIdx : Nat) + (constructorName : Lean.Name) (constructorArgs : Nat) + (index : Fin majorIdx) : + (RecursorIotaPattern recursorName majorIdx constructorName + constructorArgs).Path := + Sum.inl (IotaVarPath (.const recursorName) majorIdx index) + +/-- Pattern RHS selecting one exact recursor-prefix argument. -/ +def recursorArgumentRhs + (recursorName : Lean.Name) (majorIdx : Nat) + (constructorName : Lean.Name) (constructorArgs : Nat) + (index : Fin majorIdx) : + (RecursorIotaPattern recursorName majorIdx constructorName + constructorArgs).RHS := + .var (recursorArgumentPath recursorName majorIdx constructorName + constructorArgs index) + +@[simp] theorem recursorArgumentRhs_apply + (recursorName : Lean.Name) (majorIdx : Nat) + (constructorName : Lean.Name) (constructorArgs : Nat) + (index : Fin majorIdx) (levels : List Lean4Lean.VLevel) + (captures : (RecursorIotaPattern recursorName majorIdx constructorName + constructorArgs).Path → Lean4Lean.VExpr) : + (recursorArgumentRhs recursorName majorIdx constructorName constructorArgs + index).apply levels captures = + captures (recursorArgumentPath recursorName majorIdx constructorName + constructorArgs index) := rfl + +/-- A complete iota match exposes both positional application spines. The +constructor universe list is existential because Lean4Lean's pattern result +retains the recursor levels only. -/ +theorem matches_spines + {recursorName constructorName : Lean.Name} + {majorIdx constructorArgs : Nat} {source : Lean4Lean.VExpr} + {levels : List Lean4Lean.VLevel} + {captures : (RecursorIotaPattern recursorName majorIdx constructorName + constructorArgs).Path → Lean4Lean.VExpr} + (hmatch : Lean4Lean.Pattern.Matches + (RecursorIotaPattern recursorName majorIdx constructorName + constructorArgs) source levels captures) : + ∃ recursorArguments constructorLevels constructorArguments, + recursorArguments.length = majorIdx ∧ + constructorArguments.length = constructorArgs ∧ + source = .app + (Lean4Lean.VExpr.appN (.const recursorName levels) + recursorArguments) + (Lean4Lean.VExpr.appN (.const constructorName constructorLevels) + constructorArguments) ∧ + (∀ index : Fin majorIdx, + recursorArguments[index.val]? = some + (captures (recursorArgumentPath recursorName majorIdx + constructorName constructorArgs index))) := by + simp only [RecursorIotaPattern, Lean4Lean.SimplePattern.toPattern] at hmatch + cases hmatch with + | app hrecursor hconstructor => + obtain ⟨recursorArguments, hrecLength, rfl, hrecCaptures⟩ := + iotaVarMatch_spine hrecursor + obtain ⟨constructorArguments, hctorLength, rfl, _⟩ := + iotaVarMatch_spine hconstructor + refine ⟨recursorArguments, _, constructorArguments, hrecLength, + hctorLength, rfl, ?_⟩ + intro index + simpa [recursorArgumentPath] using hrecCaptures index + +end RecursorIotaPattern + +end Ix.Tc diff --git a/Ix/Tc/Verify/Inductive/OccurrenceValidation.lean b/Ix/Tc/Verify/Inductive/OccurrenceValidation.lean new file mode 100644 index 000000000..40c430ebe --- /dev/null +++ b/Ix/Tc/Verify/Inductive/OccurrenceValidation.lean @@ -0,0 +1,551 @@ +import Ix.Tc.Verify.Decl +import Ix.Tc.Verify.Support +import Ix.Tc.Verify.Totalization +import Ix.Tc.Verify.Trans +import Ix.Tc.Verify.World + +/-! +# Recursive-occurrence validation + +E2c consumes the successful branch of production positivity checking. This +module makes that branch proof-visible: a success identifies the active +family, the exact loaded inductive header, every pure arity/universe/index +guard, and the complete state-threaded parameter-definitional-equality loop. +No semantic inductive oracle is used here. +-/ + +namespace Ix.Tc + +/-- Header information read from the actual recursive-family declaration. -/ +def KConst.PositiveRecursiveHeader (concrete : KConst m) + (nParams nIndices levels : Nat) : Prop := + match concrete with + | .indc (params := params) (indices := indices) (lvls := lvls) .. => + params.toNat = nParams ∧ indices.toNat = nIndices ∧ + lvls.toNat = levels + | _ => False + +/-- Elementwise form of the recursive-family universe invariant. Root +families use the canonical symbolic parameter sequence; nested families use +the concrete specialization captured when the auxiliary was discovered. -/ +def PositiveUniverseSpecialization (group : PositivityGroup m) + (us : Array (KUniv m)) : Prop := + match group.concreteUs with + | some expected => + expected.size = us.size ∧ + ∀ i, i < us.size → univEq expected[i]! us[i]! = true + | none => + ∀ i, i < us.size → + univEq us[i]! (.mkParam i.toUInt64 RecM.anonN : KUniv m) = true + +/-- Elementwise form of Lean4Lean's root-family-free index condition. -/ +def RootIndicesIndependent (args : Array (KExpr m)) (nParams : Nat) + (rootAddrs : Array Address) : Prop := + let indices := args.extract nParams args.size + ∀ i (h : i < indices.size), + exprMentionsAnyAddr indices[i] rootAddrs = false + +/-- Exact successful executions of the individual parameter comparisons, +in source order and with every intermediate checker state retained. -/ +inductive PositiveParameterComparisonTrace + (args params : Array (KExpr m)) (methods : Methods m) : + Nat → Nat → TcState m → TcState m → Prop + | nil (index state) : + PositiveParameterComparisonTrace args params methods index 0 state state + | cons {index remaining before afterComparison final} : + (RecM.isDefEq args[index]! params[index]!).run methods before = + .ok true afterComparison → + PositiveParameterComparisonTrace args params methods (index + 1) + remaining afterComparison final → + PositiveParameterComparisonTrace args params methods index + (remaining + 1) before final + +/-- Pointwise semantic consequence of a fixed parameter-comparison slice. -/ +def PositiveParameterPairs (relation : KExpr m → KExpr m → Prop) + (args params : Array (KExpr m)) : Nat → Nat → Prop + | _, 0 => True + | index, remaining + 1 => + relation args[index]! params[index]! ∧ + PositiveParameterPairs relation args params (index + 1) remaining + +/-- Translation and finite-support evidence for each concrete parameter pair. +The translated expressions may differ syntactically; successful DefEq will +establish their Theory equality. -/ +def PositiveParameterTranslationPlan + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) (Delta : KVLCtx) + (args params : Array (KExpr .anon)) : Nat → Nat → Prop + | _, 0 => True + | index, remaining + 1 => + support args[index]! ∧ support params[index]! ∧ + ∃ argumentV parameterV, + TrKExprS world.venv uvars world.nameOf trProj Delta args[index]! + argumentV ∧ + TrKExprS world.venv uvars world.nameOf trProj Delta params[index]! + parameterV ∧ + PositiveParameterTranslationPlan trProj world support uvars Delta + args params (index + 1) remaining + +/-- Theory meaning of one production parameter-uniformity comparison. -/ +def TranslatedParameterDefEq + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) (Delta : KVLCtx) (argument parameter : KExpr .anon) : Prop := + support argument ∧ support parameter ∧ + ∃ argumentV parameterV, + TrKExprS world.venv uvars world.nameOf trProj Delta argument argumentV ∧ + TrKExprS world.venv uvars world.nameOf trProj Delta parameter + parameterV ∧ + world.venv.IsDefEqU uvars Delta.toCtx argumentV parameterV + +/-- The exact semantic callback needed by positivity's parameter loop. + +This contract intentionally stops at the production `isDefEq` call. It does +not grant positivity access to the complete DefEq closure, proposition +classification, or inductive authority. K2 may instantiate it from an +oracle-free recursive-method closure; E2c only consumes the successful-call +meaning and state preservation recorded here. -/ +def PositiveParameterDefEqContract + (trProj : RawProjRel) (world : VerifyWorld) (support : RunSupport) + (uvars : Nat) (Delta : KVLCtx) (methods : Methods .anon) + (invariant : TcState .anon → Prop) : Prop := + ∀ {state : TcState .anon} {argument parameter : KExpr .anon} + {argumentV parameterV : Lean4Lean.VExpr}, + support argument → support parameter → + TrKExprS world.venv uvars world.nameOf trProj Delta argument + argumentV → + TrKExprS world.venv uvars world.nameOf trProj Delta parameter + parameterV → + TcM.WF invariant state ((RecM.isDefEq argument parameter).run methods) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx argumentV parameterV) + +/-- Successful branch of the resolved-header validator. The parameter +comparison keeps its real recursive-method table and threaded checker states +for the later semantic transport theorem. -/ +def PositiveRecursiveApplicationHeaderTrace + (id : KId m) (us : Array (KUniv m)) (args : Array (KExpr m)) + (group : PositivityGroup m) (rootAddrs : Array Address) + (nParams nIndices levels : Nat) (methods : Methods m) + (initial final : TcState m) : Prop := + args.size = nParams + nIndices ∧ + us.size = levels ∧ + RecM.positiveUniverseArgumentsAgree group us = true ∧ + group.params.size = nParams ∧ + ∃ afterParameters, + (RecM.checkPositiveParameters id args group.params nParams).run methods + initial = .ok () afterParameters ∧ + RecM.positiveIndicesIndependent args nParams rootAddrs = true ∧ + final = afterParameters + +/-- Logical valid-inductive-application invariant obtained from the concrete +production guards. The stateful parameter field deliberately retains the +actual `isDefEq` execution: converting it to the normalized Theory parameter +spine is the semantic translation step, not a syntactic assumption. -/ +def ValidPositiveRecursiveApplicationHeader + (id : KId m) (us : Array (KUniv m)) (args : Array (KExpr m)) + (group : PositivityGroup m) (rootAddrs : Array Address) + (nParams nIndices levels : Nat) (methods : Methods m) + (initial final : TcState m) : Prop := + args.size = nParams + nIndices ∧ + us.size = levels ∧ + PositiveUniverseSpecialization group us ∧ + group.params.size = nParams ∧ + ∃ afterParameters, + (RecM.checkPositiveParameters id args group.params nParams).run methods + initial = .ok () afterParameters ∧ + PositiveParameterComparisonTrace args group.params methods 0 nParams + initial afterParameters ∧ + RootIndicesIndependent args nParams rootAddrs ∧ + final = afterParameters + +/-- Exact successful-branch trace of the complete production recursive +application validator, including active-group selection and lazy lookup. -/ +def PositiveRecursiveApplicationTrace + (id : KId m) (us : Array (KUniv m)) (args : Array (KExpr m)) + (groups : Array (PositivityGroup m)) (rootAddrs : Array Address) + (methods : Methods m) (initial final : TcState m) : Prop := + ∃ group concrete nParams nIndices levels afterLookup, + groups.find? (fun candidate => candidate.addrs.contains id.addr) = + some group ∧ + TcM.getConst id initial = .ok concrete afterLookup ∧ + concrete.PositiveRecursiveHeader nParams nIndices levels ∧ + PositiveRecursiveApplicationHeaderTrace id us args group rootAddrs + nParams nIndices levels methods afterLookup final + +/-- Complete selected-family form of the valid-inductive-application +invariant. It contains no `InductiveOracle`: the family and arities come from +the production lookup that occurred in this successful run. -/ +def ValidPositiveRecursiveApplication + (id : KId m) (us : Array (KUniv m)) (args : Array (KExpr m)) + (groups : Array (PositivityGroup m)) (rootAddrs : Array Address) + (methods : Methods m) (initial final : TcState m) : Prop := + ∃ group concrete nParams nIndices levels afterLookup, + groups.find? (fun candidate => candidate.addrs.contains id.addr) = + some group ∧ + TcM.getConst id initial = .ok concrete afterLookup ∧ + concrete.PositiveRecursiveHeader nParams nIndices levels ∧ + ValidPositiveRecursiveApplicationHeader id us args group rootAddrs + nParams nIndices levels methods afterLookup final + +namespace RecM + +/-- Boolean universe agreement is exactly its elementwise logical form. -/ +theorem positiveUniverseArgumentsAgree_eq_true_iff + (group : PositivityGroup m) (us : Array (KUniv m)) : + positiveUniverseArgumentsAgree group us = true ↔ + PositiveUniverseSpecialization group us := by + cases hconcrete : group.concreteUs with + | none => + simp [positiveUniverseArgumentsAgree, PositiveUniverseSpecialization, + hconcrete, List.all_eq_true] + | some expected => + simp [positiveUniverseArgumentsAgree, PositiveUniverseSpecialization, + hconcrete, Bool.and_eq_true, List.all_eq_true] + +/-- Boolean index independence is exactly root-family non-occurrence for +every argument after the parameter prefix. -/ +theorem positiveIndicesIndependent_eq_true_iff + (args : Array (KExpr m)) (nParams : Nat) + (rootAddrs : Array Address) : + positiveIndicesIndependent args nParams rootAddrs = true ↔ + RootIndicesIndependent args nParams rootAddrs := by + unfold positiveIndicesIndependent RootIndicesIndependent + rw [Array.all_eq_true] + simp + +/-- The pure validator succeeds exactly when all four header invariants hold. + This is the bridge from production diagnostics to the logical contract. -/ +theorem checkPositiveRecursiveApplicationPreconditions_success_iff + {us : Array (KUniv m)} {args : Array (KExpr m)} + {group : PositivityGroup m} {nParams nIndices levels : Nat} : + checkPositiveRecursiveApplicationPreconditions us args group nParams + nIndices levels = .ok () ↔ + args.size = nParams + nIndices ∧ + us.size = levels ∧ + positiveUniverseArgumentsAgree group us = true ∧ + group.params.size = nParams := by + unfold checkPositiveRecursiveApplicationPreconditions + by_cases hargs : args.size = nParams + nIndices + · by_cases hus : us.size = levels + · cases huniverses : positiveUniverseArgumentsAgree group us with + | false => simp [hargs, hus] + | true => + by_cases hparams : group.params.size = nParams + · simp [hargs, hus, hparams] + · simp [hargs, hus, hparams] + · simp [hargs, hus] + · simp [hargs] + +/-- Expose one concrete `TcM` bind while decomposing the successful +production trace. -/ +private theorem runTcBind {α β : Type} + (x : TcM m α) (k : α → TcM m β) (state : TcState m) : + (x >>= k) state = match x state with + | .ok value after => k value after + | .error err after => .error err after := by + show EStateM.bind x k state = _ + unfold EStateM.bind + cases x state <;> rfl + +/-- Success of the structurally recursive loop exposes the exact successful +`isDefEq` execution at every parameter position. -/ +theorem checkPositiveParametersFrom_success + (id : KId m) (args params : Array (KExpr m)) (methods : Methods m) : + ∀ {index remaining : Nat} {initial final : TcState m}, + (checkPositiveParametersFrom id args params index remaining).run methods + initial = .ok () final → + PositiveParameterComparisonTrace args params methods index remaining + initial final + | _, 0, initial, final, hrun => by + simp only [checkPositiveParametersFrom, pure, ReaderT.run] at hrun + cases hrun + exact .nil _ _ + | index, remaining + 1, initial, final, hrun => by + rw [checkPositiveParametersFrom, ReaderT.run_bind, runTcBind] at hrun + generalize hcomparison : + (isDefEq args[index]! params[index]!).run methods initial = + comparisonResult at hrun + cases comparisonResult with + | error err afterComparison => contradiction + | ok answer afterComparison => + cases answer with + | false => + simp only [Bool.not_false, if_true] at hrun + change EStateM.Result.error _ afterComparison = .ok () final + at hrun + contradiction + | true => + simp only [Bool.not_true] at hrun + exact .cons hcomparison + (checkPositiveParametersFrom_success id args params methods + hrun) + +/-- Public parameter-loop success trace, starting at the first parameter. -/ +theorem checkPositiveParameters_success + {id : KId m} {args params : Array (KExpr m)} {nParams : Nat} + {methods : Methods m} {initial final : TcState m} + (hrun : (checkPositiveParameters id args params nParams).run methods + initial = .ok () final) : + PositiveParameterComparisonTrace args params methods 0 nParams initial + final := by + exact checkPositiveParametersFrom_success id args params methods hrun + +/-- Any sound interpretation of individual successful `isDefEq` calls lifts +pointwise across the complete parameter trace. -/ +theorem PositiveParameterComparisonTrace.sound + {args params : Array (KExpr m)} {methods : Methods m} + {relation : KExpr m → KExpr m → Prop} + {index remaining : Nat} {initial final : TcState m} + (trace : PositiveParameterComparisonTrace args params methods index + remaining initial final) + (soundComparison : ∀ {position : Nat} {before after : TcState m}, + (isDefEq args[position]! params[position]!).run methods before = + .ok true after → + relation args[position]! params[position]!) : + PositiveParameterPairs relation args params index remaining := by + induction trace with + | nil => trivial + | cons hcomparison _ ih => + exact ⟨soundComparison hcomparison, ih⟩ + +/-- Instantiate every comparison with the narrow production DefEq contract. +This is the semantic parameter-uniformity bridge: a successful concrete loop +yields pointwise `VEnv.IsDefEqU` facts for the translated parameter spine, and +the checker invariant reaches the final threaded state. -/ +theorem PositiveParameterComparisonTrace.theoryDefEq + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {invariant : TcState .anon → Prop} + (defEq : PositiveParameterDefEqContract trProj world support uvars Delta + methods invariant) + {args params : Array (KExpr .anon)} + {index remaining : Nat} {initial final : TcState .anon} + (trace : PositiveParameterComparisonTrace args params methods index + remaining initial final) + (hinitial : invariant initial) + (plan : PositiveParameterTranslationPlan trProj world support + uvars Delta args params index remaining) : + PositiveParameterPairs + (TranslatedParameterDefEq trProj world support + uvars Delta) + args params index remaining ∧ + invariant final := by + induction trace with + | nil => exact ⟨trivial, hinitial⟩ + | @cons index remaining before afterComparison final hcomparison _ ih => + rcases plan with + ⟨hargumentSupport, hparameterSupport, argumentV, parameterV, + hargument, hparameter, htailPlan⟩ + have hverified := defEq + (state := before) + hargumentSupport hparameterSupport hargument hparameter + have hpost := hverified hinitial + rw [hcomparison] at hpost + have htail := ih hpost.1 htailPlan + exact ⟨ + ⟨⟨hargumentSupport, hparameterSupport, argumentV, parameterV, + hargument, hparameter, hpost.2 rfl⟩, htail.1⟩, + htail.2⟩ + +/-- Semantic parameter-uniformity consequence of a valid resolved header. +The operational header retains its exact comparison trace; this theorem +discharges that trace with only the narrow DefEq callback contract. -/ +theorem ValidPositiveRecursiveApplicationHeader.theoryParameters + {trProj : RawProjRel} {world : VerifyWorld} {support : RunSupport} + {uvars : Nat} {Delta : KVLCtx} {methods : Methods .anon} + {invariant : TcState .anon → Prop} + (defEq : PositiveParameterDefEqContract trProj world support uvars Delta + methods invariant) + {id : KId .anon} + {us : Array (KUniv .anon)} {args : Array (KExpr .anon)} + {group : PositivityGroup .anon} {rootAddrs : Array Address} + {nParams nIndices levels : Nat} {initial final : TcState .anon} + (valid : ValidPositiveRecursiveApplicationHeader id us args group + rootAddrs nParams nIndices levels methods initial final) + (hinitial : invariant initial) + (plan : PositiveParameterTranslationPlan trProj world support + uvars Delta args group.params 0 nParams) : + ∃ afterParameters, + PositiveParameterPairs + (TranslatedParameterDefEq trProj world support + uvars Delta) + args group.params 0 nParams ∧ + invariant afterParameters ∧ + final = afterParameters := by + rcases valid with + ⟨_, _, _, _, afterParameters, _, trace, _, hfinal⟩ + have hsemantic := + Ix.Tc.RecM.PositiveParameterComparisonTrace.theoryDefEq defEq trace + hinitial plan + exact ⟨afterParameters, hsemantic.1, hsemantic.2, hfinal⟩ + +/-- A successful resolved-header validation exposes every guard and the exact +parameter-comparison execution that justified it. -/ +theorem checkPositiveRecursiveApplicationHeader_success + {id : KId m} {us : Array (KUniv m)} {args : Array (KExpr m)} + {group : PositivityGroup m} {rootAddrs : Array Address} + {nParams nIndices levels : Nat} {methods : Methods m} + {initial final : TcState m} + (hrun : (checkPositiveRecursiveApplicationHeader id us args group + rootAddrs nParams nIndices levels).run methods initial = .ok () final) : + PositiveRecursiveApplicationHeaderTrace id us args group rootAddrs + nParams nIndices levels methods initial final := by + unfold checkPositiveRecursiveApplicationHeader at hrun + generalize hpreconditions : + checkPositiveRecursiveApplicationPreconditions us args group nParams + nIndices levels = preconditionResult at hrun + cases preconditionResult with + | error err => + simp only at hrun + change EStateM.Result.error err initial = .ok () final at hrun + contradiction + | ok value => + cases value + obtain ⟨hargs, hus, huniverses, hparams⟩ := + checkPositiveRecursiveApplicationPreconditions_success_iff.mp + hpreconditions + simp only at hrun + rw [ReaderT.run_bind, runTcBind] at hrun + generalize hparameterRun : + (checkPositiveParameters id args group.params nParams).run methods + initial = parameterResult at hrun + cases parameterResult with + | error err afterParameters => contradiction + | ok value afterParameters => + cases value + cases hindependent : + positiveIndicesIndependent args nParams rootAddrs with + | false => + simp only [hindependent, Bool.not_false, if_true] at hrun + change EStateM.Result.error _ afterParameters = .ok () final + at hrun + contradiction + | true => + simp only [hindependent, Bool.not_true, pure, + ReaderT.run] at hrun + cases hrun + exact ⟨hargs, hus, huniverses, hparams, final, + hparameterRun, hindependent, rfl⟩ + +/-- Strengthen an operational header trace to its elementwise logical +valid-inductive-application invariant. -/ +theorem PositiveRecursiveApplicationHeaderTrace.valid + {id : KId m} {us : Array (KUniv m)} {args : Array (KExpr m)} + {group : PositivityGroup m} {rootAddrs : Array Address} + {nParams nIndices levels : Nat} {methods : Methods m} + {initial final : TcState m} + (trace : PositiveRecursiveApplicationHeaderTrace id us args group + rootAddrs nParams nIndices levels methods initial final) : + ValidPositiveRecursiveApplicationHeader id us args group rootAddrs + nParams nIndices levels methods initial final := by + rcases trace with + ⟨hargs, hus, huniverses, hparams, afterParameters, hparameterRun, + hindependent, hfinal⟩ + exact ⟨hargs, hus, + (positiveUniverseArgumentsAgree_eq_true_iff group us).mp huniverses, + hparams, afterParameters, hparameterRun, + checkPositiveParameters_success hparameterRun, + (positiveIndicesIndependent_eq_true_iff args nParams rootAddrs).mp + hindependent, + hfinal⟩ + +/-- Direct logical contract for a successful resolved-header run. -/ +theorem checkPositiveRecursiveApplicationHeader_valid + {id : KId m} {us : Array (KUniv m)} {args : Array (KExpr m)} + {group : PositivityGroup m} {rootAddrs : Array Address} + {nParams nIndices levels : Nat} {methods : Methods m} + {initial final : TcState m} + (hrun : (checkPositiveRecursiveApplicationHeader id us args group + rootAddrs nParams nIndices levels).run methods initial = .ok () final) : + ValidPositiveRecursiveApplicationHeader id us args group rootAddrs + nParams nIndices levels methods initial final := + PositiveRecursiveApplicationHeaderTrace.valid + (checkPositiveRecursiveApplicationHeader_success hrun) + +/-- Every successful recursive-application validation exposes the selected +family, exact inductive header, and resolved-header success trace. -/ +theorem checkPositiveRecursiveApplication_success + {id : KId m} {us : Array (KUniv m)} {args : Array (KExpr m)} + {groups : Array (PositivityGroup m)} {rootAddrs : Array Address} + {methods : Methods m} {initial final : TcState m} + (hrun : (checkPositiveRecursiveApplication id us args groups rootAddrs).run + methods initial = .ok () final) : + PositiveRecursiveApplicationTrace id us args groups rootAddrs methods + initial final := by + unfold checkPositiveRecursiveApplication at hrun + generalize hgroup : + groups.find? (fun candidate => candidate.addrs.contains id.addr) = + group? at hrun + cases group? with + | none => + simp only at hrun + change EStateM.Result.error _ initial = .ok () final at hrun + contradiction + | some group => + simp only at hrun + simp only [ReaderT.run_bind, ReaderT.run_monadLift, monadLift_self] + at hrun + rw [runTcBind] at hrun + generalize hlookup : TcM.getConst id initial = lookupResult at hrun + cases lookupResult with + | error err afterLookup => contradiction + | ok concrete afterLookup => + cases concrete with + | indc name levelParams lvls params indices isUnsafe block memberIdx + ty ctors leanAll => + simp only at hrun + exact ⟨group, + .indc name levelParams lvls params indices isUnsafe block + memberIdx ty ctors leanAll, + params.toNat, indices.toNat, lvls.toNat, afterLookup, hgroup, + hlookup, ⟨rfl, rfl, rfl⟩, + checkPositiveRecursiveApplicationHeader_success hrun⟩ + | defn name levelParams kind safety hints lvls ty value leanAll block => + change EStateM.Result.error _ afterLookup = .ok () final at hrun + contradiction + | recr name levelParams k isUnsafe lvls params indices motives minors + block memberIdx ty rules leanAll => + change EStateM.Result.error _ afterLookup = .ok () final at hrun + contradiction + | axio name levelParams isUnsafe lvls ty => + change EStateM.Result.error _ afterLookup = .ok () final at hrun + contradiction + | quot name levelParams kind lvls ty => + change EStateM.Result.error _ afterLookup = .ok () final at hrun + contradiction + | ctor name levelParams isUnsafe lvls induct cidx params fields ty => + change EStateM.Result.error _ afterLookup = .ok () final at hrun + contradiction + +/-- Strengthen the complete operational trace to the selected-family logical +valid-inductive-application invariant. -/ +theorem PositiveRecursiveApplicationTrace.valid + {id : KId m} {us : Array (KUniv m)} {args : Array (KExpr m)} + {groups : Array (PositivityGroup m)} {rootAddrs : Array Address} + {methods : Methods m} {initial final : TcState m} + (trace : PositiveRecursiveApplicationTrace id us args groups rootAddrs + methods initial final) : + ValidPositiveRecursiveApplication id us args groups rootAddrs methods + initial final := by + rcases trace with + ⟨group, concrete, nParams, nIndices, levels, afterLookup, hgroup, + hlookup, hheader, happlication⟩ + exact ⟨group, concrete, nParams, nIndices, levels, afterLookup, hgroup, + hlookup, hheader, + PositiveRecursiveApplicationHeaderTrace.valid happlication⟩ + +/-- Successful production occurrence validation establishes the complete +Ix-side valid-inductive-application invariant without an oracle premise. -/ +theorem checkPositiveRecursiveApplication_valid + {id : KId m} {us : Array (KUniv m)} {args : Array (KExpr m)} + {groups : Array (PositivityGroup m)} {rootAddrs : Array Address} + {methods : Methods m} {initial final : TcState m} + (hrun : (checkPositiveRecursiveApplication id us args groups rootAddrs).run + methods initial = .ok () final) : + ValidPositiveRecursiveApplication id us args groups rootAddrs methods + initial final := + PositiveRecursiveApplicationTrace.valid + (checkPositiveRecursiveApplication_success hrun) + +end RecM +end Ix.Tc diff --git a/Ix/Tc/Verify/Inductive/RuleApplication.lean b/Ix/Tc/Verify/Inductive/RuleApplication.lean new file mode 100644 index 000000000..fe456cc57 --- /dev/null +++ b/Ix/Tc/Verify/Inductive/RuleApplication.lean @@ -0,0 +1,279 @@ +import Ix.Tc.Verify.Inductive.SingletonRecursor + +/-! +# Applying closed generated equations + +Lean4Lean registers generated iota equations as closed lambda telescopes, +whereas the production Ix reducer sees the recursor application after that +telescope has been supplied. These lemmas isolate the ordinary dependent +beta reasoning needed to cross that boundary. + +Nothing in this module assumes an iota pattern is sound. In particular, +`VEnv.Params.extra_pat` is not used: its current interface attempts to match +the still-closed left-hand side and therefore cannot justify the generated +lambda-wrapped equations. The later singleton pattern compiler must provide +the exact telescope arguments and use the lemmas below. +-/ + +namespace Lean4Lean.VExpr + +/-- Universe instantiation commutes with the lambda-telescope constructor. -/ +theorem instL_lamN (levels : List VLevel) : + ∀ (binders : List VExpr) (body : VExpr), + (VExpr.lamN binders body).instL levels = + VExpr.lamN (binders.map (VExpr.instL levels)) + (body.instL levels) + | [], _ => rfl + | binder :: binders, body => by + simp [VExpr.lamN, VExpr.instL, instL_lamN levels binders body] + +/-- Instantiation commutes with the lambda-telescope constructor. -/ +theorem instN_lamN (replacement : VExpr) : + ∀ (binders : List VExpr) (body : VExpr) (depth : Nat), + (VExpr.lamN binders body).inst replacement depth = + VExpr.lamN (VExpr.instTelN replacement binders depth) + (body.inst replacement (depth + binders.length)) + | [], _, _ => rfl + | binder :: binders, body, depth => by + simp only [VExpr.lamN, VExpr.inst, VExpr.instTelN] + rw [instN_lamN replacement binders body (depth + 1)] + congr 2 + simp [Nat.add_comm, Nat.add_left_comm] + +/-- Positional lookup in the reverse de Bruijn range used by generated rule +telescopes. -/ +theorem bvarRevRange_getElem? (off arity index : Nat) + (hindex : index < arity) : + (VExpr.bvarRevRange off arity)[index]? = + some (.bvar (off + (arity - 1 - index))) := by + induction arity generalizing index with + | zero => omega + | succ arity ih => + cases index with + | zero => simp [VExpr.bvarRevRange] + | succ index => + simp only [VExpr.bvarRevRange, List.getElem?_cons_succ] + rw [ih index (by omega)] + congr 2 + omega + +/-- Instantiating the reverse de Bruijn range consumes the argument spine in +its original left-to-right order. -/ +theorem instRev_bvar_at (arguments : List VExpr) (index : Nat) + (hindex : index < arguments.length) : + VExpr.instRev + (.bvar (arguments.length - 1 - index)) arguments = + arguments[index] := by + have hrange := congrArg (fun values => values[index]?) + (VExpr.map_instRev_bvarRevRange arguments) + change ((VExpr.bvarRevRange 0 arguments.length).map + (VExpr.instRev · arguments))[index]? = arguments[index]? at hrange + rw [List.getElem?_map, + bvarRevRange_getElem? 0 arguments.length index hindex] at hrange + simp only [Nat.zero_add, Option.map_some] at hrange + rw [List.getElem?_eq_getElem hindex] at hrange + exact Option.some.inj hrange + +end Lean4Lean.VExpr + +namespace Lean4Lean.VEnv + +/-- Typing an application spine also types its original head. This is a +small inversion helper for the equation-application proofs below. -/ +theorem HasType.appN_head + {env : VEnv} {U : Nat} {Gamma : List VExpr} + (henv : env.WF) (hGamma : OnCtx Gamma (env.IsType U)) + {f : VExpr} {args : List VExpr} {A : VExpr} + (h : env.HasType U Gamma (VExpr.appN f args) A) : + ∃ B, env.HasType U Gamma f B := by + induction args generalizing f A with + | nil => exact ⟨A, h⟩ + | cons arg args ih => + obtain ⟨B, hhead⟩ := ih h + obtain ⟨domain, codomain, hfun, _⟩ := + hhead.app_inv henv.ordered hGamma + exact ⟨_, hfun⟩ + +/-- If two heads expose the same dependent binder telescope, any complete +argument spine which types the first head also types the second. Their result +bodies may differ. This is the typed congruence needed to apply a generated +iota equation: the recursor and the equation lambda share motive/minor +binders, but only the recursor retains the final major binder. -/ +theorem HasType.transfer_appN_telescope + {env : VEnv} {U : Nat} {Gamma : List VExpr} + (henv : env.WF) (hGamma : OnCtx Gamma (env.IsType U)) + {binders : List VExpr} {leftBody rightBody : VExpr} + {left right : VExpr} {arguments : List VExpr} {A : VExpr} + (hlength : arguments.length = binders.length) + (hsource : env.HasType U Gamma (VExpr.appN left arguments) A) + (hleft : env.HasType U Gamma left + (VExpr.forallN binders leftBody)) + (hright : env.HasType U Gamma right + (VExpr.forallN binders rightBody)) : + ∃ B, env.HasType U Gamma (VExpr.appN right arguments) B := by + induction arguments generalizing binders left right leftBody rightBody A with + | nil => + cases binders with + | nil => exact ⟨rightBody, hright⟩ + | cons binder binders => simp at hlength + | cons argument arguments ih => + cases binders with + | nil => simp at hlength + | cons binder binders => + have hrestLength : arguments.length = binders.length := by + simpa using hlength + have hsource' : env.HasType U Gamma + (VExpr.appN (.app left argument) arguments) A := hsource + obtain ⟨prefixType, hprefix⟩ := + HasType.appN_head henv hGamma hsource' + obtain ⟨actualDomain, actualBody, hleftActual, hargument⟩ := + hprefix.app_inv henv.ordered hGamma + have hleft' : env.HasType U Gamma left + (.forallE binder (VExpr.forallN binders leftBody)) := by + simpa only [VExpr.forallN] using hleft + have htypes : env.IsDefEqU U Gamma + (.forallE actualDomain actualBody) + (.forallE binder (VExpr.forallN binders leftBody)) := + hleftActual.uniqU henv hGamma hleft' + obtain ⟨sortLevel, hdomain⟩ := + (htypes.forallE_inv henv hGamma).1 + have hargument' : env.HasType U Gamma argument binder := + hargument.defeqU_r henv hGamma ⟨.sort sortLevel, hdomain⟩ + have hleftApp : env.HasType U Gamma (.app left argument) + ((VExpr.forallN binders leftBody).inst argument) := + .app hleft' hargument' + have hright' : env.HasType U Gamma right + (.forallE binder (VExpr.forallN binders rightBody)) := by + simpa only [VExpr.forallN] using hright + have hrightApp : env.HasType U Gamma (.app right argument) + ((VExpr.forallN binders rightBody).inst argument) := + .app hright' hargument' + rw [VExpr.instN_forallN] at hleftApp hrightApp + have hleftApp' : env.HasType U Gamma (.app left argument) + (VExpr.forallN (VExpr.instTelN argument binders 0) + (leftBody.inst argument binders.length)) := by + simpa only [Nat.zero_add] using hleftApp + have hrightApp' : env.HasType U Gamma (.app right argument) + (VExpr.forallN (VExpr.instTelN argument binders 0) + (rightBody.inst argument binders.length)) := by + simpa only [Nat.zero_add] using hrightApp + have htransLength : arguments.length = + (VExpr.instTelN argument binders 0).length := by + simpa [VExpr.instTelN_length] using hrestLength + exact ih + (binders := VExpr.instTelN argument binders 0) + (leftBody := leftBody.inst argument binders.length) + (rightBody := rightBody.inst argument binders.length) + htransLength hsource hleftApp' hrightApp' + +/-- A typed equality remains valid after applying the same typed spine to +both sides. The final left-hand typing is enough: application inversion and +unique typing recover each dependent argument type. -/ +theorem IsDefEq.appN_same + {env : VEnv} {U : Nat} {Gamma : List VExpr} + (henv : env.WF) (hGamma : OnCtx Gamma (env.IsType U)) + {f g T : VExpr} (hfg : env.IsDefEq U Gamma f g T) + {args : List VExpr} {A : VExpr} + (hsource : env.HasType U Gamma (VExpr.appN f args) A) : + env.IsDefEqU U Gamma (VExpr.appN f args) (VExpr.appN g args) := by + induction args generalizing f g T A with + | nil => exact ⟨T, hfg⟩ + | cons arg rest ih => + have hsource' : env.HasType U Gamma + (VExpr.appN (.app f arg) rest) A := hsource + obtain ⟨headType, hhead⟩ := + HasType.appN_head henv hGamma hsource' + obtain ⟨domain, codomain, hfun, harg⟩ := + hhead.app_inv henv.ordered hGamma + have hfg' : env.IsDefEq U Gamma f g (.forallE domain codomain) := + (show env.IsDefEqU U Gamma f g from ⟨T, hfg⟩).of_l + henv hGamma hfun + exact ih (.appDF hfg' harg) hsource + +/-- Contract the first beta redex beneath an arbitrary remaining application +spine. This is deliberately proved from the Theory beta rule and typing +inversion, not from a syntactic rewrite relation. -/ +theorem HasType.beta_head_appN + {env : VEnv} {U : Nat} {Gamma : List VExpr} + (henv : env.WF) (hGamma : OnCtx Gamma (env.IsType U)) + {domain body arg : VExpr} {rest : List VExpr} {A : VExpr} + (hsource : env.HasType U Gamma + (VExpr.appN (.app (.lam domain body) arg) rest) A) : + env.IsDefEqU U Gamma + (VExpr.appN (.app (.lam domain body) arg) rest) + (VExpr.appN (body.inst arg) rest) := by + obtain ⟨prefixType, hprefix⟩ := + HasType.appN_head henv hGamma hsource + obtain ⟨actualDomain, actualBody, hlam, harg⟩ := + hprefix.app_inv henv.ordered hGamma + obtain ⟨⟨sortLevel, hdomain⟩, bodyType, hbody⟩ := + hlam.lam_inv henv.ordered hGamma + have hcanonical : env.HasType U Gamma (.lam domain body) + (.forallE domain bodyType) := .lam hdomain hbody + have hforallEq : env.IsDefEqU U Gamma + (.forallE actualDomain actualBody) (.forallE domain bodyType) := + hlam.uniqU henv hGamma hcanonical + have hdomainEq : env.IsDefEqU U Gamma actualDomain domain := + let ⟨level, h⟩ := + (hforallEq.forallE_inv henv hGamma).1 + ⟨.sort level, h⟩ + have harg' : env.HasType U Gamma arg domain := + harg.defeqU_r henv hGamma hdomainEq + have hbeta : env.IsDefEq U Gamma + (.app (.lam domain body) arg) (body.inst arg) + (bodyType.inst arg) := .beta hbody harg' + exact IsDefEq.appN_same henv hGamma hbeta hsource + +/-- Supplying exactly one argument per closed lambda binder beta-reduces to +Lean4Lean's outer-to-inner `instRev` operation. This is the reusable semantic +bridge from a registered closed equation to an open generated rule body. -/ +theorem HasType.lamN_appN_beta + {env : VEnv} {U : Nat} {Gamma : List VExpr} + (henv : env.WF) (hGamma : OnCtx Gamma (env.IsType U)) + {binders : List VExpr} {body : VExpr} {args : List VExpr} {A : VExpr} + (hlength : args.length = binders.length) + (hsource : env.HasType U Gamma + (VExpr.appN (VExpr.lamN binders body) args) A) : + env.IsDefEqU U Gamma + (VExpr.appN (VExpr.lamN binders body) args) + (VExpr.instRev body args) := by + induction args generalizing binders body A with + | nil => + cases binders with + | nil => exact ⟨A, hsource⟩ + | cons binder binders => simp at hlength + | cons arg args ih => + cases binders with + | nil => simp at hlength + | cons binder binders => + have hrestLength : args.length = binders.length := by + simpa using hlength + have hfirst : env.IsDefEqU U Gamma + (VExpr.appN + (.app (.lam binder (VExpr.lamN binders body)) arg) args) + (VExpr.appN + ((VExpr.lamN binders body).inst arg) args) := + HasType.beta_head_appN henv hGamma hsource + have hintermediate : env.HasType U Gamma + (VExpr.appN ((VExpr.lamN binders body).inst arg) args) A := + (hfirst.of_l henv hGamma hsource).hasType.2 + rw [VExpr.instN_lamN] at hintermediate hfirst + have htransLength : args.length = + (VExpr.instTelN arg binders 0).length := by + simpa [VExpr.instTelN_length] using hrestLength + have hrest := ih + (binders := VExpr.instTelN arg binders 0) + (body := body.inst arg binders.length) + htransLength (by simpa using hintermediate) + have hrest' : env.IsDefEqU U Gamma + (VExpr.appN + (VExpr.lamN (VExpr.instTelN arg binders 0) + (body.inst arg (0 + binders.length))) args) + (VExpr.instRev + (body.inst arg (0 + binders.length)) args) := by + simpa only [Nat.zero_add] using hrest + have hcombined := hfirst.trans henv hGamma hrest' + simpa only [VExpr.lamN, VExpr.appN, VExpr.instRev, + Nat.zero_add, hrestLength] using hcombined + +end Lean4Lean.VEnv diff --git a/Ix/Tc/Verify/Inductive/SingletonEnumeration.lean b/Ix/Tc/Verify/Inductive/SingletonEnumeration.lean new file mode 100644 index 000000000..d9b7ac1e6 --- /dev/null +++ b/Ix/Tc/Verify/Inductive/SingletonEnumeration.lean @@ -0,0 +1,704 @@ +import Ix.Tc.Verify.Inductive.IotaPattern + +/-! +# Certified singleton enumerations + +This module is E2b's first executable inductive fragment. A singleton +enumeration has no declaration universes, parameters, indices, constructor +fields, or recursive arguments. It may have several nullary constructors, +so its generated iota rules are non-vacuous: rule `i` returns the exact +`i`-th minor premise. + +The restriction is intentionally stated over the normalized generation +retained by E2a. It is therefore a decidable fragment boundary around the +actual generated artifacts, not a second inductive-declaration model. +-/ + +namespace Ix.Tc + +open Lean4Lean (VConstVal VEnv VExpr VInductDecl) + +namespace CertifiedSingletonGeneration + +/-- The first executable E2b fragment: one nonempty, universe-free, +parameter-free, index-free family whose constructors are nullary and +nonrecursive. -/ +structure IsEnumeration {source : VInductDecl} + (generation : source.GenerationChecked) : Prop where + noUniverses : source.uvars = 0 + noParameters : source.nparams = 0 + noIndices : generation.block.rawIndices = [] + nonempty : 0 < generation.block.ctorPairs.length + constructor : ∀ {index : Nat} + {normalized : VInductDecl.NormalizedCtor}, + generation.block.ctorPairs[index]? = some normalized → + normalized.fieldsR source.uvars source.nparams = [] ∧ + normalized.recArgsR source.uvars = [] ∧ + normalized.resultIndicesR source.uvars = [] + +namespace IsEnumeration + +/-- Closed equation binders for the enumeration fragment: one motive and +one minor per constructor. -/ +def ruleBinders {source : VInductDecl} + (generation : source.GenerationChecked) : List VExpr := + generation.motiveType :: generation.minorTypes + +/-- The raw parameter telescope is empty, as opposed to merely having a +counter that claims zero parameters. -/ +theorem rawParams_nil {source : VInductDecl} + {generation : source.GenerationChecked} + (shape : IsEnumeration generation) : + generation.block.rawParams = [] := by + apply List.eq_nil_of_length_eq_zero + rw [generation.shape.1, shape.noParameters] + +@[simp] theorem paramsTel_nil {source : VInductDecl} + {generation : source.GenerationChecked} + (shape : IsEnumeration generation) : + generation.paramsTel = [] := by + simp [VInductDecl.GenerationChecked.paramsTel, shape.rawParams_nil] + +@[simp] theorem idxTel_nil {source : VInductDecl} + {generation : source.GenerationChecked} + (shape : IsEnumeration generation) : + generation.idxTel = [] := by + simp [VInductDecl.GenerationChecked.idxTel, shape.noIndices] + +/-- Every certified enum constructor contributes no field binders to its +generated equation. -/ +theorem fields_nil {source : VInductDecl} + {generation : source.GenerationChecked} + (shape : IsEnumeration generation) + {index : Nat} {normalized : VInductDecl.NormalizedCtor} + (hconstructor : generation.block.ctorPairs[index]? = some normalized) : + normalized.fieldsR source.uvars source.nparams = [] := + (shape.constructor hconstructor).1 + +/-- Every certified enum constructor contributes no recursive calls. -/ +theorem recursive_nil {source : VInductDecl} + {generation : source.GenerationChecked} + (shape : IsEnumeration generation) + {index : Nat} {normalized : VInductDecl.NormalizedCtor} + (hconstructor : generation.block.ctorPairs[index]? = some normalized) : + normalized.recArgsR source.uvars = [] := + (shape.constructor hconstructor).2.1 + +/-- An index-free enum constructor has no normalized result-index spine. -/ +theorem resultIndices_nil {source : VInductDecl} + {generation : source.GenerationChecked} + (shape : IsEnumeration generation) + {index : Nat} {normalized : VInductDecl.NormalizedCtor} + (hconstructor : generation.block.ctorPairs[index]? = some normalized) : + normalized.resultIndicesR source.uvars = [] := + (shape.constructor hconstructor).2.2 + +@[simp] theorem ruleBinders_length {source : VInductDecl} + {generation : source.GenerationChecked} : + (ruleBinders generation).length = + generation.block.ctorPairs.length + 1 := by + simp [ruleBinders, generation.minorTypes_length, Nat.add_comm] + +/-- Exact generated left-hand side for a nullary enum constructor. -/ +theorem rule_lhs {source : VInductDecl} + {generation : source.GenerationChecked} + (shape : IsEnumeration generation) + {index : Nat} {normalized : VInductDecl.NormalizedCtor} + (hconstructor : generation.block.ctorPairs[index]? = some normalized) : + (generation.rule index normalized).lhs = + VExpr.lamN (ruleBinders generation) + (.app + (VExpr.appN + (.const + (.str generation.block.sourceType.name "rec") + (Lean4Lean.VLevel.params 1)) + (VExpr.bvarRevRange 0 + (generation.block.ctorPairs.length + 1))) + (.const normalized.raw.name [])) := by + unfold VInductDecl.GenerationChecked.rule + rw [shape.paramsTel_nil, shape.fields_nil hconstructor, + shape.resultIndices_nil hconstructor] + simp [ruleBinders, VExpr.liftTelN, VExpr.appN, + VExpr.bvarRevRange, shape.noUniverses, shape.noParameters, + Lean4Lean.VLevel.params'] + +/-- Exact generated right-hand side: enum rule `index` is the corresponding +minor variable and has no field/IH application suffix. -/ +theorem rule_rhs {source : VInductDecl} + {generation : source.GenerationChecked} + (shape : IsEnumeration generation) + {index : Nat} {normalized : VInductDecl.NormalizedCtor} + (hconstructor : generation.block.ctorPairs[index]? = some normalized) : + (generation.rule index normalized).rhs = + VExpr.lamN (ruleBinders generation) + (.bvar (generation.block.ctorPairs.length - 1 - index)) := by + unfold VInductDecl.GenerationChecked.rule + rw [shape.paramsTel_nil, shape.fields_nil hconstructor, + shape.recursive_nil hconstructor] + simp [ruleBinders, VExpr.liftTelN, VExpr.appN, + VExpr.bvarRevRange] + +/-- Universe instantiation does not change the number of arguments needed to +open a generated enumeration equation. -/ +@[simp] theorem ruleBinders_instL_length {source : VInductDecl} + {generation : source.GenerationChecked} + (levels : List Lean4Lean.VLevel) : + ((ruleBinders generation).map (VExpr.instL levels)).length = + generation.block.ctorPairs.length + 1 := by + simp + +/-- After universe instantiation, the enumeration recursor and every +generated equation expose the same motive/minor telescope. The recursor +retains only its final major binder after that common prefix. -/ +theorem recType_instantiated {source : VInductDecl} + {generation : source.GenerationChecked} + (shape : IsEnumeration generation) + (levels : List Lean4Lean.VLevel) : + generation.recType.instL levels = + VExpr.forallN + ((ruleBinders generation).map (VExpr.instL levels)) + (.forallE + (.const generation.block.sourceType.name []) + (.app + (.bvar (generation.block.ctorPairs.length + 1)) + (.bvar 0))) := by + unfold VInductDecl.GenerationChecked.recType + rw [shape.paramsTel_nil, shape.idxTel_nil] + simp [ruleBinders, VExpr.forallN, VExpr.appN, VExpr.instL, + VExpr.instL_forallN, VExpr.liftTelN, VExpr.bvarRevRange, shape.noUniverses, + shape.noParameters, Lean4Lean.VLevel.params'] + +/-- After universe instantiation, an enumeration equation has exactly the +same motive/minor telescope as the recursor. Its result body applies the +selected motive to the selected nullary constructor. -/ +theorem ruleType_instantiated {source : VInductDecl} + {generation : source.GenerationChecked} + (shape : IsEnumeration generation) + {index : Nat} {normalized : VInductDecl.NormalizedCtor} + (hconstructor : generation.block.ctorPairs[index]? = some normalized) + (levels : List Lean4Lean.VLevel) : + (generation.rule index normalized).type.instL levels = + VExpr.forallN + ((ruleBinders generation).map (VExpr.instL levels)) + (.app + (.bvar generation.block.ctorPairs.length) + (.const normalized.raw.name [])) := by + unfold VInductDecl.GenerationChecked.rule + rw [shape.paramsTel_nil, shape.fields_nil hconstructor, + shape.resultIndices_nil hconstructor] + simp [ruleBinders, VExpr.forallN, VExpr.appN, VExpr.instL, + VExpr.instL_forallN, VExpr.liftTelN, VExpr.bvarRevRange, shape.noUniverses, + shape.noParameters, Lean4Lean.VLevel.params'] + +/-- Opening the exact generated enumeration LHS with one universe and the +complete motive/minor spine produces the expression matched by the compiled +iota pattern. -/ +theorem ruleLhsBody_instantiated {source : VInductDecl} + {generation : source.GenerationChecked} + (normalized : VInductDecl.NormalizedCtor) + (levels : List Lean4Lean.VLevel) (arguments : List VExpr) + (hlevels : levels.length = 1) + (harguments : arguments.length = + generation.block.ctorPairs.length + 1) : + VExpr.instRev + ((VExpr.app + (VExpr.appN + (.const + (.str generation.block.sourceType.name "rec") + (Lean4Lean.VLevel.params 1)) + (VExpr.bvarRevRange 0 + (generation.block.ctorPairs.length + 1))) + (.const normalized.raw.name [])).instL levels) + arguments = + VExpr.app + (VExpr.appN + (.const + (.str generation.block.sourceType.name "rec") levels) + arguments) + (.const normalized.raw.name []) := by + simp only [VExpr.instL, VExpr.instL_appN, + Lean4Lean.VLevel.inst_map_id hlevels, + VInductDecl.bvarRevRange_instL] + change VExpr.instRev + (VExpr.appN + (VExpr.appN + (.const + (.str generation.block.sourceType.name "rec") levels) + (VExpr.bvarRevRange 0 + (generation.block.ctorPairs.length + 1))) + [.const normalized.raw.name []]) + arguments = _ + rw [VExpr.instRev_appN, VExpr.instRev_appN, + VExpr.instRev_closedN arguments (C := + .const (.str generation.block.sourceType.name "rec") levels) trivial, + ← harguments, VExpr.map_instRev_bvarRevRange] + simp only [List.map_cons, List.map_nil, VExpr.appN] + rw [VExpr.instRev_closedN arguments (C := + .const normalized.raw.name []) trivial] + +/-- Opening the exact generated enumeration RHS selects the same +left-to-right minor argument encoded by the dependent pattern path. -/ +theorem ruleRhsBody_instantiated {source : VInductDecl} + {generation : source.GenerationChecked} + (index : Nat) (hindex : index < generation.block.ctorPairs.length) + (levels : List Lean4Lean.VLevel) (arguments : List VExpr) + (harguments : arguments.length = + generation.block.ctorPairs.length + 1) : + VExpr.instRev + ((VExpr.bvar + (generation.block.ctorPairs.length - 1 - index)).instL levels) + arguments = + arguments[index + 1] := by + have hargument : index + 1 < arguments.length := by omega + have hdeBruijn : + generation.block.ctorPairs.length - 1 - index = + arguments.length - 1 - (index + 1) := by omega + change VExpr.instRev + (.bvar (generation.block.ctorPairs.length - 1 - index)) arguments = _ + rw [hdeBruijn] + exact VExpr.instRev_bvar_at arguments (index + 1) hargument + +end IsEnumeration + +end CertifiedSingletonGeneration + +namespace KConst.IsCertifiedSingletonRecursor + +/-- In the enumeration fragment the production major is immediately after +the motive and all constructor minors. -/ +theorem enumerationMajorIdx + {source : VInductDecl} {generation : source.GenerationChecked} + {constructorIds : Array (KId .anon)} {concrete : KConst .anon} + (hrecursor : concrete.IsCertifiedSingletonRecursor source generation + constructorIds) + (shape : CertifiedSingletonGeneration.IsEnumeration generation) : + concrete.RecursorMajorIdx = some (constructorIds.size + 1) := by + cases concrete with + | recr name levelParams k isUnsafe levels params indices motives minors + block memberIdx type rules leanAll => + simp only [KConst.IsCertifiedSingletonRecursor] at hrecursor + simp only [KConst.RecursorMajorIdx] + apply congrArg some + have hparams : params.toNat = 0 := + hrecursor.2.1.trans shape.noParameters + have hindices : indices.toNat = 0 := by + simpa [shape.noIndices] using hrecursor.2.2.1 + calc + (params + motives + minors + indices).toNat = + params.toNat + motives.toNat + minors.toNat + indices.toNat := + hrecursor.2.2.2.2.2.2.2 + _ = 0 + 1 + constructorIds.size + 0 := by + rw [hparams, hrecursor.2.2.2.1, + hrecursor.2.2.2.2.1, hindices] + _ = constructorIds.size + 1 := by omega + | _ => simp [KConst.IsCertifiedSingletonRecursor] at hrecursor + +end KConst.IsCertifiedSingletonRecursor + +namespace SingletonRecursorCatalogLink + +/-- The concrete pattern compiled for enumeration rule `index`. The +recursor prefix consists of one motive followed by one minor per +constructor; the selected RHS is therefore minor `index` at prefix position +`index + 1`. -/ +def enumerationPattern + {trProj : RawProjRel} {catalog : Catalog} + {nameOf : Address → Option Lean.Name} {trusted : KId .anon → Prop} + {source : VInductDecl} {before after : VEnv} + {tx : CertifiedGenerationTransaction source before after} + {family : SingletonFamilyCatalogLink trProj catalog nameOf trusted tx} + (_link : SingletonRecursorCatalogLink trProj catalog nameOf trusted tx + family) + (index : Nat) (hindex : index < family.constructorIds.size) + (normalized : VInductDecl.NormalizedCtor) : RecursorRulePattern where + recursorName := + .str tx.certificate.generation.block.sourceType.name "rec" + constructorId := family.constructorIds[index] + constructorName := normalized.raw.name + constructorParams := 0 + constructorFields := 0 + ruleIndex := index + majorIdx := family.constructorIds.size + 1 + rhs := RecursorIotaPattern.recursorArgumentRhs + (.str tx.certificate.generation.block.sourceType.name "rec") + (family.constructorIds.size + 1) normalized.raw.name 0 + ⟨index + 1, by omega⟩ + checks := .true + +@[simp] theorem enumerationPattern_ruleIndex + {trProj : RawProjRel} {catalog : Catalog} + {nameOf : Address → Option Lean.Name} {trusted : KId .anon → Prop} + {source : VInductDecl} {before after : VEnv} + {tx : CertifiedGenerationTransaction source before after} + {family : SingletonFamilyCatalogLink trProj catalog nameOf trusted tx} + (_link : SingletonRecursorCatalogLink trProj catalog nameOf trusted tx + family) + (index : Nat) (hindex : index < family.constructorIds.size) + (normalized : VInductDecl.NormalizedCtor) : + (_link.enumerationPattern index hindex normalized).ruleIndex = index := rfl + +/-- Resolve a normalized enum constructor to the exact physical constructor +slot used by production iota dispatch. -/ +theorem enumerationConstructorAt + {trProj : RawProjRel} {catalog : Catalog} + {nameOf : Address → Option Lean.Name} {trusted : KId .anon → Prop} + {source : VInductDecl} {before after : VEnv} + {tx : CertifiedGenerationTransaction source before after} + {family : SingletonFamilyCatalogLink trProj catalog nameOf trusted tx} + (_link : SingletonRecursorCatalogLink trProj catalog nameOf trusted tx + family) + (shape : CertifiedSingletonGeneration.IsEnumeration + tx.certificate.generation) + {index : Nat} (hindex : index < family.constructorIds.size) + {normalized : VInductDecl.NormalizedCtor} + (hnormalized : + tx.certificate.generation.block.ctorPairs[index]? = some normalized) : + ∃ concrete, + catalog family.constructorIds[index] = some concrete ∧ + concrete.ConstructorAt index 0 0 ∧ + nameOf family.constructorIds[index].addr = some normalized.raw.name := by + obtain ⟨sourceConstructor, concrete, hsource, hcatalog, hconcrete, + hname, _⟩ := family.constructor index hindex + have hnormalizedSource := + CertifiedSingletonGeneration.rawConstructorAt + tx.certificate.generation hnormalized + have hsourceEq : sourceConstructor = normalized.raw := by + rw [hsource] at hnormalizedSource + exact Option.some.inj hnormalizedSource + subst sourceConstructor + have hfieldsR := shape.fields_nil hnormalized + have hrawFields : normalized.rawFields source.nparams = [] := by + simpa [VInductDecl.NormalizedCtor.fieldsR] using hfieldsR + change VInductDecl.ctorFields + (VExpr.dropN source.nparams normalized.raw.type) = [] at hrawFields + refine ⟨concrete, hcatalog, ?_, hname⟩ + cases concrete with + | ctor name levelParams isUnsafe levels induct cidx params fields type => + simp only [KConst.IsCertifiedSingletonConstructor] at hconcrete + simp only [KConst.ConstructorAt] + refine ⟨hconcrete.2.2.1, ?_, ?_⟩ + · apply UInt64.toNat_inj.mp + simpa [shape.noParameters] using hconcrete.2.2.2.1 + · apply UInt64.toNat_inj.mp + rw [hrawFields] at hconcrete + simpa using hconcrete.2.2.2.2 + | _ => simp [KConst.IsCertifiedSingletonConstructor] at hconcrete + +/-- All finite pattern metadata for an enum rule is forced by the two exact +catalog links and the E2a generation position. No semantic rewrite premise +is used here. -/ +theorem enumerationPatternMetadata + {trProj : RawProjRel} {catalog : Catalog} + {nameOf : Address → Option Lean.Name} {trusted : KId .anon → Prop} + {source : VInductDecl} {before after : VEnv} + {tx : CertifiedGenerationTransaction source before after} + {family : SingletonFamilyCatalogLink trProj catalog nameOf trusted tx} + (link : SingletonRecursorCatalogLink trProj catalog nameOf trusted tx + family) + (shape : CertifiedSingletonGeneration.IsEnumeration + tx.certificate.generation) + {index : Nat} {rule : RecRule .anon} + (hrule : link.recursorConcrete.RecursorRuleAt index rule) : + ∃ (hindex : index < family.constructorIds.size) + (normalized : VInductDecl.NormalizedCtor), + tx.certificate.generation.block.ctorPairs[index]? = some normalized ∧ + RawRecursorRulePatternMetadataRel catalog nameOf link.recursorId + link.recursorConcrete rule + (link.enumerationPattern index hindex normalized) := by + have hindex := link.recursorShape.ruleCount hrule + obtain ⟨normalized, hnormalized, _, hfields, _, _⟩ := + link.ruleAt hrule + obtain ⟨constructor, hconstructorCatalog, hconstructorAt, + hconstructorName⟩ := + link.enumerationConstructorAt shape hindex hnormalized + have hruleFields : rule.fields = 0 := by + apply UInt64.toNat_inj.mp + rw [hfields, shape.fields_nil hnormalized] + rfl + refine ⟨hindex, normalized, hnormalized, { + recursorName := ?_ + majorIdx := ?_ + majorIdxCoherent := link.recursorShape.coherent + ruleAt := ?_ + constructorName := ?_ + constructorAt := ?_ + fields := ?_ }⟩ + · simpa [enumerationPattern] using link.recursorName + · simpa [enumerationPattern] using + link.recursorShape.enumerationMajorIdx shape + · simpa [enumerationPattern] using hrule + · simpa [enumerationPattern] using hconstructorName + · exact ⟨constructor, by + simpa [enumerationPattern] using hconstructorCatalog, by + simpa [enumerationPattern] using hconstructorAt⟩ + · simpa [enumerationPattern] using hruleFields + +/-- The compiled enum pattern is semantically justified by the exact +registered generated equation. This is the central E2b bridge: a successful +pattern match is reduced through Lean4Lean's registered equality, rather than +through an independently postulated iota law. -/ +theorem enumerationPatternSound + {trProj : RawProjRel} {catalog : Catalog} + {nameOf : Address → Option Lean.Name} {trusted : KId .anon → Prop} + {source : VInductDecl} {before after : VEnv} + {tx : CertifiedGenerationTransaction source before after} + {family : SingletonFamilyCatalogLink trProj catalog nameOf trusted tx} + (link : SingletonRecursorCatalogLink trProj catalog nameOf trusted tx + family) + (shape : CertifiedSingletonGeneration.IsEnumeration + tx.certificate.generation) + {index : Nat} {rule : RecRule .anon} + (hrule : link.recursorConcrete.RecursorRuleAt index rule) + (hindex : index < family.constructorIds.size) + (normalized : VInductDecl.NormalizedCtor) + (hnormalized : + tx.certificate.generation.block.ctorPairs[index]? = some normalized) : + (link.enumerationPattern index hindex normalized).Sound after := by + intro future hfuture hfutureWF uvars Gamma matched levels captures A + hGamma hmatches htype _hchecks + let generation := tx.certificate.generation + have hcount : family.constructorIds.size = + generation.block.ctorPairs.length := by + rw [family.constructorCount, ← generation.rawCtors_eq] + simp + change Lean4Lean.Pattern.Matches + (RecursorIotaPattern + (.str generation.block.sourceType.name "rec") + (family.constructorIds.size + 1) normalized.raw.name 0) + matched levels captures at hmatches + obtain ⟨recursorArguments, constructorLevels, constructorArguments, + hrecursorLength, hconstructorLength, hmatched, hcaptures⟩ := + RecursorIotaPattern.matches_spines hmatches + have hconstructorArguments : constructorArguments = [] := + List.eq_nil_of_length_eq_zero hconstructorLength + rw [hmatched] at htype + obtain ⟨majorDomain, majorBody, hrecursorApplied, hconstructorApplied⟩ := + htype.app_inv hfutureWF.ordered hGamma + + have hrecursorHead := + Lean4Lean.VEnv.HasType.appN_head hfutureWF hGamma hrecursorApplied + obtain ⟨recursorHeadType, hrecursorHeadType⟩ := hrecursorHead + obtain ⟨recursorConstant, hrecursorLookup, hlevelsWF, + hlevelsArity⟩ := + hrecursorHeadType.const_inv hfutureWF.ordered hGamma + have hcertifiedRecursorLookup := + hfuture.constants tx.facts.recursorLookup + have hrecursorConstant : recursorConstant = generation.recursor := by + exact Option.some.inj + (hrecursorLookup.symm.trans hcertifiedRecursorLookup) + subst recursorConstant + have hlevelsLength : levels.length = 1 := by + simpa [VInductDecl.GenerationChecked.recursor, + shape.noUniverses] using hlevelsArity + + rw [hconstructorArguments] at hconstructorApplied + simp only [VExpr.appN] at hconstructorApplied + obtain ⟨constructorConstant, hconstructorLookup, _, + hconstructorLevelsArity⟩ := + hconstructorApplied.const_inv hfutureWF.ordered hGamma + have hrawConstructor := + CertifiedSingletonGeneration.rawConstructorAt generation hnormalized + have hrawConstructorMem : + normalized.raw ∈ generation.block.sourceType.ctors := + List.mem_of_getElem? hrawConstructor + have hcertifiedConstructorLookup := + hfuture.constants (tx.facts.ctorLookup hrawConstructorMem) + have hconstructorConstant : + constructorConstant = normalized.raw.toVConstant := by + exact Option.some.inj + (hconstructorLookup.symm.trans hcertifiedConstructorLookup) + subst constructorConstant + have hconstructorLevelsLength : constructorLevels.length = 0 := by + calc + constructorLevels.length = normalized.raw.toVConstant.uvars := + hconstructorLevelsArity + _ = normalized.raw.uvars := rfl + _ = source.uvars := + CertifiedSingletonGeneration.sourceConstructorUvars generation + hrawConstructorMem + _ = 0 := shape.noUniverses + have hconstructorLevels : constructorLevels = [] := + List.eq_nil_of_length_eq_zero hconstructorLevelsLength + + obtain ⟨registeredNormalized, hregisteredNormalized, hregistered⟩ := + link.registeredRuleAt hrule + have hnormalizedEq : registeredNormalized = normalized := by + rw [hnormalized] at hregisteredNormalized + exact (Option.some.inj hregisteredNormalized).symm + subst registeredNormalized + have hregisteredFuture := hregistered.mono hfuture + obtain ⟨_, _, _, _, hdefeqRegistered, hdefeqWF, _, _, _⟩ := + hregisteredFuture + have hlevelsRuleArity : + levels.length = (generation.rule index normalized).uvars := by + simpa [VInductDecl.GenerationChecked.rule, shape.noUniverses] using + hlevelsLength + have hequation : future.IsDefEq uvars Gamma + ((generation.rule index normalized).lhs.instL levels) + ((generation.rule index normalized).rhs.instL levels) + ((generation.rule index normalized).type.instL levels) := + .extra hdefeqRegistered hlevelsWF hlevelsRuleArity + + have hrecursorConstantTyped : future.HasType uvars Gamma + (.const (.str generation.block.sourceType.name "rec") levels) + (generation.recType.instL levels) := by + simpa [VInductDecl.GenerationChecked.recursor] using + (Lean4Lean.VEnv.HasType.const + (Γ := Gamma) hcertifiedRecursorLookup hlevelsWF hlevelsArity) + have hrecursorCommonType : future.HasType uvars Gamma + (.const (.str generation.block.sourceType.name "rec") levels) + (VExpr.forallN + ((CertifiedSingletonGeneration.IsEnumeration.ruleBinders generation).map + (VExpr.instL levels)) + (.forallE + (.const generation.block.sourceType.name []) + (.app (.bvar (generation.block.ctorPairs.length + 1)) + (.bvar 0)))) := by + rw [← shape.recType_instantiated levels] + exact hrecursorConstantTyped + have hequationLhsCommonType : future.HasType uvars Gamma + ((generation.rule index normalized).lhs.instL levels) + (VExpr.forallN + ((CertifiedSingletonGeneration.IsEnumeration.ruleBinders generation).map + (VExpr.instL levels)) + (.app (.bvar generation.block.ctorPairs.length) + (.const normalized.raw.name []))) := by + rw [← shape.ruleType_instantiated hnormalized levels] + exact hequation.hasType.1 + have hargumentLength : recursorArguments.length = + ((CertifiedSingletonGeneration.IsEnumeration.ruleBinders generation).map + (VExpr.instL levels)).length := by + rw [hrecursorLength, List.length_map, + CertifiedSingletonGeneration.IsEnumeration.ruleBinders_length, + hcount] + obtain ⟨equationApplicationType, hequationLhsApplied⟩ := + Lean4Lean.VEnv.HasType.transfer_appN_telescope + hfutureWF hGamma hargumentLength hrecursorApplied + hrecursorCommonType hequationLhsCommonType + have hequationApplied := + Lean4Lean.VEnv.IsDefEq.appN_same hfutureWF hGamma hequation + hequationLhsApplied + have hequationRhsApplied : future.HasType uvars Gamma + (VExpr.appN ((generation.rule index normalized).rhs.instL levels) + recursorArguments) equationApplicationType := + (hequationApplied.of_l hfutureWF hGamma hequationLhsApplied).hasType.2 + + have hequationLhsApplied' : future.HasType uvars Gamma + (VExpr.appN + (VExpr.lamN + ((CertifiedSingletonGeneration.IsEnumeration.ruleBinders generation).map + (VExpr.instL levels)) + ((VExpr.app + (VExpr.appN + (.const (.str generation.block.sourceType.name "rec") + (Lean4Lean.VLevel.params 1)) + (VExpr.bvarRevRange 0 + (generation.block.ctorPairs.length + 1))) + (.const normalized.raw.name [])).instL levels)) + recursorArguments) equationApplicationType := by + have hcopy := hequationLhsApplied + rw [CertifiedSingletonGeneration.IsEnumeration.rule_lhs shape hnormalized, + VExpr.instL_lamN] at hcopy + exact hcopy + have hlhsBeta := Lean4Lean.VEnv.HasType.lamN_appN_beta + hfutureWF hGamma hargumentLength hequationLhsApplied' + rw [CertifiedSingletonGeneration.IsEnumeration.ruleLhsBody_instantiated + normalized levels recursorArguments + hlevelsLength (by simpa [hcount] using hrecursorLength)] at hlhsBeta + have hlhsBeta' : future.IsDefEqU uvars Gamma + (VExpr.appN ((generation.rule index normalized).lhs.instL levels) + recursorArguments) + (.app + (VExpr.appN + (.const (.str generation.block.sourceType.name "rec") levels) + recursorArguments) + (.const normalized.raw.name [])) := by + rw [CertifiedSingletonGeneration.IsEnumeration.rule_lhs shape hnormalized, + VExpr.instL_lamN] + exact hlhsBeta + + have hequationRhsApplied' : future.HasType uvars Gamma + (VExpr.appN + (VExpr.lamN + ((CertifiedSingletonGeneration.IsEnumeration.ruleBinders generation).map + (VExpr.instL levels)) + ((.bvar (generation.block.ctorPairs.length - 1 - index) : VExpr).instL + levels)) + recursorArguments) equationApplicationType := by + have hcopy := hequationRhsApplied + rw [CertifiedSingletonGeneration.IsEnumeration.rule_rhs shape hnormalized, + VExpr.instL_lamN] at hcopy + exact hcopy + have hrhsBeta := Lean4Lean.VEnv.HasType.lamN_appN_beta + hfutureWF hGamma hargumentLength hequationRhsApplied' + have hindexGeneration : index < generation.block.ctorPairs.length := by + simpa [hcount] using hindex + rw [CertifiedSingletonGeneration.IsEnumeration.ruleRhsBody_instantiated + index hindexGeneration levels + recursorArguments (by simpa [hcount] using hrecursorLength)] at hrhsBeta + let selected : Fin (family.constructorIds.size + 1) := + ⟨index + 1, by omega⟩ + have hselected : recursorArguments[index + 1] = + captures (RecursorIotaPattern.recursorArgumentPath + (.str generation.block.sourceType.name "rec") + (family.constructorIds.size + 1) normalized.raw.name 0 selected) := by + have hselected? := hcaptures selected + have hselectedBound : selected.val < recursorArguments.length := by + simp only [selected] + rw [hrecursorLength] + omega + rw [List.getElem?_eq_getElem hselectedBound] at hselected? + exact Option.some.inj hselected? + rw [hselected] at hrhsBeta + have hrhsBeta' : future.IsDefEqU uvars Gamma + (VExpr.appN ((generation.rule index normalized).rhs.instL levels) + recursorArguments) + (captures (RecursorIotaPattern.recursorArgumentPath + (.str generation.block.sourceType.name "rec") + (family.constructorIds.size + 1) normalized.raw.name 0 selected)) := by + rw [CertifiedSingletonGeneration.IsEnumeration.rule_rhs shape hnormalized, + VExpr.instL_lamN] + exact hrhsBeta + + have hresult := (hlhsBeta'.symm.trans hfutureWF hGamma + hequationApplied).trans hfutureWF hGamma hrhsBeta' + rw [hconstructorArguments, hconstructorLevels] at hmatched + have hmatchedExact : matched = + .app + (VExpr.appN + (.const (.str generation.block.sourceType.name "rec") levels) + recursorArguments) + (.const normalized.raw.name []) := by + simpa only [VExpr.appN] using hmatched + rw [hmatchedExact] + simpa [SingletonRecursorCatalogLink.enumerationPattern, selected, + RecursorIotaPattern.recursorArgumentRhs_apply] using hresult + +/-- Package the finite pattern metadata and its registered-equation proof as +the exact historical relation consumed by the production iota verifier. -/ +theorem enumerationPatternRel + {trProj : RawProjRel} {catalog : Catalog} + {nameOf : Address → Option Lean.Name} {trusted : KId .anon → Prop} + {source : VInductDecl} {before after : VEnv} + {tx : CertifiedGenerationTransaction source before after} + {family : SingletonFamilyCatalogLink trProj catalog nameOf trusted tx} + (link : SingletonRecursorCatalogLink trProj catalog nameOf trusted tx + family) + (shape : CertifiedSingletonGeneration.IsEnumeration + tx.certificate.generation) + {index : Nat} {rule : RecRule .anon} + (hrule : link.recursorConcrete.RecursorRuleAt index rule) : + ∃ pattern, + RawRecursorRulePatternRel after catalog nameOf link.recursorId + link.recursorConcrete rule pattern ∧ + pattern.ruleIndex = index := by + obtain ⟨hindex, normalized, hnormalized, hmetadata⟩ := + link.enumerationPatternMetadata shape hrule + let pattern := link.enumerationPattern index hindex normalized + refine ⟨pattern, RawRecursorRulePatternRel.of_metadata_sound hmetadata ?_, + rfl⟩ + exact link.enumerationPatternSound shape hrule hindex normalized hnormalized + +end SingletonRecursorCatalogLink + +end Ix.Tc diff --git a/Ix/Tc/Verify/Inductive/SingletonFamily.lean b/Ix/Tc/Verify/Inductive/SingletonFamily.lean new file mode 100644 index 000000000..96d65fcd2 --- /dev/null +++ b/Ix/Tc/Verify/Inductive/SingletonFamily.lean @@ -0,0 +1,471 @@ +import Ix.Tc.Verify.Inductive + +/-! +# Certified singleton-family admission + +This module is the first production-facing half of E2b. A Lean4Lean +`CertifiedGenerationTransaction` already owns the semantic generation of one +family, all of its constructors, its recursor, and its iota equations. What +that transaction cannot know is which anonymous Ix addresses contain the +family and constructors. + +`SingletonFamilyCatalogLink` supplies exactly that missing representation +link for the physical family block: + +* the family is the first member and the remaining members are its constructor + array in source order; +* every concrete declaration has the production singleton shape and the + exact source universe/parameter/index/field counts; +* every address resolves to the source name; and +* every stored type has the exact raw Theory translation installed by the + certified transaction. + +The structure deliberately contains no `InductiveOracle`, environment-WF, +environment-extension, constant-WF, or recursor-rule premise. Those facts +are derived below from the E2a transaction. The later checker adapter must +construct this link from ingress plus a successful production block run. +-/ + +namespace Ix.Tc + +open Lean4Lean (VConstVal VEnv VExpr VInductDecl) + +/-! ## Header facts retained by normalized generation -/ + +namespace CertifiedSingletonGeneration + +/-- The checked singleton family retains the declaration universe arity. -/ +theorem checkedTypeUvars {decl : VInductDecl} + (checked : decl.Checked) : checked.type.uvars = decl.uvars := by + rcases checked with + ⟨type, typesEq, params, paramsEq, indices, indicesEq, + resultLevel, resultEq, elimination, eliminationEq, names, namesEq, + constructors, constructorsEq, accepted⟩ + cases decl with + | mk uvars nparams types => + change types = [type] at typesEq + change VInductDecl.stage3Core ⟨uvars, nparams, types⟩ = true at accepted + rw [typesEq] at accepted + simp only [VInductDecl.stage3Core, VInductDecl.stage3DirectCore, + Bool.and_eq_true, beq_iff_eq] at accepted + change type.uvars = uvars + exact accepted.1.1.1.1.1.1 + +/-- Every checked constructor retains the declaration universe arity. -/ +theorem checkedConstructorUvars {decl : VInductDecl} + (checked : decl.Checked) {constructor : VConstVal} + (hconstructor : constructor ∈ checked.type.ctors) : + constructor.uvars = decl.uvars := by + rcases checked with + ⟨type, typesEq, params, paramsEq, indices, indicesEq, + resultLevel, resultEq, elimination, eliminationEq, names, namesEq, + constructors, constructorsEq, accepted⟩ + cases decl with + | mk uvars nparams types => + change types = [type] at typesEq + change VInductDecl.stage3Core ⟨uvars, nparams, types⟩ = true at accepted + rw [typesEq] at accepted + simp only [VInductDecl.stage3Core, VInductDecl.stage3DirectCore, + Bool.and_eq_true, beq_iff_eq, List.all_eq_true] at accepted + change constructor.uvars = uvars + exact (accepted.1.2 constructor hconstructor).1.1 + +/-- Positional header coherence transports a common constructor universe +arity from a normalized view back to the stored source constructors. -/ +theorem sourceConstructorUvarsOfHeaders + {raw view : List VConstVal} {uvars : Nat} + (hheaders : VInductDecl.sameCtorHeaders raw view = true) + (hview : ∀ constructor ∈ view, constructor.uvars = uvars) : + ∀ constructor ∈ raw, constructor.uvars = uvars := by + induction raw generalizing view with + | nil => simp + | cons first rest ih => + cases view with + | nil => simp [VInductDecl.sameCtorHeaders] at hheaders + | cons firstView restView => + simp only [VInductDecl.sameCtorHeaders, Bool.and_eq_true, + beq_iff_eq] at hheaders + intro constructor hconstructor + simp only [List.mem_cons] at hconstructor + rcases hconstructor with rfl | hconstructor + · exact hheaders.1.2.trans (hview firstView (.head _)) + · exact ih hheaders.2 + (fun candidate hcandidate => + hview candidate (.tail _ hcandidate)) + constructor hconstructor + +/-- The raw source family selected by a normalized generation has the +declaration's universe arity. -/ +theorem sourceTypeUvars {source : VInductDecl} + (generation : source.GenerationChecked) : + generation.block.sourceType.uvars = source.uvars := by + have hview := checkedTypeUvars generation.block.checked + have hshape := generation.block.normalization.shape_eq + simp only [VInductDecl.normalizationShape, Bool.and_eq_true, + beq_iff_eq] at hshape + have hheaders := hshape.2 + rw [generation.block.source_types_eq, + generation.block.checked.types_eq] at hheaders + simp only [VInductDecl.sameTypeHeaders, Bool.and_eq_true, + beq_iff_eq] at hheaders + exact hheaders.1.1.2.trans (hview.trans hshape.1.1.symm) + +/-- Every raw source constructor selected by a normalized generation has the +same universe arity. -/ +theorem sourceConstructorUvars {source : VInductDecl} + (generation : source.GenerationChecked) {constructor : VConstVal} + (hconstructor : constructor ∈ generation.block.sourceType.ctors) : + constructor.uvars = source.uvars := by + have hshape := generation.block.normalization.shape_eq + simp only [VInductDecl.normalizationShape, Bool.and_eq_true, + beq_iff_eq] at hshape + have hheaders := hshape.2 + rw [generation.block.source_types_eq, + generation.block.checked.types_eq] at hheaders + simp only [VInductDecl.sameTypeHeaders, Bool.and_eq_true, + beq_iff_eq] at hheaders + exact sourceConstructorUvarsOfHeaders hheaders.1.2 + (fun candidate hcandidate => + (checkedConstructorUvars generation.block.checked hcandidate).trans + hshape.1.1.symm) + constructor hconstructor + +end CertifiedSingletonGeneration + +/-! ## Exact supported production shapes -/ + +/-- The concrete family shape supported by the singleton E2b adapter. + +The singleton family is member zero of its physical inductive block. Its +stored parameter and index counters must agree with the raw/view generation +selected by the certificate, and its constructor array is the exact ordered +physical constructor suffix. -/ +def KConst.IsCertifiedSingletonFamily + (source : VInductDecl) (generation : source.GenerationChecked) + (constructorIds : Array (KId .anon)) : KConst .anon → Prop + | .indc (lvls := levels) (params := params) (indices := indices) + (memberIdx := memberIdx) (ctors := ctors) .. => + levels.toNat = source.uvars ∧ + params.toNat = source.nparams ∧ + indices.toNat = generation.block.rawIndices.length ∧ + memberIdx = 0 ∧ + ctors = constructorIds + | _ => False + +/-- The concrete constructor shape at one source position. + +The field count is computed from the exact raw constructor stored in the +certificate, not from an independently supplied view. -/ +def KConst.IsCertifiedSingletonConstructor + (source : VInductDecl) (familyId : KId .anon) (index : Nat) + (constructor : VConstVal) : KConst .anon → Prop + | .ctor (lvls := levels) (induct := induct) (cidx := cidx) + (params := params) (fields := fields) .. => + levels.toNat = source.uvars ∧ + induct = familyId ∧ + cidx.toNat = index ∧ + params.toNat = source.nparams ∧ + fields.toNat = + (VInductDecl.ctorFields + (VExpr.dropN source.nparams constructor.type)).length + | _ => False + +namespace KConst.IsCertifiedSingletonFamily + +theorem levels + {source : VInductDecl} {generation : source.GenerationChecked} + {constructorIds : Array (KId .anon)} {concrete : KConst .anon} + (h : concrete.IsCertifiedSingletonFamily source generation constructorIds) : + concrete.lvls.toNat = source.uvars := by + cases concrete <;> + simp_all [KConst.IsCertifiedSingletonFamily, KConst.lvls] + +theorem inductiveMember + {source : VInductDecl} {generation : source.GenerationChecked} + {constructorIds : Array (KId .anon)} {concrete : KConst .anon} + (h : concrete.IsCertifiedSingletonFamily source generation constructorIds) : + concrete.IsInductiveMember := by + cases concrete <;> + simp_all [KConst.IsCertifiedSingletonFamily, + KConst.IsInductiveMember] + +theorem noRecursorRule + {source : VInductDecl} {generation : source.GenerationChecked} + {constructorIds : Array (KId .anon)} {concrete : KConst .anon} + (h : concrete.IsCertifiedSingletonFamily source generation constructorIds) + (rule : RecRule .anon) : ¬concrete.HasRecursorRule rule := by + cases concrete <;> + simp_all [KConst.IsCertifiedSingletonFamily, KConst.HasRecursorRule] + +theorem noRecursorRuleAt + {source : VInductDecl} {generation : source.GenerationChecked} + {constructorIds : Array (KId .anon)} {concrete : KConst .anon} + (h : concrete.IsCertifiedSingletonFamily source generation constructorIds) + (index : Nat) (rule : RecRule .anon) : + ¬concrete.RecursorRuleAt index rule := by + cases concrete <;> + simp_all [KConst.IsCertifiedSingletonFamily, KConst.RecursorRuleAt] + +end KConst.IsCertifiedSingletonFamily + +namespace KConst.IsCertifiedSingletonConstructor + +theorem levels + {source : VInductDecl} {familyId : KId .anon} {index : Nat} + {constructor : VConstVal} {concrete : KConst .anon} + (h : concrete.IsCertifiedSingletonConstructor source familyId index + constructor) : + concrete.lvls.toNat = source.uvars := by + cases concrete <;> + simp_all [KConst.IsCertifiedSingletonConstructor, KConst.lvls] + +theorem inductiveMember + {source : VInductDecl} {familyId : KId .anon} {index : Nat} + {constructor : VConstVal} {concrete : KConst .anon} + (h : concrete.IsCertifiedSingletonConstructor source familyId index + constructor) : + concrete.IsInductiveMember := by + cases concrete <;> + simp_all [KConst.IsCertifiedSingletonConstructor, + KConst.IsInductiveMember] + +theorem noRecursorRule + {source : VInductDecl} {familyId : KId .anon} {index : Nat} + {constructor : VConstVal} {concrete : KConst .anon} + (h : concrete.IsCertifiedSingletonConstructor source familyId index + constructor) (rule : RecRule .anon) : + ¬concrete.HasRecursorRule rule := by + cases concrete <;> + simp_all [KConst.IsCertifiedSingletonConstructor, + KConst.HasRecursorRule] + +theorem noRecursorRuleAt + {source : VInductDecl} {familyId : KId .anon} {index : Nat} + {constructor : VConstVal} {concrete : KConst .anon} + (h : concrete.IsCertifiedSingletonConstructor source familyId index + constructor) (ruleIndex : Nat) (rule : RecRule .anon) : + ¬concrete.RecursorRuleAt ruleIndex rule := by + cases concrete <;> + simp_all [KConst.IsCertifiedSingletonConstructor, + KConst.RecursorRuleAt] + +end KConst.IsCertifiedSingletonConstructor + +/-! ## Ix/source correspondence -/ + +/-- Exact representation link between one certified singleton generation and +the production family/constructor block. + +`constructor` is indexed by the physical constructor array. Its source +lookup is therefore positional and cannot pair an Ix constructor with a +different certificate constructor having the same type. -/ +structure SingletonFamilyCatalogLink + (trProj : RawProjRel) (catalog : Catalog) + (nameOf : Address → Option Lean.Name) (trusted : KId .anon → Prop) + {source : VInductDecl} {before after : VEnv} + (tx : CertifiedGenerationTransaction source before after) where + familyId : KId .anon + constructorIds : Array (KId .anon) + constructorCount : + constructorIds.size = + tx.certificate.generation.block.sourceType.ctors.length + familyConcrete : KConst .anon + familyCatalog : catalog familyId = some familyConcrete + familyShape : familyConcrete.IsCertifiedSingletonFamily source + tx.certificate.generation constructorIds + familyName : nameOf familyId.addr = + some tx.certificate.generation.block.sourceType.name + familyType : RawExprRel after nameOf trProj [] familyConcrete.ty + tx.certificate.generation.block.sourceType.type + constructor : ∀ (index : Nat) (hindex : index < constructorIds.size), + ∃ sourceConstructor concrete, + tx.certificate.generation.block.sourceType.ctors[index]? = + some sourceConstructor ∧ + catalog constructorIds[index] = some concrete ∧ + concrete.IsCertifiedSingletonConstructor source familyId index + sourceConstructor ∧ + nameOf constructorIds[index].addr = some sourceConstructor.name ∧ + RawExprRel after nameOf trProj [] concrete.ty sourceConstructor.type + fresh : ∀ id, id ∈ (#[familyId] ++ constructorIds) → ¬trusted id + +namespace SingletonFamilyCatalogLink + +/-- The exact physical member array certified by this link. -/ +def members + {trProj : RawProjRel} {catalog : Catalog} + {nameOf : Address → Option Lean.Name} {trusted : KId .anon → Prop} + {source : VInductDecl} {before after : VEnv} + {tx : CertifiedGenerationTransaction source before after} + (link : SingletonFamilyCatalogLink trProj catalog nameOf trusted tx) : + Array (KId .anon) := + #[link.familyId] ++ link.constructorIds + +@[simp] theorem family_mem + {trProj : RawProjRel} {catalog : Catalog} + {nameOf : Address → Option Lean.Name} {trusted : KId .anon → Prop} + {source : VInductDecl} {before after : VEnv} + {tx : CertifiedGenerationTransaction source before after} + (link : SingletonFamilyCatalogLink trProj catalog nameOf trusted tx) : + link.familyId ∈ link.members := by + simp [members] + +theorem member_cases + {trProj : RawProjRel} {catalog : Catalog} + {nameOf : Address → Option Lean.Name} {trusted : KId .anon → Prop} + {source : VInductDecl} {before after : VEnv} + {tx : CertifiedGenerationTransaction source before after} + (link : SingletonFamilyCatalogLink trProj catalog nameOf trusted tx) + {id : KId .anon} (hmember : id ∈ link.members) : + id = link.familyId ∨ + ∃ (index : Nat) (hindex : index < link.constructorIds.size), + link.constructorIds[index] = id := by + simp only [members, Array.mem_append, Array.mem_singleton] at hmember + rcases hmember with rfl | hconstructor + · exact .inl rfl + · exact .inr (Array.mem_iff_getElem.mp hconstructor) + +/-- Every linked member has the exact raw inductive translation and installed +Theory constant required by `InductiveOracle.translateBlock`. Constant WF is +derived from the certified post-environment rather than stored in the link. -/ +theorem translateMember + {trProj : RawProjRel} {catalog : Catalog} + {nameOf : Address → Option Lean.Name} {trusted : KId .anon → Prop} + {source : VInductDecl} {before after : VEnv} + {tx : CertifiedGenerationTransaction source before after} + (link : SingletonFamilyCatalogLink trProj catalog nameOf trusted tx) + {id : KId .anon} (hmember : id ∈ link.members) : + ∃ concrete name ci, + catalog id = some concrete ∧ + RawInductiveConstRel after nameOf trProj id concrete name ci ∧ + after.constants name = some ci ∧ + ci.WF after := by + have facts := tx.facts + rcases link.member_cases hmember with rfl | ⟨index, hindex, hget⟩ + · refine ⟨link.familyConcrete, + tx.certificate.generation.block.sourceType.name, + tx.certificate.generation.block.sourceType.toVConstant, + link.familyCatalog, ?_, facts.familyLookup, ?_⟩ + · exact { + kind := KConst.IsCertifiedSingletonFamily.inductiveMember + link.familyShape + nameEq := link.familyName + uvars := (KConst.IsCertifiedSingletonFamily.levels + link.familyShape).trans + (CertifiedSingletonGeneration.sourceTypeUvars + tx.certificate.generation).symm + type := link.familyType } + · exact facts.afterWF.ordered.constWF facts.familyLookup + · obtain ⟨sourceConstructor, concrete, hsource, hcatalog, hshape, + hname, htype⟩ := link.constructor index hindex + subst id + have hsourceMem : sourceConstructor ∈ + tx.certificate.generation.block.sourceType.ctors := + List.mem_of_getElem? hsource + refine ⟨concrete, sourceConstructor.name, sourceConstructor.toVConstant, + hcatalog, ?_, facts.ctorLookup hsourceMem, ?_⟩ + · exact { + kind := KConst.IsCertifiedSingletonConstructor.inductiveMember hshape + nameEq := hname + uvars := (KConst.IsCertifiedSingletonConstructor.levels hshape).trans + (CertifiedSingletonGeneration.sourceConstructorUvars + tx.certificate.generation hsourceMem).symm + type := htype } + · exact facts.afterWF.ordered.constWF + (facts.ctorLookup hsourceMem) + +/-- No family-block member can carry a concrete recursor rule. This closes +the rule clauses of the family admission by contradiction rather than by an +unrelated rule oracle. -/ +theorem noRecursorRule + {trProj : RawProjRel} {catalog : Catalog} + {nameOf : Address → Option Lean.Name} {trusted : KId .anon → Prop} + {source : VInductDecl} {before after : VEnv} + {tx : CertifiedGenerationTransaction source before after} + (link : SingletonFamilyCatalogLink trProj catalog nameOf trusted tx) + {id : KId .anon} (hmember : id ∈ link.members) + {concrete : KConst .anon} (hcatalog : catalog id = some concrete) + (rule : RecRule .anon) : ¬concrete.HasRecursorRule rule := by + rcases link.member_cases hmember with rfl | ⟨index, hindex, hget⟩ + · have hconcrete : concrete = link.familyConcrete := by + rw [link.familyCatalog] at hcatalog + exact Option.some.inj hcatalog.symm + subst concrete + exact link.familyShape.noRecursorRule rule + · obtain ⟨sourceConstructor, linked, _, hlinked, hshape, _⟩ := + link.constructor index hindex + rw [hget] at hlinked + have hconcrete : concrete = linked := by + rw [hlinked] at hcatalog + exact Option.some.inj hcatalog.symm + subst concrete + exact hshape.noRecursorRule rule + +theorem noRecursorRuleAt + {trProj : RawProjRel} {catalog : Catalog} + {nameOf : Address → Option Lean.Name} {trusted : KId .anon → Prop} + {source : VInductDecl} {before after : VEnv} + {tx : CertifiedGenerationTransaction source before after} + (link : SingletonFamilyCatalogLink trProj catalog nameOf trusted tx) + {id : KId .anon} (hmember : id ∈ link.members) + {concrete : KConst .anon} (hcatalog : catalog id = some concrete) + (ruleIndex : Nat) (rule : RecRule .anon) : + ¬concrete.RecursorRuleAt ruleIndex rule := by + rcases link.member_cases hmember with rfl | ⟨index, hindex, hget⟩ + · have hconcrete : concrete = link.familyConcrete := by + rw [link.familyCatalog] at hcatalog + exact Option.some.inj hcatalog.symm + subst concrete + exact link.familyShape.noRecursorRuleAt ruleIndex rule + · obtain ⟨sourceConstructor, linked, _, hlinked, hshape, _⟩ := + link.constructor index hindex + rw [hget] at hlinked + have hconcrete : concrete = linked := by + rw [hlinked] at hcatalog + exact Option.some.inj hcatalog.symm + subst concrete + exact hshape.noRecursorRuleAt ruleIndex rule + +/-- Construct the complete family-block oracle from the exact Ix/source link +and E2a's certified transaction. The recursor clauses are vacuous for this +physical block because it contains only the family and its constructors. -/ +def oracle + {trProj : RawProjRel} {catalog : Catalog} + {nameOf : Address → Option Lean.Name} {trusted : KId .anon → Prop} + {source : VInductDecl} {before after : VEnv} + {tx : CertifiedGenerationTransaction source before after} + (link : SingletonFamilyCatalogLink trProj catalog nameOf trusted tx) : + InductiveOracle trProj catalog nameOf trusted before where + members := fun id => id ∈ link.members + nonempty := ⟨link.familyId, link.family_mem⟩ + fresh := by + intro id hmember + exact link.fresh id hmember + after := after + envLE := tx.facts.envLE + blockWF := tx.facts.afterWF + translateBlock := by + intro id hmember + exact link.translateMember hmember + recursorFacts := by + intro id concrete rule hmember hcatalog hrule + exact False.elim (link.noRecursorRule hmember hcatalog rule hrule) + recursorPatterns := by + intro id concrete ruleIndex rule hmember hcatalog hrule + exact False.elim + (link.noRecursorRuleAt hmember hcatalog ruleIndex rule hrule) + +@[simp] theorem oracle_members_iff + {trProj : RawProjRel} {catalog : Catalog} + {nameOf : Address → Option Lean.Name} {trusted : KId .anon → Prop} + {source : VInductDecl} {before after : VEnv} + {tx : CertifiedGenerationTransaction source before after} + (link : SingletonFamilyCatalogLink trProj catalog nameOf trusted tx) + (id : KId .anon) : + link.oracle.members id ↔ id ∈ link.members := + by + change (id ∈ link.members) ↔ id ∈ link.members + exact Iff.rfl + +end SingletonFamilyCatalogLink + +end Ix.Tc diff --git a/Ix/Tc/Verify/Inductive/SingletonIngress.lean b/Ix/Tc/Verify/Inductive/SingletonIngress.lean new file mode 100644 index 000000000..0ac9b5433 --- /dev/null +++ b/Ix/Tc/Verify/Inductive/SingletonIngress.lean @@ -0,0 +1,313 @@ +import Ix.Tc.Verify.Inductive.SingletonRecursor +import Ix.Tc.Verify.Env + +/-! +# Loaded singleton-inductive ingress correspondence + +Anonymous ingress and the production checker operate on concrete `KEnv` +entries. The semantic singleton adapters, by contrast, consume immutable +catalog entries. This module makes that boundary explicit without assigning +semantic authority to loading: + +* `SingletonFamilyIngressView` records the exact family and constructor + entries present in one concrete environment, together with the ghost + interpretation of their anonymous expressions and addresses; +* `SingletonRecursorIngressView` does the same for the separate physical + recursor block; and +* `toCatalogLink` transports those representation facts through + `LoadedAgrees` and derives pre-admission freshness from the trusted log and + the Lean4Lean generation transaction. + +The views contain no catalog lookup, trusted-membership negation, declaration +WF, or checker-success premise. In particular, an anonymous `KEnv` entry +cannot manufacture its source `Lean.Name`; that interpretation remains +deliberate ghost input and will be constructed from the corresponding Ixon +ingress trace. +-/ + +namespace Ix.Tc + +open Lean4Lean (VConstVal VEnv VInductDecl) + +/-! ## Family and constructor ingress -/ + +/-- Exact representation evidence for the singleton family and constructor +entries loaded by anonymous ingress. + +The physical address order is retained, and each source constructor is paired +positionally. Catalog agreement and semantic freshness are intentionally +absent: both are consequences of the surrounding checker state and certified +Theory transaction. -/ +structure SingletonFamilyIngressView + (trProj : RawProjRel) (env : KEnv .anon) + (nameOf : Address → Option Lean.Name) + {source : VInductDecl} {before after : VEnv} + (tx : CertifiedGenerationTransaction source before after) where + familyId : KId .anon + constructorIds : Array (KId .anon) + constructorCount : + constructorIds.size = + tx.certificate.generation.block.sourceType.ctors.length + familyConcrete : KConst .anon + familyLoaded : env.get? familyId = some familyConcrete + familyShape : familyConcrete.IsCertifiedSingletonFamily source + tx.certificate.generation constructorIds + familyName : nameOf familyId.addr = + some tx.certificate.generation.block.sourceType.name + familyType : RawExprRel after nameOf trProj [] familyConcrete.ty + tx.certificate.generation.block.sourceType.type + constructor : ∀ (index : Nat) (hindex : index < constructorIds.size), + ∃ sourceConstructor concrete, + tx.certificate.generation.block.sourceType.ctors[index]? = + some sourceConstructor ∧ + env.get? constructorIds[index] = some concrete ∧ + concrete.IsCertifiedSingletonConstructor source familyId index + sourceConstructor ∧ + nameOf constructorIds[index].addr = some sourceConstructor.name ∧ + RawExprRel after nameOf trProj [] concrete.ty sourceConstructor.type + +namespace SingletonFamilyIngressView + +/-- The exact physical member array described by a loaded family view. -/ +def members + {trProj : RawProjRel} {env : KEnv .anon} + {nameOf : Address → Option Lean.Name} + {source : VInductDecl} {before after : VEnv} + {tx : CertifiedGenerationTransaction source before after} + (view : SingletonFamilyIngressView trProj env nameOf tx) : + Array (KId .anon) := + #[view.familyId] ++ view.constructorIds + +@[simp] theorem family_mem + {trProj : RawProjRel} {env : KEnv .anon} + {nameOf : Address → Option Lean.Name} + {source : VInductDecl} {before after : VEnv} + {tx : CertifiedGenerationTransaction source before after} + (view : SingletonFamilyIngressView trProj env nameOf tx) : + view.familyId ∈ view.members := by + simp [members] + +/-- Split membership into the leading family or one exact constructor +position. -/ +theorem member_cases + {trProj : RawProjRel} {env : KEnv .anon} + {nameOf : Address → Option Lean.Name} + {source : VInductDecl} {before after : VEnv} + {tx : CertifiedGenerationTransaction source before after} + (view : SingletonFamilyIngressView trProj env nameOf tx) + {id : KId .anon} (hmember : id ∈ view.members) : + id = view.familyId ∨ + ∃ (index : Nat) (hindex : index < view.constructorIds.size), + view.constructorIds[index] = id := by + simp only [members, Array.mem_append, Array.mem_singleton] at hmember + rcases hmember with rfl | hconstructor + · exact .inl rfl + · exact .inr (Array.mem_iff_getElem.mp hconstructor) + +/-- The family address cannot already be trusted in the transaction's input +world. Otherwise trusted provenance and the ingress name assignment would +produce the exact Theory lookup which the generation trace proves absent. -/ +theorem familyFresh + {trProj : RawProjRel} {env : KEnv .anon} + {world : VerifyWorld} {source : VInductDecl} {after : VEnv} + {tx : CertifiedGenerationTransaction source world.venv after} + (view : SingletonFamilyIngressView trProj env world.nameOf tx) + (trustedCatalog : TrustedCatalogRel trProj world) : + ¬world.trusted view.familyId := by + intro htrusted + obtain ⟨_, name, ci, _, hname, hlookup⟩ := + trustedCatalog.lookup htrusted + have hnameEq : + name = tx.certificate.generation.block.sourceType.name := + Option.some.inj (hname.symm.trans view.familyName) + subst name + have hcollision : + (none : Option Lean4Lean.VConstant) = some ci := + tx.facts.familyFresh.symm.trans hlookup + cases hcollision + +/-- Every constructor address is likewise fresh. Positional source lookup +is essential here: it selects the precise constructor freshness fact emitted +by the certified transaction. -/ +theorem constructorFresh + {trProj : RawProjRel} {env : KEnv .anon} + {world : VerifyWorld} {source : VInductDecl} {after : VEnv} + {tx : CertifiedGenerationTransaction source world.venv after} + (view : SingletonFamilyIngressView trProj env world.nameOf tx) + (trustedCatalog : TrustedCatalogRel trProj world) + (index : Nat) (hindex : index < view.constructorIds.size) : + ¬world.trusted view.constructorIds[index] := by + obtain ⟨sourceConstructor, concrete, hsource, _, _, hsourceName, _⟩ := + view.constructor index hindex + intro htrusted + obtain ⟨_, name, ci, _, hname, hlookup⟩ := + trustedCatalog.lookup htrusted + have hnameEq : name = sourceConstructor.name := + Option.some.inj (hname.symm.trans hsourceName) + subst name + have hsourceMem : sourceConstructor ∈ + tx.certificate.generation.block.sourceType.ctors := + List.mem_of_getElem? hsource + have hcollision : + (none : Option Lean4Lean.VConstant) = some ci := + (tx.facts.ctorFresh hsourceMem).symm.trans hlookup + cases hcollision + +/-- Transport actual loaded entries to the immutable catalog and assemble +the semantic family link. The only semantic input is the trusted log already +carried by the checker-state invariant. -/ +def toCatalogLink + {trProj : RawProjRel} {env : KEnv .anon} + {world : VerifyWorld} {source : VInductDecl} {after : VEnv} + {tx : CertifiedGenerationTransaction source world.venv after} + (view : SingletonFamilyIngressView trProj env world.nameOf tx) + (loaded : LoadedAgrees world.catalog env) + (trustedCatalog : TrustedCatalogRel trProj world) : + SingletonFamilyCatalogLink trProj world.catalog world.nameOf + world.trusted tx where + familyId := view.familyId + constructorIds := view.constructorIds + constructorCount := view.constructorCount + familyConcrete := view.familyConcrete + familyCatalog := loaded view.familyLoaded + familyShape := view.familyShape + familyName := view.familyName + familyType := view.familyType + constructor := by + intro index hindex + obtain ⟨sourceConstructor, concrete, hsource, hloaded, hshape, + hname, htype⟩ := view.constructor index hindex + exact ⟨sourceConstructor, concrete, hsource, loaded hloaded, + hshape, hname, htype⟩ + fresh := by + intro id hmember + have hviewMember : id ∈ view.members := by + simpa only [members] using hmember + rcases view.member_cases hviewMember with rfl | ⟨index, hindex, hid⟩ + · exact view.familyFresh trustedCatalog + · subst id + exact view.constructorFresh trustedCatalog index hindex + +@[simp] theorem toCatalogLink_members + {trProj : RawProjRel} {env : KEnv .anon} + {world : VerifyWorld} {source : VInductDecl} {after : VEnv} + {tx : CertifiedGenerationTransaction source world.venv after} + (view : SingletonFamilyIngressView trProj env world.nameOf tx) + (loaded : LoadedAgrees world.catalog env) + (trustedCatalog : TrustedCatalogRel trProj world) : + (view.toCatalogLink loaded trustedCatalog).members = view.members := rfl + +end SingletonFamilyIngressView + +/-! ## Recursor ingress -/ + +/-- Exact representation evidence for the separate singleton recursor entry +loaded by anonymous ingress. + +The family link is the semantic result of the preceding physical family +block. This view adds only facts about the recursor entry loaded in `env`; +in particular, it does not assume that the recursor id is untrusted. -/ +structure SingletonRecursorIngressView + (trProj : RawProjRel) (env : KEnv .anon) + (nameOf : Address → Option Lean.Name) + {source : VInductDecl} {before after : VEnv} + (tx : CertifiedGenerationTransaction source before after) + {trusted : KId .anon → Prop} {catalog : Catalog} + (family : SingletonFamilyCatalogLink trProj catalog nameOf trusted tx) where + recursorId : KId .anon + recursorConcrete : KConst .anon + recursorLoaded : env.get? recursorId = some recursorConcrete + recursorShape : recursorConcrete.IsCertifiedSingletonRecursor source + tx.certificate.generation family.constructorIds + recursorName : nameOf recursorId.addr = + some (.str tx.certificate.generation.block.sourceType.name "rec") + recursorType : RawExprRel after nameOf trProj [] recursorConcrete.ty + tx.certificate.generation.recursor.type + rule : ∀ (index : Nat) (_hindex : index < family.constructorIds.size), + ∃ concreteRule normalizedConstructor, + recursorConcrete.RecursorRuleAt index concreteRule ∧ + tx.certificate.generation.block.ctorPairs[index]? = + some normalizedConstructor ∧ + concreteRule.fields.toNat = + (normalizedConstructor.fieldsR source.uvars source.nparams).length ∧ + RawExprRel after nameOf trProj [] concreteRule.rhs + (tx.certificate.generation.rule index normalizedConstructor).rhs ∧ + TrKExprS after + (tx.certificate.generation.rule index normalizedConstructor).uvars + nameOf trProj [] concreteRule.rhs + (tx.certificate.generation.rule index normalizedConstructor).rhs + +namespace SingletonRecursorIngressView + +/-- The separate physical recursor block contains exactly its one loaded +recursor declaration. -/ +def members + {trProj : RawProjRel} {env : KEnv .anon} + {nameOf : Address → Option Lean.Name} + {source : VInductDecl} {before after : VEnv} + {tx : CertifiedGenerationTransaction source before after} + {trusted : KId .anon → Prop} {catalog : Catalog} + {family : SingletonFamilyCatalogLink trProj catalog nameOf trusted tx} + (view : SingletonRecursorIngressView trProj env nameOf tx family) : + Array (KId .anon) := + #[view.recursorId] + +@[simp] theorem recursor_mem + {trProj : RawProjRel} {env : KEnv .anon} + {nameOf : Address → Option Lean.Name} + {source : VInductDecl} {before after : VEnv} + {tx : CertifiedGenerationTransaction source before after} + {trusted : KId .anon → Prop} {catalog : Catalog} + {family : SingletonFamilyCatalogLink trProj catalog nameOf trusted tx} + (view : SingletonRecursorIngressView trProj env nameOf tx family) : + view.recursorId ∈ view.members := by + simp [members] + +/-- Trusted provenance for the same anonymous address would contradict the +certified transaction's absent pre-state recursor lookup. -/ +theorem recursorFresh + {trProj : RawProjRel} {env : KEnv .anon} + {world : VerifyWorld} {source : VInductDecl} {after : VEnv} + {tx : CertifiedGenerationTransaction source world.venv after} + {family : SingletonFamilyCatalogLink trProj world.catalog world.nameOf + world.trusted tx} + (view : SingletonRecursorIngressView trProj env world.nameOf tx family) + (trustedCatalog : TrustedCatalogRel trProj world) : + ¬world.trusted view.recursorId := by + intro htrusted + obtain ⟨_, name, ci, _, hname, hlookup⟩ := + trustedCatalog.lookup htrusted + have hnameEq : name = + .str tx.certificate.generation.block.sourceType.name "rec" := + Option.some.inj (hname.symm.trans view.recursorName) + subst name + have hcollision : + (none : Option Lean4Lean.VConstant) = some ci := + tx.facts.recursorFresh.symm.trans hlookup + cases hcollision + +/-- Transport the actually loaded recursor entry to its immutable catalog +entry and assemble the positional recursor/rule link. -/ +def toCatalogLink + {trProj : RawProjRel} {env : KEnv .anon} + {world : VerifyWorld} {source : VInductDecl} {after : VEnv} + {tx : CertifiedGenerationTransaction source world.venv after} + {family : SingletonFamilyCatalogLink trProj world.catalog world.nameOf + world.trusted tx} + (view : SingletonRecursorIngressView trProj env world.nameOf tx family) + (loaded : LoadedAgrees world.catalog env) + (trustedCatalog : TrustedCatalogRel trProj world) : + SingletonRecursorCatalogLink trProj world.catalog world.nameOf + world.trusted tx family where + recursorId := view.recursorId + recursorConcrete := view.recursorConcrete + recursorCatalog := loaded view.recursorLoaded + recursorShape := view.recursorShape + recursorName := view.recursorName + recursorType := view.recursorType + rule := view.rule + fresh := view.recursorFresh trustedCatalog + +end SingletonRecursorIngressView + +end Ix.Tc diff --git a/Ix/Tc/Verify/Inductive/SingletonOracle.lean b/Ix/Tc/Verify/Inductive/SingletonOracle.lean new file mode 100644 index 000000000..dab75e142 --- /dev/null +++ b/Ix/Tc/Verify/Inductive/SingletonOracle.lean @@ -0,0 +1,121 @@ +import Ix.Tc.Verify.Inductive.SingletonEnumeration + +/-! +# Certificate-backed singleton recursor oracle + +The family/constructor and recursor declarations are separate physical Ix +blocks. `SingletonFamilyCatalogLink.oracle` closes the former. This module +closes the latter for the executable enumeration fragment, using the exact +generated equations and pattern-soundness theorem rather than an ambient +reflection premise. +-/ + +namespace Ix.Tc + +open Lean4Lean (VEnv VInductDecl) + +namespace SingletonRecursorCatalogLink + +/-- The exact physical member array of the singleton recursor block. -/ +def members + {trProj : RawProjRel} {catalog : Catalog} + {nameOf : Address → Option Lean.Name} {trusted : KId .anon → Prop} + {source : VInductDecl} {before after : VEnv} + {tx : CertifiedGenerationTransaction source before after} + {family : SingletonFamilyCatalogLink trProj catalog nameOf trusted tx} + (link : SingletonRecursorCatalogLink trProj catalog nameOf trusted tx + family) : Array (KId .anon) := + #[link.recursorId] + +@[simp] theorem recursor_mem + {trProj : RawProjRel} {catalog : Catalog} + {nameOf : Address → Option Lean.Name} {trusted : KId .anon → Prop} + {source : VInductDecl} {before after : VEnv} + {tx : CertifiedGenerationTransaction source before after} + {family : SingletonFamilyCatalogLink trProj catalog nameOf trusted tx} + (link : SingletonRecursorCatalogLink trProj catalog nameOf trusted tx + family) : link.recursorId ∈ link.members := by + simp [members] + +/-- Membership in the recursor block identifies its sole declaration. -/ +theorem member_eq + {trProj : RawProjRel} {catalog : Catalog} + {nameOf : Address → Option Lean.Name} {trusted : KId .anon → Prop} + {source : VInductDecl} {before after : VEnv} + {tx : CertifiedGenerationTransaction source before after} + {family : SingletonFamilyCatalogLink trProj catalog nameOf trusted tx} + (link : SingletonRecursorCatalogLink trProj catalog nameOf trusted tx + family) + {id : KId .anon} (hmember : id ∈ link.members) : + id = link.recursorId := by + simpa [members] using hmember + +/-- Construct a complete `InductiveOracle` for the actual singleton recursor +block. Every rule and pattern is selected by its concrete array position and +is justified by the equation installed by the E2a transaction. -/ +def oracle + {trProj : RawProjRel} {catalog : Catalog} + {nameOf : Address → Option Lean.Name} {trusted : KId .anon → Prop} + {source : VInductDecl} {before after : VEnv} + {tx : CertifiedGenerationTransaction source before after} + {family : SingletonFamilyCatalogLink trProj catalog nameOf trusted tx} + (link : SingletonRecursorCatalogLink trProj catalog nameOf trusted tx + family) + (shape : CertifiedSingletonGeneration.IsEnumeration + tx.certificate.generation) : + InductiveOracle trProj catalog nameOf trusted before where + members := fun id => id ∈ link.members + nonempty := ⟨link.recursorId, link.recursor_mem⟩ + fresh := by + intro id hmember + rw [link.member_eq hmember] + exact link.fresh + after := after + envLE := tx.facts.envLE + blockWF := tx.facts.afterWF + translateBlock := by + intro id hmember + have hid := link.member_eq hmember + subst id + obtain ⟨hraw, hlookup, hwf⟩ := link.translateRecursor + exact ⟨link.recursorConcrete, + .str tx.certificate.generation.block.sourceType.name "rec", + tx.certificate.generation.recursor, + link.recursorCatalog, hraw, hlookup, hwf⟩ + recursorFacts := by + intro id concrete rule hmember hcatalog hrule + have hid := link.member_eq hmember + subst id + have hconcrete : concrete = link.recursorConcrete := by + rw [link.recursorCatalog] at hcatalog + exact Option.some.inj hcatalog.symm + subst concrete + exact link.registeredRule hrule + recursorPatterns := by + intro id concrete ruleIndex rule hmember hcatalog hrule + have hid := link.member_eq hmember + subst id + have hconcrete : concrete = link.recursorConcrete := by + rw [link.recursorCatalog] at hcatalog + exact Option.some.inj hcatalog.symm + subst concrete + exact link.enumerationPatternRel shape hrule + +@[simp] theorem oracle_members_iff + {trProj : RawProjRel} {catalog : Catalog} + {nameOf : Address → Option Lean.Name} {trusted : KId .anon → Prop} + {source : VInductDecl} {before after : VEnv} + {tx : CertifiedGenerationTransaction source before after} + {family : SingletonFamilyCatalogLink trProj catalog nameOf trusted tx} + (link : SingletonRecursorCatalogLink trProj catalog nameOf trusted tx + family) + (shape : CertifiedSingletonGeneration.IsEnumeration + tx.certificate.generation) + (id : KId .anon) : + (link.oracle shape).members id ↔ id ∈ link.members := by + change (id ∈ link.members) ↔ id ∈ link.members + exact Iff.rfl + +end SingletonRecursorCatalogLink + +end Ix.Tc diff --git a/Ix/Tc/Verify/Inductive/SingletonRecursor.lean b/Ix/Tc/Verify/Inductive/SingletonRecursor.lean new file mode 100644 index 000000000..03f238c85 --- /dev/null +++ b/Ix/Tc/Verify/Inductive/SingletonRecursor.lean @@ -0,0 +1,302 @@ +import Ix.Tc.Verify.Inductive.SingletonFamily + +/-! +# Certified singleton-recursor correspondence + +The Lean4Lean transaction used by E2a installs a singleton family's recursor +and all of its iota equations atomically with the family. Anonymous Ix +ingress does not: the family/constructor block and the recursor block are +distinct physical blocks. This module links the latter block to the exact +artifacts already installed by the transaction. + +The link is deliberately positional. Rule `i` is paired with normalized +constructor `i`, the generated equation at `i`, and the stored constructor at +`i`; an existential search by equal RHS is never sufficient. Pattern +compilation is kept for the next module because it has an additional semantic +obligation beyond raw/structural translation. +-/ + +namespace Ix.Tc + +open Lean4Lean (VConstVal VDefEq VEnv VExpr VInductDecl) + +namespace CertifiedSingletonGeneration + +/-- The generated rule array is positionally the map over `ctorPairs.zipIdx`. +This small theorem prevents later adapters from selecting an arbitrary +registered equation with an equal body. -/ +theorem generatedRuleAt {source : VInductDecl} + (generation : source.GenerationChecked) {index : Nat} + {constructor : VInductDecl.NormalizedCtor} + (hconstructor : generation.block.ctorPairs[index]? = some constructor) : + generation.generatedRules[index]? = + some (generation.rule index constructor) := by + unfold VInductDecl.GenerationChecked.generatedRules + simp only [List.getElem?_map] + rw [List.getElem?_zipIdx] + simp [hconstructor] + +/-- Positional pairing retains the raw source constructor at the same index. -/ +theorem rawConstructorAt {source : VInductDecl} + (generation : source.GenerationChecked) {index : Nat} + {constructor : VInductDecl.NormalizedCtor} + (hconstructor : generation.block.ctorPairs[index]? = some constructor) : + generation.block.sourceType.ctors[index]? = some constructor.raw := by + have hmapped : + (generation.block.ctorPairs.map (·.raw))[index]? = + some constructor.raw := by + rw [List.getElem?_map, hconstructor] + rfl + rw [generation.rawCtors_eq] at hmapped + exact hmapped + +/-- A generated iota equation is recursor-headed below its closed rule +telescope. This is the shape actually emitted by Lean4Lean; its outer node +is never directly a constant-headed application when the telescope is +nonempty. -/ +theorem generatedRuleHead {source : VInductDecl} + (generation : source.GenerationChecked) (index : Nat) + (constructor : VInductDecl.NormalizedCtor) : + HeadConstUnderLambdas + (.str generation.block.sourceType.name "rec") + (generation.rule index constructor).lhs := by + unfold VInductDecl.GenerationChecked.rule + apply HeadConstUnderLambdas.lamN + apply HeadConst.appN + apply HeadConst.appN + exact .const _ + +end CertifiedSingletonGeneration + +/-! ## Exact supported recursor shape -/ + +/-- Concrete recursor metadata supported by E2b's singleton adapter. + +`motives = 1` is the explicit no-mutual/no-nested boundary of this adapter. +The exact rule count is retained, and `RecursorMajorIdxCoherent` rules out the +wrapping-`UInt64` disagreement between production's ordinary iota path and +its Nat descriptor path. -/ +def KConst.IsCertifiedSingletonRecursor + (source : VInductDecl) (generation : source.GenerationChecked) + (constructorIds : Array (KId .anon)) : KConst .anon → Prop + | concrete@(.recr (lvls := levels) (params := params) + (indices := indices) (motives := motives) (minors := minors) + (memberIdx := memberIdx) (rules := rules) ..) => + levels.toNat = source.uvars + 1 ∧ + params.toNat = source.nparams ∧ + indices.toNat = generation.block.rawIndices.length ∧ + motives.toNat = 1 ∧ + minors.toNat = constructorIds.size ∧ + memberIdx = 0 ∧ + rules.size = constructorIds.size ∧ + concrete.RecursorMajorIdxCoherent + | _ => False + +namespace KConst.IsCertifiedSingletonRecursor + +theorem inductiveMember + {source : VInductDecl} {generation : source.GenerationChecked} + {constructorIds : Array (KId .anon)} {concrete : KConst .anon} + (h : concrete.IsCertifiedSingletonRecursor source generation + constructorIds) : concrete.IsInductiveMember := by + cases concrete <;> + simp_all [KConst.IsCertifiedSingletonRecursor, + KConst.IsInductiveMember] + +theorem levels + {source : VInductDecl} {generation : source.GenerationChecked} + {constructorIds : Array (KId .anon)} {concrete : KConst .anon} + (h : concrete.IsCertifiedSingletonRecursor source generation + constructorIds) : + concrete.lvls.toNat = generation.recursor.uvars := by + cases concrete <;> + simp_all [KConst.IsCertifiedSingletonRecursor, KConst.lvls, + VInductDecl.GenerationChecked.recursor] + +theorem coherent + {source : VInductDecl} {generation : source.GenerationChecked} + {constructorIds : Array (KId .anon)} {concrete : KConst .anon} + (h : concrete.IsCertifiedSingletonRecursor source generation + constructorIds) : concrete.RecursorMajorIdxCoherent := by + cases concrete <;> + simp only [KConst.IsCertifiedSingletonRecursor] at h + exact h.2.2.2.2.2.2.2 + +theorem ruleCount + {source : VInductDecl} {generation : source.GenerationChecked} + {constructorIds : Array (KId .anon)} {concrete : KConst .anon} + (h : concrete.IsCertifiedSingletonRecursor source generation + constructorIds) : + ∀ {index : Nat} {rule : RecRule .anon}, + concrete.RecursorRuleAt index rule → index < constructorIds.size := by + cases concrete with + | recr name levelParams k isUnsafe levels params indices motives minors + block memberIdx type rules leanAll => + simp only [KConst.IsCertifiedSingletonRecursor] at h + intro index rule hrule + change rules[index]? = some rule at hrule + have hlt : index < rules.size := + (Array.getElem?_eq_some_iff.mp hrule).choose + simpa only [h.2.2.2.2.2.2.1] using hlt + | _ => simp [KConst.IsCertifiedSingletonRecursor] at h + +end KConst.IsCertifiedSingletonRecursor + +/-! ## Exact recursor/rule correspondence -/ + +/-- Positional correspondence between the one physical Ix recursor block and +the recursor/equations already installed by an E2a transaction. + +The structure contains representation facts only. Registration, equation +WF, recursor WF, and recursor-headedness are derived from the transaction and +the generator definition below. -/ +structure SingletonRecursorCatalogLink + (trProj : RawProjRel) (catalog : Catalog) + (nameOf : Address → Option Lean.Name) (trusted : KId .anon → Prop) + {source : VInductDecl} {before after : VEnv} + (tx : CertifiedGenerationTransaction source before after) + (family : SingletonFamilyCatalogLink trProj catalog nameOf trusted tx) where + recursorId : KId .anon + recursorConcrete : KConst .anon + recursorCatalog : catalog recursorId = some recursorConcrete + recursorShape : recursorConcrete.IsCertifiedSingletonRecursor source + tx.certificate.generation family.constructorIds + recursorName : nameOf recursorId.addr = + some (.str tx.certificate.generation.block.sourceType.name "rec") + recursorType : RawExprRel after nameOf trProj [] recursorConcrete.ty + tx.certificate.generation.recursor.type + rule : ∀ (index : Nat) (_hindex : index < family.constructorIds.size), + ∃ concreteRule normalizedConstructor, + recursorConcrete.RecursorRuleAt index concreteRule ∧ + tx.certificate.generation.block.ctorPairs[index]? = + some normalizedConstructor ∧ + concreteRule.fields.toNat = + (normalizedConstructor.fieldsR source.uvars source.nparams).length ∧ + RawExprRel after nameOf trProj [] concreteRule.rhs + (tx.certificate.generation.rule index normalizedConstructor).rhs ∧ + TrKExprS after + (tx.certificate.generation.rule index normalizedConstructor).uvars + nameOf trProj [] concreteRule.rhs + (tx.certificate.generation.rule index normalizedConstructor).rhs + fresh : ¬trusted recursorId + +namespace SingletonRecursorCatalogLink + +/-- The recursor's exact raw translation and certified post-environment +lookup. -/ +theorem translateRecursor + {trProj : RawProjRel} {catalog : Catalog} + {nameOf : Address → Option Lean.Name} {trusted : KId .anon → Prop} + {source : VInductDecl} {before after : VEnv} + {tx : CertifiedGenerationTransaction source before after} + {family : SingletonFamilyCatalogLink trProj catalog nameOf trusted tx} + (link : SingletonRecursorCatalogLink trProj catalog nameOf trusted tx + family) : + RawInductiveConstRel after nameOf trProj link.recursorId + link.recursorConcrete + (.str tx.certificate.generation.block.sourceType.name "rec") + tx.certificate.generation.recursor ∧ + after.constants + (.str tx.certificate.generation.block.sourceType.name "rec") = + some tx.certificate.generation.recursor ∧ + tx.certificate.generation.recursor.WF after := by + have facts := tx.facts + refine ⟨?_, facts.recursorLookup, + facts.afterWF.ordered.constWF facts.recursorLookup⟩ + exact { + kind := link.recursorShape.inductiveMember + nameEq := link.recursorName + uvars := link.recursorShape.levels + type := link.recursorType } + +/-- Select the exact normalized constructor and generated equation paired +with a concrete rule at the requested array index. -/ +theorem ruleAt + {trProj : RawProjRel} {catalog : Catalog} + {nameOf : Address → Option Lean.Name} {trusted : KId .anon → Prop} + {source : VInductDecl} {before after : VEnv} + {tx : CertifiedGenerationTransaction source before after} + {family : SingletonFamilyCatalogLink trProj catalog nameOf trusted tx} + (link : SingletonRecursorCatalogLink trProj catalog nameOf trusted tx + family) + {index : Nat} {concreteRule : RecRule .anon} + (hrule : link.recursorConcrete.RecursorRuleAt index concreteRule) : + ∃ normalizedConstructor, + tx.certificate.generation.block.ctorPairs[index]? = + some normalizedConstructor ∧ + tx.certificate.generation.generatedRules[index]? = + some (tx.certificate.generation.rule index normalizedConstructor) ∧ + concreteRule.fields.toNat = + (normalizedConstructor.fieldsR source.uvars source.nparams).length ∧ + RawExprRel after nameOf trProj [] concreteRule.rhs + (tx.certificate.generation.rule index normalizedConstructor).rhs ∧ + TrKExprS after + (tx.certificate.generation.rule index normalizedConstructor).uvars + nameOf trProj [] concreteRule.rhs + (tx.certificate.generation.rule index normalizedConstructor).rhs := by + have hindex := link.recursorShape.ruleCount hrule + obtain ⟨linkedRule, normalizedConstructor, hlinkedRule, hnormalized, + hfields, hraw, htyped⟩ := link.rule index hindex + have hruleEq : linkedRule = concreteRule := + KConst.RecursorRuleAt.unique hlinkedRule hrule + subst linkedRule + exact ⟨normalizedConstructor, hnormalized, + CertifiedSingletonGeneration.generatedRuleAt _ hnormalized, + hfields, hraw, htyped⟩ + +/-- E2a registration plus the exact positional Ix link yields the complete +registered-rule semantic relation. -/ +theorem registeredRuleAt + {trProj : RawProjRel} {catalog : Catalog} + {nameOf : Address → Option Lean.Name} {trusted : KId .anon → Prop} + {source : VInductDecl} {before after : VEnv} + {tx : CertifiedGenerationTransaction source before after} + {family : SingletonFamilyCatalogLink trProj catalog nameOf trusted tx} + (link : SingletonRecursorCatalogLink trProj catalog nameOf trusted tx + family) + {index : Nat} {concreteRule : RecRule .anon} + (hrule : link.recursorConcrete.RecursorRuleAt index concreteRule) : + ∃ normalizedConstructor, + tx.certificate.generation.block.ctorPairs[index]? = + some normalizedConstructor ∧ + RegisteredRecursorRuleRhsRel after nameOf trProj link.recursorId + link.recursorConcrete concreteRule + (tx.certificate.generation.rule index normalizedConstructor) := by + obtain ⟨normalizedConstructor, hnormalized, hgenerated, _, hraw, htyped⟩ := + link.ruleAt hrule + have hgeneratedMem : + tx.certificate.generation.rule index normalizedConstructor ∈ + tx.certificate.generation.generatedRules := + List.mem_of_getElem? hgenerated + have hrecursor := link.translateRecursor + refine ⟨normalizedConstructor, hnormalized, + .str tx.certificate.generation.block.sourceType.name "rec", + tx.certificate.generation.recursor, hrecursor.1, + hrecursor.2.1, tx.facts.ruleMem hgeneratedMem, ?_, ?_, hraw, htyped⟩ + · exact tx.facts.afterWF.ordered.defEqWF + (tx.facts.ruleMem hgeneratedMem) + · exact CertifiedSingletonGeneration.generatedRuleHead + tx.certificate.generation index normalizedConstructor + +/-- Membership-only rule evidence is recovered by first retaining the exact +array position. -/ +theorem registeredRule + {trProj : RawProjRel} {catalog : Catalog} + {nameOf : Address → Option Lean.Name} {trusted : KId .anon → Prop} + {source : VInductDecl} {before after : VEnv} + {tx : CertifiedGenerationTransaction source before after} + {family : SingletonFamilyCatalogLink trProj catalog nameOf trusted tx} + (link : SingletonRecursorCatalogLink trProj catalog nameOf trusted tx + family) + {concreteRule : RecRule .anon} + (hrule : link.recursorConcrete.HasRecursorRule concreteRule) : + RawRecursorRuleRel after nameOf trProj link.recursorId + link.recursorConcrete concreteRule := by + obtain ⟨index, hat⟩ := hrule.exists_ruleAt + obtain ⟨normalizedConstructor, _, hregistered⟩ := + link.registeredRuleAt hat + exact ⟨_, hregistered⟩ + +end SingletonRecursorCatalogLink + +end Ix.Tc diff --git a/Ix/Tc/Verify/Inductive/SpecializationIdentity.lean b/Ix/Tc/Verify/Inductive/SpecializationIdentity.lean new file mode 100644 index 000000000..8059ce111 --- /dev/null +++ b/Ix/Tc/Verify/Inductive/SpecializationIdentity.lean @@ -0,0 +1,69 @@ +import Ix.Tc.Verify.Inductive.OccurrenceValidation + +/-! +# Nested-inductive specialization identity + +The positivity recursion stack and flat-block construction must agree on the +identity of an auxiliary. Semantic universe equality and term DefEq are +intentionally broader than this identity: syntactically distinct applications +receive distinct generated auxiliaries even when they denote equal types. +-/ + +namespace Ix.Tc + +/-- Exact flat-block identity represented by a nested positivity group and a +concrete application. -/ +def PositivityFlatIdentity (group : PositivityGroup m) (family : Address) + (us : Array (KUniv m)) (args : Array (KExpr m)) + (nParams : Nat) : Prop := + group.params.size = nParams ∧ + (group.nestedSpecializationKey? family == + some (nestedApplicationSpecializationKey family us args nParams)) = true + +namespace RecM + +/-- The production positivity-stack match is exactly equality of the same key +used by flat-block auxiliary deduplication. -/ +theorem positivityGroupMatches_eq_true_iff + (group : PositivityGroup m) (family : Address) + (us : Array (KUniv m)) (args : Array (KExpr m)) (nParams : Nat) : + positivityGroupMatches group family us args nParams = true ↔ + PositivityFlatIdentity group family us args nParams := by + simp [positivityGroupMatches, PositivityFlatIdentity, Bool.and_eq_true] + +end RecM + +namespace SpecializationIdentityFixture + +private def family : Address := default +private def leftParam : KUniv .anon := .mkParam 0 () +private def rightParam : KUniv .anon := .mkParam 1 () +private def leftUniverse : KUniv .anon := .mkMax leftParam rightParam +private def rightUniverse : KUniv .anon := .mkMax rightParam leftParam +private def group : PositivityGroup .anon := + { addrs := #[family], params := #[], concreteUs := some #[leftUniverse] } + +private theorem semanticUniverseEquality_does_not_collapse_specializationNative : + univEq leftUniverse rightUniverse = true ∧ + (NestedSpecializationKey.ofApplication family #[leftUniverse] #[] == + NestedSpecializationKey.ofApplication family #[rightUniverse] #[]) = + false ∧ + RecM.positivityGroupMatches group family #[rightUniverse] #[] 0 = + false := by + native_decide + +/-- Adversarial boundary: commuted maxima are semantically equal universes, +but they are distinct auxiliary specializations and must not close the same +positivity-stack edge. -/ +theorem semanticUniverseEquality_does_not_collapse_specialization : + univEq leftUniverse rightUniverse = true ∧ + (NestedSpecializationKey.ofApplication family #[leftUniverse] #[] == + NestedSpecializationKey.ofApplication family #[rightUniverse] #[]) = + false ∧ + RecM.positivityGroupMatches group family #[rightUniverse] #[] 0 = + false := + semanticUniverseEquality_does_not_collapse_specializationNative + +end SpecializationIdentityFixture + +end Ix.Tc diff --git a/Ix/Tc/Verify/Infer.lean b/Ix/Tc/Verify/Infer.lean index 72ec43dfc..2947abcda 100644 --- a/Ix/Tc/Verify/Infer.lean +++ b/Ix/Tc/Verify/Infer.lean @@ -289,6 +289,12 @@ def inferCacheSemantics (keys : WhnfContextKeys) (trProj : RawProjRel) blockError := by intro authority support block err exact fallback.blockError authority support block err + blockSuccess := by + intro authority support block h + exact fallback.blockSuccess authority support block h + blockSuccessSound := by + intro authority support block h + exact fallback.blockSuccessSound authority support block h namespace CacheProvenance diff --git a/Ix/Tc/Verify/Infer/BinderScopes.lean b/Ix/Tc/Verify/Infer/BinderScopes.lean index 57a67e3b1..a5d9281f2 100644 --- a/Ix/Tc/Verify/Infer/BinderScopes.lean +++ b/Ix/Tc/Verify/Infer/BinderScopes.lean @@ -85,20 +85,18 @@ theorem instRev_whnf_eval_of_resources (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 +/-- Operational core of binder opening. The domain translation is already +typed so the ghost context can be extended, while the body relation is left +to a caller-specific wrapper. -/ +theorem openBinder_scope_base {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} + {ty body : KExpr .anon} {tyV : 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 → @@ -110,10 +108,7 @@ theorem openBinder_scope 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 + support bodyOpen | .error _ after => WhnfStateInv layer semantics trProj world support uvars Delta after ∧ after = s := by @@ -184,9 +179,6 @@ theorem openBinder_scope · 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⟩ _ @@ -218,9 +210,60 @@ theorem openBinder_scope rw [hopenRun] rfl rw [hopenSuccess] - refine ⟨rfl, rfl, hIOpen, ?_, ?_⟩ - · simpa [fv] using hbodyOpenSupport - · simpa [fv] using hbodyOpenTr + refine ⟨rfl, rfl, hIOpen, ?_⟩ + simpa [fv] using hbodyOpenSupport + +/-- Opening a typed binder returns the freshly tagged typed 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 hbase := openBinder_scope_base (bi := bi) hty htyType hcollision + hresources hI + cases hopen : TcM.openBinder name bi ty body s with + | error err after => + rw [hopen] at hbase + simpa only using hbase + | ok opened after => + rcases opened with ⟨bodyOpen, fv⟩ + rw [hopen] at hbase + simp only + rcases hbase with ⟨hfv, hbodyEq, hIopen, hsupport⟩ + 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) + refine ⟨hfv, hbodyEq, hIopen, hsupport, ?_⟩ + subst fv + subst bodyOpen + exact hbodyOpenTr end TcM diff --git a/Ix/Tc/Verify/Infer/CacheSoundness.lean b/Ix/Tc/Verify/Infer/CacheSoundness.lean index 4911b4106..910f2e56a 100644 --- a/Ix/Tc/Verify/Infer/CacheSoundness.lean +++ b/Ix/Tc/Verify/Infer/CacheSoundness.lean @@ -34,6 +34,25 @@ theorem inferKey_model_matches_wf (keys := model.keys) (Δ := Delta) (source := source) (s := s) (fun _ _ hctx hrun => model.represents hctx hrun)) +/-- Run-scoped inference-key matching. Unlike the legacy theorem, both +success and error states retain the finite suffix-state witness, and the key +representation consumes that witness at the concrete pre-state. -/ +theorem inferKey_scoped_model_matches_wf + {layer : WhnfLayer} {trProj : RawProjRel} {world : VerifyWorld} + {support : RunSupport} (model : ScopedKernelSuffixModel trProj world) + {Delta : KVLCtx} {source : KExpr .anon} {s : TcState .anon} : + TcM.WF + (ScopedWhnfStateInv model layer + (kernelCacheSemantics model.keys trProj) support Delta) s + (TcM.inferKey source) + (fun key s' => + model.keys.Matches trProj world s Delta source key ∧ + ContextKeyFrame s s') := by + simpa [TcM.inferKey_eq_whnfKey] using + (TcM.whnfKey_scoped_model_matches_wf + (layer := layer) (semantics := kernelCacheSemantics model.keys trProj) + (support := support) model (Delta := Delta) (source := source) (s := s)) + end TcM namespace UncachedInference.Context diff --git a/Ix/Tc/Verify/Infer/LetScopes.lean b/Ix/Tc/Verify/Infer/LetScopes.lean index 082cabaf8..b2df97c68 100644 --- a/Ix/Tc/Verify/Infer/LetScopes.lean +++ b/Ix/Tc/Verify/Infer/LetScopes.lean @@ -14,20 +14,19 @@ 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 +/-- Operational core of let opening. The type and value are already typed +so the ghost context can be extended, while the body relation is left to a +caller-specific wrapper. -/ +theorem openLet_scope_base {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} + {ty val body : KExpr .anon} {tyV valV : 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 → @@ -39,10 +38,7 @@ theorem openLet_scope 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 + support bodyOpen | .error _ after => WhnfStateInv layer semantics trProj world support uvars Delta after ∧ after = s := by @@ -113,9 +109,6 @@ theorem openLet_scope · 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⟩ _ @@ -147,9 +140,61 @@ theorem openLet_scope rw [hopenRun] rfl rw [hopenSuccess] - refine ⟨rfl, rfl, hIOpen, ?_, ?_⟩ - · simpa [fv] using hbodyOpenSupport - · simpa [fv] using hbodyOpenTr + refine ⟨rfl, rfl, hIOpen, ?_⟩ + simpa [fv] using hbodyOpenSupport + +/-- Opening a translated let either fails before changing the semantic +context, or returns its freshly tagged typed 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 hbase := openLet_scope_base hty hval hvalType hcollision + hresources hI + cases hopen : TcM.openLet name ty val body s with + | error err after => + rw [hopen] at hbase + simpa only using hbase + | ok opened after => + rcases opened with ⟨bodyOpen, fv⟩ + rw [hopen] at hbase + simp only + rcases hbase with ⟨hfv, hbodyEq, hIopen, hsupport⟩ + 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) + refine ⟨hfv, hbodyEq, hIopen, hsupport, ?_⟩ + subst fv + subst bodyOpen + exact hbodyOpenTr end TcM diff --git a/Ix/Tc/Verify/Ingress/AnonStructural.lean b/Ix/Tc/Verify/Ingress/AnonStructural.lean new file mode 100644 index 000000000..42879463f --- /dev/null +++ b/Ix/Tc/Verify/Ingress/AnonStructural.lean @@ -0,0 +1,225 @@ +import Ix.Tc.Const +import Ix.Tc.Verify.Expr + +/-! +# Structural equality for anonymous kernel values + +Production `BEq` on kernel expressions and universes deliberately compares +content addresses. Closed representation fixtures instead need to decide +genuine inductive equality without assuming that Blake3 is injective. + +The shapes below retain every semantic anonymous-mode field and erase only +metadata fields whose type is definitionally `Unit`. Each shape has a +left-inverse back to the production datatype. Equality reflected through +that left-inverse is therefore structural equality, not hash equality. +-/ + +namespace Ix.Tc +namespace AnonStructural + +def addressDecidableEq : DecidableEq Address := + fun left right => + if h : left == right then + .isTrue (eq_of_beq h) + else + .isFalse fun equality => h (by + cases equality + exact beq_self_eq_true left) + +local instance : DecidableEq Address := addressDecidableEq + +deriving instance DecidableEq for Lean.ReducibilityHints + +inductive Univ where + | zero (addr : Address) + | succ (u : Univ) (addr : Address) + | max (left right : Univ) (addr : Address) + | imax (left right : Univ) (addr : Address) + | param (idx : UInt64) (addr : Address) + deriving DecidableEq + +def Univ.ofKernel : KUniv .anon → Univ + | .zero addr => .zero addr + | .succ u addr => .succ (ofKernel u) addr + | .max left right addr => .max (ofKernel left) (ofKernel right) addr + | .imax left right addr => .imax (ofKernel left) (ofKernel right) addr + | .param idx _ addr => .param idx addr + +def Univ.toKernel : Univ → KUniv .anon + | .zero addr => .zero addr + | .succ u addr => .succ u.toKernel addr + | .max left right addr => .max left.toKernel right.toKernel addr + | .imax left right addr => .imax left.toKernel right.toKernel addr + | .param idx addr => .param idx () addr + +@[simp] theorem Univ.roundtrip (u : KUniv .anon) : + (ofKernel u).toKernel = u := by + induction u <;> simp [ofKernel, toKernel, *] + +structure ExprInfo where + addr : Address + lbr : UInt64 + count0 : UInt64 + hasFVars : Bool + deriving DecidableEq + +def ExprInfo.ofKernel (info : Ix.Tc.ExprInfo .anon) : ExprInfo := + ⟨info.addr, info.lbr, info.count0, info.hasFVars⟩ + +def ExprInfo.toKernel (info : ExprInfo) : Ix.Tc.ExprInfo .anon := + ⟨info.addr, info.lbr, info.count0, info.hasFVars, (), ()⟩ + +@[simp] theorem ExprInfo.roundtrip (info : Ix.Tc.ExprInfo .anon) : + (ofKernel info).toKernel = info := by + cases info + rfl + +inductive Expr where + | var (idx : UInt64) (info : ExprInfo) + | fvar (id : FVarId) (info : ExprInfo) + | sort (u : Univ) (info : ExprInfo) + | const (id : Address) (us : Array Univ) (info : ExprInfo) + | app (fn arg : Expr) (info : ExprInfo) + | lam (type body : Expr) (info : ExprInfo) + | all (type body : Expr) (info : ExprInfo) + | letE (type value body : Expr) (nonDep : Bool) (info : ExprInfo) + | prj (id : Address) (field : UInt64) (value : Expr) (info : ExprInfo) + | nat (value : Nat) (blob : Address) (info : ExprInfo) + | str (value : String) (blob : Address) (info : ExprInfo) + deriving DecidableEq + +def Expr.ofKernel : KExpr .anon → Expr + | .var idx _ info => .var idx (ExprInfo.ofKernel info) + | .fvar id _ info => .fvar id (ExprInfo.ofKernel info) + | .sort u info => .sort (Univ.ofKernel u) (ExprInfo.ofKernel info) + | .const id us info => + .const id.addr (us.map Univ.ofKernel) (ExprInfo.ofKernel info) + | .app fn arg info => + .app (ofKernel fn) (ofKernel arg) (ExprInfo.ofKernel info) + | .lam _ _ type body info => + .lam (ofKernel type) (ofKernel body) (ExprInfo.ofKernel info) + | .all _ _ type body info => + .all (ofKernel type) (ofKernel body) (ExprInfo.ofKernel info) + | .letE _ type value body nonDep info => + .letE (ofKernel type) (ofKernel value) (ofKernel body) nonDep + (ExprInfo.ofKernel info) + | .prj id field value info => + .prj id.addr field (ofKernel value) (ExprInfo.ofKernel info) + | .nat value blob info => .nat value blob (ExprInfo.ofKernel info) + | .str value blob info => .str value blob (ExprInfo.ofKernel info) + +def Expr.toKernel : Expr → KExpr .anon + | .var idx info => .var idx () info.toKernel + | .fvar id info => .fvar id () info.toKernel + | .sort u info => .sort u.toKernel info.toKernel + | .const id us info => + .const ⟨id, ()⟩ (us.map Univ.toKernel) info.toKernel + | .app fn arg info => .app fn.toKernel arg.toKernel info.toKernel + | .lam type body info => .lam () () type.toKernel body.toKernel info.toKernel + | .all type body info => .all () () type.toKernel body.toKernel info.toKernel + | .letE type value body nonDep info => + .letE () type.toKernel value.toKernel body.toKernel nonDep info.toKernel + | .prj id field value info => + .prj ⟨id, ()⟩ field value.toKernel info.toKernel + | .nat value blob info => .nat value blob info.toKernel + | .str value blob info => .str value blob info.toKernel + +@[simp] theorem Expr.roundtrip (expr : KExpr .anon) : + (ofKernel expr).toKernel = expr := by + induction expr <;> + simp [ofKernel, toKernel, Array.map_map, Function.comp_def, *, + Univ.roundtrip, ExprInfo.roundtrip] + +structure RecRule where + fields : UInt64 + rhs : Expr + deriving DecidableEq + +def RecRule.ofKernel (rule : Ix.Tc.RecRule .anon) : RecRule := + ⟨rule.fields, Expr.ofKernel rule.rhs⟩ + +def RecRule.toKernel (rule : RecRule) : Ix.Tc.RecRule .anon := + ⟨(), rule.fields, rule.rhs.toKernel⟩ + +@[simp] theorem RecRule.roundtrip (rule : Ix.Tc.RecRule .anon) : + (ofKernel rule).toKernel = rule := by + cases rule + simp [ofKernel, toKernel] + +inductive Const where + | defn (kind : Ix.DefKind) (safety : Ix.DefinitionSafety) + (hints : Lean.ReducibilityHints) (lvls : UInt64) + (type value : Expr) (block : Address) + | recr (k isUnsafe : Bool) (lvls params indices motives minors : UInt64) + (block : Address) (memberIdx : UInt64) (type : Expr) + (rules : Array RecRule) + | axio (isUnsafe : Bool) (lvls : UInt64) (type : Expr) + | quot (kind : Ix.QuotKind) (lvls : UInt64) (type : Expr) + | indc (lvls params indices : UInt64) (isUnsafe : Bool) + (block : Address) (memberIdx : UInt64) (type : Expr) + (ctors : Array Address) + | ctor (isUnsafe : Bool) (lvls : UInt64) (induct : Address) + (cidx params fields : UInt64) (type : Expr) + deriving DecidableEq + +def Const.ofKernel : KConst .anon → Const + | .defn _ _ kind safety hints lvls type value _ block => + .defn kind safety hints lvls (Expr.ofKernel type) (Expr.ofKernel value) + block.addr + | .recr _ _ k isUnsafe lvls params indices motives minors block memberIdx + type rules _ => + .recr k isUnsafe lvls params indices motives minors block.addr memberIdx + (Expr.ofKernel type) (rules.map RecRule.ofKernel) + | .axio _ _ isUnsafe lvls type => + .axio isUnsafe lvls (Expr.ofKernel type) + | .quot _ _ kind lvls type => .quot kind lvls (Expr.ofKernel type) + | .indc _ _ lvls params indices isUnsafe block memberIdx type ctors _ => + .indc lvls params indices isUnsafe block.addr memberIdx + (Expr.ofKernel type) (ctors.map KId.addr) + | .ctor _ _ isUnsafe lvls induct cidx params fields type => + .ctor isUnsafe lvls induct.addr cidx params fields (Expr.ofKernel type) + +def Const.toKernel : Const → KConst .anon + | .defn kind safety hints lvls type value block => + .defn () () kind safety hints lvls type.toKernel value.toKernel () + ⟨block, ()⟩ + | .recr k isUnsafe lvls params indices motives minors block memberIdx type + rules => + .recr () () k isUnsafe lvls params indices motives minors ⟨block, ()⟩ + memberIdx type.toKernel (rules.map RecRule.toKernel) () + | .axio isUnsafe lvls type => .axio () () isUnsafe lvls type.toKernel + | .quot kind lvls type => .quot () () kind lvls type.toKernel + | .indc lvls params indices isUnsafe block memberIdx type ctors => + .indc () () lvls params indices isUnsafe ⟨block, ()⟩ memberIdx + type.toKernel (ctors.map fun addr => ⟨addr, ()⟩) () + | .ctor isUnsafe lvls induct cidx params fields type => + .ctor () () isUnsafe lvls ⟨induct, ()⟩ cidx params fields type.toKernel + +@[simp] theorem Const.roundtrip (constant : KConst .anon) : + (ofKernel constant).toKernel = constant := by + cases constant <;> + simp [ofKernel, toKernel, Array.map_map, Function.comp_def, + Expr.roundtrip, RecRule.roundtrip] + +def decidableEqOfRoundtrip {original view : Type} [DecidableEq view] + (encode : original → view) (decode : view → original) + (roundtrip : ∀ value, decode (encode value) = value) : + DecidableEq original := fun left right => + if h : encode left = encode right then + .isTrue <| by rw [← roundtrip left, ← roundtrip right, h] + else + .isFalse fun equality => h (congrArg encode equality) + +def idDecidableEq : DecidableEq (KId .anon) := + decidableEqOfRoundtrip KId.addr (fun addr => ⟨addr, ()⟩) (by + intro id + cases id with + | mk addr name => + cases name + rfl) + +def constDecidableEq : DecidableEq (KConst .anon) := + decidableEqOfRoundtrip Const.ofKernel Const.toKernel Const.roundtrip + +end AnonStructural +end Ix.Tc diff --git a/Ix/Tc/Verify/Ingress/LiteralBlobs.lean b/Ix/Tc/Verify/Ingress/LiteralBlobs.lean new file mode 100644 index 000000000..41aa8c664 --- /dev/null +++ b/Ix/Tc/Verify/Ingress/LiteralBlobs.lean @@ -0,0 +1,465 @@ +import Ix.Tc.Verify.Ingress.AnonStructural +import Ix.Tc.Verify.Ingress.Representation + +/-! +# Serialized literal/blob ingress + +This T0 fixture makes the blob side of the serialized representation +contract non-vacuous. A Nat literal and a String literal are stored in one +Ixon environment, serialized, decoded with the pure reference decoder, and +ingressed through the production anonymous lazy-fault path. Separate +malformed environments demonstrate that the decoder rejects a constant or a +blob stored under an address that does not commit to its bytes. +-/ + +namespace Ix.Tc +namespace SerializedLiteralBlobs + +local instance addressDecidableEq : DecidableEq Address := + AnonStructural.addressDecidableEq + +local instance idDecidableEq : DecidableEq (KId .anon) := + AnonStructural.idDecidableEq + +local instance constDecidableEq : DecidableEq (KConst .anon) := + AnonStructural.constDecidableEq + +/- Executable equality is confined to this finite Ixon fixture and compares +the actual inductive fields. -/ +deriving instance DecidableEq for Ixon.Univ +deriving instance DecidableEq for Ixon.Expr +deriving instance DecidableEq for Ixon.Definition +deriving instance DecidableEq for Ixon.RecursorRule +deriving instance DecidableEq for Ixon.Recursor +deriving instance DecidableEq for Ixon.Axiom +deriving instance DecidableEq for Ixon.Quotient +deriving instance DecidableEq for Ixon.Constructor +deriving instance DecidableEq for Ixon.Inductive +deriving instance DecidableEq for Ixon.InductiveProj +deriving instance DecidableEq for Ixon.ConstructorProj +deriving instance DecidableEq for Ixon.RecursorProj +deriving instance DecidableEq for Ixon.DefinitionProj +deriving instance DecidableEq for Ixon.MutConst +deriving instance DecidableEq for Ixon.ConstantInfo +deriving instance DecidableEq for Ixon.Constant +deriving instance DecidableEq for Ixon.LazyConstant + +/-! ## Source environment -/ + +def natBytes : ByteArray := ⟨(42 : Nat).toBytesLE⟩ +def stringBytes : ByteArray := "hi".toUTF8 + +def natBlobAddress : Address := Address.blake3 natBytes +def stringBlobAddress : Address := Address.blake3 stringBytes + +def natConstant : Ixon.Constant := + ⟨.defn ⟨.defn, .safe, 0, .sort 0, .nat 0⟩, + #[], #[natBlobAddress], #[.zero]⟩ + +def stringConstant : Ixon.Constant := + ⟨.defn ⟨.defn, .safe, 0, .sort 0, .str 0⟩, + #[], #[stringBlobAddress], #[.zero]⟩ + +def natAddress : Address := Address.blake3 (Ixon.serConstant natConstant) +def stringAddress : Address := + Address.blake3 (Ixon.serConstant stringConstant) + +def sourceEnv : Ixon.Env := + let base : Ixon.Env := {} + let blobs := base.blobs.insert natBlobAddress natBytes + let blobs := blobs.insert stringBlobAddress stringBytes + let withBlobs : Ixon.Env := { base with blobs := blobs } + (withBlobs.storeConst natAddress natConstant).storeConst + stringAddress stringConstant + +/-! ## Pure byte round-trip -/ + +def encoded : Except String ByteArray := Ixon.serEnv sourceEnv + +def bytes : ByteArray := + match encoded with + | .ok bytes => bytes + | .error _ => ByteArray.empty + +def encodeSucceeded : Bool := + match encoded with + | .ok _ => true + | .error _ => false + +private theorem encodeSucceededNative : encodeSucceeded = true := by + native_decide + +theorem encode_eq : encoded = .ok bytes := by + have success := encodeSucceededNative + unfold encodeSucceeded at success + unfold bytes + generalize hencoded : encoded = result at success ⊢ + cases result <;> simp_all + +def decoded : Ixon.Env := + match Ixon.deEnv bytes with + | .ok env => env + | .error _ => {} + +def decodeSucceeded : Bool := + match Ixon.deEnv bytes with + | .ok _ => true + | .error _ => false + +private theorem decodeSucceededNative : decodeSucceeded = true := by + native_decide + +theorem decode_eq : Ixon.deEnv bytes = .ok decoded := by + have success := decodeSucceededNative + unfold decodeSucceeded at success + unfold decoded + generalize hdecoded : Ixon.deEnv bytes = result at success ⊢ + cases result <;> simp_all + +def env : Ixon.Env := IxonEnv.eraseAnonMetadata decoded + +/-! ## Exact decoded entries -/ + +private theorem natLookupNative : + env.consts.get? natAddress = + some (Ixon.LazyConstant.ofConstant natConstant) := by + native_decide + +private theorem stringLookupNative : + env.consts.get? stringAddress = + some (Ixon.LazyConstant.ofConstant stringConstant) := by + native_decide + +private theorem natBlobLookupNative : + env.getBlob? natBlobAddress = some natBytes := by + native_decide + +private theorem stringBlobLookupNative : + env.getBlob? stringBlobAddress = some stringBytes := by + native_decide + +private theorem natHashNative : + Address.blake3 (Ixon.LazyConstant.ofConstant natConstant).rawBytes = + natAddress := by + native_decide + +private theorem stringHashNative : + Address.blake3 (Ixon.LazyConstant.ofConstant stringConstant).rawBytes = + stringAddress := by + native_decide + +private theorem natBlobHashNative : + Address.blake3 natBytes = natBlobAddress := by + native_decide + +private theorem stringBlobHashNative : + Address.blake3 stringBytes = stringBlobAddress := by + native_decide + +private theorem natEntry : ExactAnonEntry env natAddress natConstant := by + refine ⟨by native_decide, Ixon.LazyConstant.ofConstant natConstant, + natLookupNative, rfl, by native_decide⟩ + +private theorem stringEntry : + ExactAnonEntry env stringAddress stringConstant := by + refine ⟨by native_decide, Ixon.LazyConstant.ofConstant stringConstant, + stringLookupNative, rfl, by native_decide⟩ + +def isLiteralAddress (addr : Address) : Bool := + addr == natAddress || addr == stringAddress + +private theorem isLiteralAddress_iff (addr : Address) : + isLiteralAddress addr = true ↔ + addr = natAddress ∨ addr = stringAddress := by + simp [isLiteralAddress, beq_iff_eq] + +private theorem sourceAddressesClassifiedNative : + (orderedAnonConstAddrs env).toList.all isLiteralAddress = true := by + native_decide + +private theorem sourceAddressCases {addr : Address} + (haddr : addr ∈ orderedAnonConstAddrs env) : + addr = natAddress ∨ addr = stringAddress := by + have hall := sourceAddressesClassifiedNative + rw [List.all_eq_true] at hall + exact (isLiteralAddress_iff addr).mp (hall addr (by simpa using haddr)) + +private theorem sourceKeysClassifiedNative : + env.consts.keys.all isLiteralAddress = true := by + native_decide + +private theorem sourceAddressesNodupNative : + (orderedAnonConstAddrs env).toList.Nodup := by + native_decide + +private theorem sourceKeyCases {addr : Address} + (haddr : addr ∈ env.consts.keys) : + addr = natAddress ∨ addr = stringAddress := by + have hall := sourceKeysClassifiedNative + rw [List.all_eq_true] at hall + exact (isLiteralAddress_iff addr).mp (hall addr haddr) + +private theorem sourceEntryCases {addr : Address} + {constant : Ixon.Constant} (hentry : ExactAnonEntry env addr constant) : + (addr = natAddress ∧ constant = natConstant) ∨ + (addr = stringAddress ∧ constant = stringConstant) := by + rcases sourceAddressCases hentry.1 with rfl | rfl + · exact .inl ⟨rfl, ExactAnonEntry.constant_unique hentry natEntry⟩ + · exact .inr ⟨rfl, ExactAnonEntry.constant_unique hentry stringEntry⟩ + +def sourceWF : AnonWorkEnvWF env where + keysNodup := sourceAddressesNodupNative + entry := by + intro addr haddr + rcases sourceAddressCases haddr with rfl | rfl + · exact ⟨natConstant, natEntry⟩ + · exact ⟨stringConstant, stringEntry⟩ + blocksNonempty := by + intro addr constant members hentry hinfo + rcases sourceEntryCases hentry with ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ + · simp [natConstant] at hinfo + · simp [stringConstant] at hinfo + projectionComplete := by + intro block constant members target hentry hinfo _ + rcases sourceEntryCases hentry with ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ + · simp [natConstant] at hinfo + · simp [stringConstant] at hinfo + projectionOwned := by + intro addr constant owner hentry howner + rcases sourceEntryCases hentry with ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ + · simp [natConstant, projectionOwner?] at howner + · simp [stringConstant, projectionOwner?] at howner + +private theorem constAddresses : IxonEnv.ConstAddressIntegrity env := by + intro addr lazy hlookup + have hmem : addr ∈ env.consts := + (Std.HashMap.getElem?_eq_some_iff.mp hlookup).choose + have hkey : addr ∈ env.consts.keys := Std.HashMap.mem_keys.mpr hmem + rcases sourceKeyCases hkey with rfl | rfl + · have hlazy := Option.some.inj (hlookup.symm.trans natLookupNative) + subst lazy + exact natHashNative + · have hlazy := Option.some.inj (hlookup.symm.trans stringLookupNative) + subst lazy + exact stringHashNative + +private theorem constMaterialization : + IxonEnv.ConstMaterializationIntegrity env := by + intro addr lazy hlookup + have hmem : addr ∈ env.consts := + (Std.HashMap.getElem?_eq_some_iff.mp hlookup).choose + have hkey : addr ∈ env.consts.keys := Std.HashMap.mem_keys.mpr hmem + rcases sourceKeyCases hkey with rfl | rfl + · have hlazy := Option.some.inj (hlookup.symm.trans natLookupNative) + subst lazy + exact ⟨natConstant, rfl⟩ + · have hlazy := Option.some.inj (hlookup.symm.trans stringLookupNative) + subst lazy + exact ⟨stringConstant, rfl⟩ + +def isLiteralBlobAddress (addr : Address) : Bool := + addr == natBlobAddress || addr == stringBlobAddress + +private theorem isLiteralBlobAddress_iff (addr : Address) : + isLiteralBlobAddress addr = true ↔ + addr = natBlobAddress ∨ addr = stringBlobAddress := by + simp [isLiteralBlobAddress, beq_iff_eq] + +private theorem blobKeysClassifiedNative : + env.blobs.keys.all isLiteralBlobAddress = true := by + native_decide + +private theorem blobAddresses : IxonEnv.BlobAddressIntegrity env := by + intro addr value hlookup + have hmem : addr ∈ env.blobs := + (Std.HashMap.getElem?_eq_some_iff.mp hlookup).choose + have hkey : addr ∈ env.blobs.keys := Std.HashMap.mem_keys.mpr hmem + have hall := blobKeysClassifiedNative + rw [List.all_eq_true] at hall + rcases (isLiteralBlobAddress_iff addr).mp (hall addr hkey) with rfl | rfl + · have hvalue := Option.some.inj + (hlookup.symm.trans natBlobLookupNative) + subst value + exact natBlobHashNative + · have hvalue := Option.some.inj + (hlookup.symm.trans stringBlobLookupNative) + subst value + exact stringBlobHashNative + +def blockOfIdempotent : IxonEnv.BlockOfIdempotent env := by + intro addr + cases hlookup : env.getConst? addr with + | none => simp [blockOfAddr, hlookup] + | some constant => + have hraw : ∃ lazy, env.consts.get? addr = some lazy := by + have hbind : + (env.consts.get? addr).bind Ixon.LazyConstant.get? = + some constant := by + simpa only [Ixon.Env.getConst?] using hlookup + rw [Option.bind_eq_some_iff] at hbind + obtain ⟨lazy, hstored, _⟩ := hbind + exact ⟨lazy, hstored⟩ + obtain ⟨lazy, hraw⟩ := hraw + have hmem : addr ∈ env.consts := + (Std.HashMap.getElem?_eq_some_iff.mp hraw).choose + have hkey : addr ∈ env.consts.keys := + Std.HashMap.mem_keys.mpr hmem + rcases sourceKeyCases hkey with rfl | rfl + · simp [blockOfAddr, natEntry.getConst, natConstant] + · simp [blockOfAddr, stringEntry.getConst, stringConstant] + +def representationWF : IxonEnv.RepresentationWF env where + constAddresses := constAddresses + constMaterialization := constMaterialization + blobAddresses := blobAddresses + source := sourceWF + blockOfIdempotent := blockOfIdempotent + +def input : IxonEnv.SerializedAnonInput bytes env where + source := sourceEnv + encode := encode_eq + decoded := decoded + decode := decode_eq + erased := rfl + representation := representationWF + +/-! ## Exact literal ingress -/ + +def natId : KId .anon := ⟨natAddress, ()⟩ +def stringId : KId .anon := ⟨stringAddress, ()⟩ + +def sortZero : KExpr .anon := KExpr.mkSort KUniv.mkZero + +def natExpected : KConst .anon := + .defn () () .defn .safe (.regular 0) 0 sortZero + (KExpr.mkNat 42 natBlobAddress) () natId + +def stringExpected : KConst .anon := + .defn () () .defn .safe (.regular 0) 0 sortZero + (KExpr.mkStr "hi" stringBlobAddress) () stringId + +def natOutcome := + ingressAnonAddrShallow env natAddress true ({} : AnonEnv) + +def natAfter : AnonEnv := + match natOutcome with + | .ok _ after => after + | .error _ failed => failed + +def natSucceeded : Bool := + match natOutcome with + | .ok found _ => found + | .error _ _ => false + +private theorem natSucceededNative : natSucceeded = true := by + native_decide + +theorem natRun : natOutcome = .ok true natAfter := by + have success := natSucceededNative + unfold natSucceeded at success + unfold natAfter + generalize houtcome : natOutcome = result at success ⊢ + cases result <;> simp_all + +private theorem natLoadedNative : + natAfter.get? natId = some natExpected := by + native_decide + +def stringOutcome := + ingressAnonAddrShallow env stringAddress true ({} : AnonEnv) + +def stringAfter : AnonEnv := + match stringOutcome with + | .ok _ after => after + | .error _ failed => failed + +def stringSucceeded : Bool := + match stringOutcome with + | .ok found _ => found + | .error _ _ => false + +private theorem stringSucceededNative : stringSucceeded = true := by + native_decide + +theorem stringRun : stringOutcome = .ok true stringAfter := by + have success := stringSucceededNative + unfold stringSucceeded at success + unfold stringAfter + generalize houtcome : stringOutcome = result at success ⊢ + cases result <;> simp_all + +private theorem stringLoadedNative : + stringAfter.get? stringId = some stringExpected := by + native_decide + +structure LiteralBlobRoundTrip where + input : IxonEnv.SerializedAnonInput bytes env + natBlob : env.getBlob? natBlobAddress = some natBytes + natBlobAddressed : Address.blake3 natBytes = natBlobAddress + stringBlob : env.getBlob? stringBlobAddress = some stringBytes + stringBlobAddressed : Address.blake3 stringBytes = stringBlobAddress + natAfter : AnonEnv + natRun : natOutcome = .ok true natAfter + natLoaded : natAfter.get? natId = some natExpected + stringAfter : AnonEnv + stringRun : stringOutcome = .ok true stringAfter + stringLoaded : stringAfter.get? stringId = some stringExpected + +def literalCertificate : LiteralBlobRoundTrip where + input := input + natBlob := natBlobLookupNative + natBlobAddressed := natBlobHashNative + stringBlob := stringBlobLookupNative + stringBlobAddressed := stringBlobHashNative + natAfter := natAfter + natRun := natRun + natLoaded := natLoadedNative + stringAfter := stringAfter + stringRun := stringRun + stringLoaded := stringLoadedNative + +/-- Non-vacuous T0 literal/blob round-trip through serialized bytes and the +actual anonymous ingress implementation. -/ +theorem literalRoundTrip : Nonempty LiteralBlobRoundTrip := + ⟨literalCertificate⟩ + +/-! ## Adversarial address-integrity fixtures -/ + +def wrongConstantAddress : Address := + Address.blake3 "not-the-constant-body".toUTF8 + +def malformedConstantEnv : Ixon.Env := + let consts := sourceEnv.consts.insert wrongConstantAddress + (Ixon.LazyConstant.ofConstant natConstant) + { sourceEnv with consts := consts } + +private theorem malformedConstantRejectedNative : + IxonEnv.serializationRejected malformedConstantEnv = true := by + native_decide + +/-- The reference decoder rejects constant bytes stored under a mismatching +content address. -/ +theorem malformedConstantRejected : + IxonEnv.SerializedDecodeRejected malformedConstantEnv := + IxonEnv.serializedDecodeRejected_of_true + malformedConstantRejectedNative + +def wrongBlobAddress : Address := + Address.blake3 "not-the-blob-body".toUTF8 + +def malformedBlobEnv : Ixon.Env := + let blobs := sourceEnv.blobs.insert wrongBlobAddress natBytes + { sourceEnv with blobs := blobs } + +private theorem malformedBlobRejectedNative : + IxonEnv.serializationRejected malformedBlobEnv = true := by + native_decide + +/-- The reference decoder rejects blob bytes stored under a mismatching +content address. -/ +theorem malformedBlobRejected : + IxonEnv.SerializedDecodeRejected malformedBlobEnv := + IxonEnv.serializedDecodeRejected_of_true malformedBlobRejectedNative + +end SerializedLiteralBlobs +end Ix.Tc diff --git a/Ix/Tc/Verify/Ingress/Representation.lean b/Ix/Tc/Verify/Ingress/Representation.lean new file mode 100644 index 000000000..79640e35e --- /dev/null +++ b/Ix/Tc/Verify/Ingress/Representation.lean @@ -0,0 +1,264 @@ +import Ix.Tc.Verify.Driver.Enumeration +import Ix.Tc.Verify.Driver.Serial +import Ix.Tc.Verify.Whnf.Runtime.LazyIngress + +/-! +# Serialized Ixon representation correspondence + +This module states the representation boundary between Ixon bytes and the +anonymous kernel model. `Ixon.deEnv` is the pure Lean reference decoder: a +successful run has already traversed the wire format and checked constant +hashes, blob hashes, the canonical constant Merkle root, sorted table keys, +the optional main pointer, and trailing-byte exhaustion. The predicates +below retain the resulting facts in the exact form consumed by ingress. + +The mmap-backed Rust decoder `Ixon.deEnvAnon` is intentionally not equated to +the pure decoder here. That implementation/refinement result belongs to the +later Rust transport phase; T0 reasons from the pure decoder and the actual +Lean eager/lazy ingress functions. +-/ + +namespace Ix.Tc + +namespace IxonEnv + +/-- Anonymous checking erases source names, reverse-name indices, named +metadata, and commitments. Constants, literal blobs, anonymous reducibility +hints, the bundle root, and explicit assumptions are semantic input and are +preserved. -/ +def eraseAnonMetadata (env : Ixon.Env) : Ixon.Env := + { env with named := {}, names := {}, comms := {}, addrToName := {} } + +@[simp] theorem eraseAnonMetadata_consts (env : Ixon.Env) : + (eraseAnonMetadata env).consts = env.consts := rfl + +@[simp] theorem eraseAnonMetadata_blobs (env : Ixon.Env) : + (eraseAnonMetadata env).blobs = env.blobs := rfl + +@[simp] theorem eraseAnonMetadata_hints (env : Ixon.Env) : + (eraseAnonMetadata env).anonHints = env.anonHints := rfl + +@[simp] theorem eraseAnonMetadata_main (env : Ixon.Env) : + (eraseAnonMetadata env).main = env.main := rfl + +@[simp] theorem eraseAnonMetadata_assumptions (env : Ixon.Env) : + (eraseAnonMetadata env).assumptions = env.assumptions := rfl + +@[simp] theorem eraseAnonMetadata_named (env : Ixon.Env) : + (eraseAnonMetadata env).named = {} := rfl + +@[simp] theorem eraseAnonMetadata_names (env : Ixon.Env) : + (eraseAnonMetadata env).names = {} := rfl + +@[simp] theorem eraseAnonMetadata_comms (env : Ixon.Env) : + (eraseAnonMetadata env).comms = {} := rfl + +@[simp] theorem eraseAnonMetadata_addrToName (env : Ixon.Env) : + (eraseAnonMetadata env).addrToName = {} := rfl + +/-- Every stored constant body commits to the map key under which ingress +will request it. This is byte equality at the Ixon layer, before conversion +to a `KConst`; it does not assert hash injectivity. -/ +def ConstAddressIntegrity (env : Ixon.Env) : Prop := + ∀ {addr lazy}, env.consts.get? addr = some lazy → + Address.blake3 lazy.rawBytes = addr + +/-- Every constant entry materializes successfully. The pure decoder +provides cached parsed constants; mmap-backed environments establish the +same property only for entries reached by a successful lazy parse. -/ +def ConstMaterializationIntegrity (env : Ixon.Env) : Prop := + ∀ {addr lazy}, env.consts.get? addr = some lazy → + ∃ constant, lazy.get = .ok constant + +/-- Literal data is separately content-addressed because the constants +Merkle root does not cover blob bytes. -/ +def BlobAddressIntegrity (env : Ixon.Env) : Prop := + ∀ {addr bytes}, env.blobs.get? addr = some bytes → + Address.blake3 bytes = addr + +/-- Representation facts consumed by anonymous work enumeration and ingress. +Projection-address completeness is carried by `source`: every generated +IPrj/CPrj/RPrj/DPrj address must exist and point back to its owning Muts +block. -/ +structure RepresentationWF (env : Ixon.Env) : Prop where + constAddresses : ConstAddressIntegrity env + constMaterialization : ConstMaterializationIntegrity env + blobAddresses : BlobAddressIntegrity env + source : AnonWorkEnvWF env + blockOfIdempotent : BlockOfIdempotent env + +namespace RepresentationWF + +theorem projectionComplete {env : Ixon.Env} (h : RepresentationWF env) + {block constant members target} + (hentry : ExactAnonEntry env block constant) + (hinfo : constant.info = .muts members) + (htarget : target ∈ anonBlockTargets block members) : + ∃ projectionConstant, + ExactAnonEntry env target projectionConstant ∧ + projectionOwner? projectionConstant.info = some block := + h.source.projectionComplete hentry hinfo htarget + +theorem projectionOwned {env : Ixon.Env} (h : RepresentationWF env) + {addr constant owner} + (hentry : ExactAnonEntry env addr constant) + (howner : projectionOwner? constant.info = some owner) : + ∃ blockConstant members, + ExactAnonEntry env owner blockConstant ∧ + blockConstant.info = .muts members ∧ + addr ∈ anonBlockTargets owner members := + h.source.projectionOwned hentry howner + +/-- Hash verification and materialization make the production verified +loader return the exact stored constant. -/ +theorem getConstVerified_true {env : Ixon.Env} (h : RepresentationWF env) + {addr : Address} {lazy : Ixon.LazyConstant} + (hlookup : env.consts.get? addr = some lazy) : + ∃ constant, getConstVerified env addr true = .ok (some constant) := by + obtain ⟨constant, hget⟩ := h.constMaterialization hlookup + refine ⟨constant, ?_⟩ + have hhash := h.constAddresses hlookup + unfold getConstVerified + change env.consts[addr]? = some lazy at hlookup + rw [hlookup] + simp only [Bool.true_or, if_true] + rw [hhash] + simp [hget] + change Except.ok (some constant) = Except.ok (some constant) + rfl + +end RepresentationWF + +/-- A successful pure decode followed by explicit anonymous metadata erasure +and a proof that the resulting ingress source is representation-safe. -/ +structure SerializedAnonInput (bytes : ByteArray) (env : Ixon.Env) where + source : Ixon.Env + encode : Ixon.serEnv source = .ok bytes + decoded : Ixon.Env + decode : Ixon.deEnv bytes = .ok decoded + erased : eraseAnonMetadata decoded = env + representation : RepresentationWF env + +/-- A source environment can be serialized, but its emitted bytes are +rejected by the reference decoder. This is the useful negative contract for +malformed content-addressed maps: the writer is intentionally mechanical, +while the reader enforces representation integrity. -/ +def SerializedDecodeRejected (source : Ixon.Env) : Prop := + ∃ bytes error, + Ixon.serEnv source = .ok bytes ∧ Ixon.deEnv bytes = .error error + +/-- Executable discriminator used only to establish finite rejection +fixtures. -/ +def serializationRejected (source : Ixon.Env) : Bool := + match Ixon.serEnv source with + | .error _ => false + | .ok bytes => + match Ixon.deEnv bytes with + | .error _ => true + | .ok _ => false + +theorem serializedDecodeRejected_of_true {source : Ixon.Env} + (h : serializationRejected source = true) : + SerializedDecodeRejected source := by + unfold serializationRejected at h + generalize hencode : Ixon.serEnv source = encoded at h + cases encoded with + | error error => simp at h + | ok bytes => + generalize hdecode : Ixon.deEnv bytes = decoded at h + cases decoded with + | error error => exact ⟨bytes, error, hencode, hdecode⟩ + | ok env => simp [hdecode] at h + +end IxonEnv + +/-! ## Catalog load correspondence -/ + +/-- Exact successful eager ingress of the work enumerated from a serialized +environment, with both constant and block tables agreeing with the immutable +semantic world. -/ +structure EagerCatalogAgreement (env : Ixon.Env) (world : VerifyWorld) + (work : Array AnonWorkItem) where + after : AnonEnv + run : (ingressAll env true).run ({} : AnonEnv) = .ok work after + constants : LoadedAgrees world.catalog after + blocks : LoadedBlocksAgrees world.blocks after + +/-- One successful production lazy-fault step and its immutable-catalog +postcondition. The step may report `false` for an absent address; in that +case catalog agreement still has to hold. -/ +structure LazyCatalogStep (env : Ixon.Env) (world : VerifyWorld) + (before : AnonEnv) (addr : Address) where + after : AnonEnv + found : Bool + run : ingressAnonAddrShallow env addr true before = .ok found after + constants : LoadedAgrees world.catalog after + blocks : LoadedBlocksAgrees world.blocks after + +/-- A concrete sequence of successful production lazy faults. This is the +finite, run-scoped load oracle used by serialized fixtures; it makes neither +an arbitrary-callback assumption nor an all-address totality claim. -/ +inductive LazyCatalogTrace (env : Ixon.Env) (world : VerifyWorld) : + AnonEnv → List Address → AnonEnv → Prop + | nil (current : AnonEnv) : LazyCatalogTrace env world current [] current + | cons {before after : AnonEnv} {addr : Address} + {rest : List Address} : + (step : LazyCatalogStep env world before addr) → + LazyCatalogTrace env world step.after rest after → + LazyCatalogTrace env world before (addr :: rest) after + +/-! ## Serialized dependency binding -/ + +/-- Every abstract declaration edge is witnessed by the exact serialized +constant at its source and by membership in that constant's `refs` table. +The table is an intern table, so this is intentionally one-way: unused refs +and Nat/String blob slots do not become declaration dependencies. -/ +def SerializedDependencyBound (env : Ixon.Env) + (dependencies : DependencyCatalog) : Prop := + ∀ {source target}, dependencies.dependsOn source target → + ∃ constant, env.getConst? source = some constant ∧ + target ∈ constant.refs + +theorem IxonEnv.dependencyCatalog_bound (env : Ixon.Env) + (hblock : IxonEnv.BlockOfIdempotent env) : + SerializedDependencyBound env + (IxonEnv.dependencyCatalog env hblock) := by + intro source target hdependency + obtain ⟨constant, hget, hsemantic⟩ := hdependency + exact ⟨constant, hget, hsemantic.target_mem_refs⟩ + +/-! ## Byte-level acceptance package -/ + +/-- A complete finite serialized-input acceptance certificate. + +The semantic conclusion remains the existing `SubjectWF`; the additional +fields prove that its source work, dependency edges, eager catalog, lazy +catalog, and production driver execution all originate in one successfully +decoded, hash-verified byte array. -/ +structure SerializedSubjectCertificate (bytes : ByteArray) (world : VerifyWorld) + (dependencies : DependencyCatalog) (assumptions : FiniteAddressSet) + (lazyRequests : List Address) where + env : Ixon.Env + input : IxonEnv.SerializedAnonInput bytes env + eager : EagerCatalogAgreement env world (expectedAnonWork env) + lazyAfter : AnonEnv + lazy : LazyCatalogTrace env world ({} : AnonEnv) lazyRequests lazyAfter + lazyConstants : LoadedAgrees world.catalog lazyAfter + lazyBlocks : LoadedBlocksAgrees world.blocks lazyAfter + dependencyBound : SerializedDependencyBound env dependencies + cfg : CheckCfg + results : Array CheckResult + driver : checkEnvAnon env cfg = .ok results + resultsSucceeded : AllCheckResultsSucceeded results + semantic : SubjectWF world dependencies (expectedAnonWork env) + input.representation.source.subjects assumptions + +/-- Proposition-level public statement: a byte array has a complete finite +serialized-input certificate. -/ +def SerializedSubjectWF (bytes : ByteArray) (world : VerifyWorld) + (dependencies : DependencyCatalog) (assumptions : FiniteAddressSet) + (lazyRequests : List Address) : Prop := + Nonempty (SerializedSubjectCertificate bytes world dependencies assumptions + lazyRequests) + +end Ix.Tc diff --git a/Ix/Tc/Verify/Ingress/SerializedBoolean.lean b/Ix/Tc/Verify/Ingress/SerializedBoolean.lean new file mode 100644 index 000000000..ffabd970e --- /dev/null +++ b/Ix/Tc/Verify/Ingress/SerializedBoolean.lean @@ -0,0 +1,999 @@ +import Ix.Tc.Verify.Driver.BooleanAcceptance +import Ix.Tc.Verify.Ingress.AnonStructural +import Ix.Tc.Verify.Ingress.Representation + +/-! +# Serialized Boolean acceptance + +This is the first complete T0 vertical slice. It serializes the certified +Boolean Ixon environment, decodes the resulting bytes with the pure reference +decoder, erases anonymous-irrelevant metadata, and reconnects the decoded +source to the existing E3-S semantic world. +-/ + +namespace Ix.Tc +namespace BooleanSerialized + +open BooleanEnumerationFixture + +local instance addressDecidableEq : DecidableEq Address := + AnonStructural.addressDecidableEq + +local instance idDecidableEq : DecidableEq (KId .anon) := + AnonStructural.idDecidableEq + +local instance constDecidableEq : DecidableEq (KConst .anon) := + AnonStructural.constDecidableEq + +/-! ## Pure byte round-trip -/ + +def encoded : Except String ByteArray := Ixon.serEnv recursorIxonEnv + +def bytes : ByteArray := + match encoded with + | .ok bytes => bytes + | .error _ => ByteArray.empty + +def encodeSucceeded : Bool := + match encoded with + | .ok _ => true + | .error _ => false + +private theorem encodeSucceededNative : encodeSucceeded = true := by + native_decide + +theorem encode_eq : encoded = .ok bytes := by + have success := encodeSucceededNative + unfold encodeSucceeded at success + unfold bytes + generalize hencoded : encoded = result at success ⊢ + cases result <;> simp_all + +def decoded : Ixon.Env := + match Ixon.deEnv bytes with + | .ok env => env + | .error _ => {} + +def decodeSucceeded : Bool := + match Ixon.deEnv bytes with + | .ok _ => true + | .error _ => false + +private theorem decodeSucceededNative : decodeSucceeded = true := by + native_decide + +theorem decode_eq : Ixon.deEnv bytes = .ok decoded := by + have success := decodeSucceededNative + unfold decodeSucceeded at success + unfold decoded + generalize hdecoded : Ixon.deEnv bytes = result at success ⊢ + cases result <;> simp_all + +/-- The exact environment consumed by anonymous checking. -/ +def env : Ixon.Env := IxonEnv.eraseAnonMetadata decoded + +/-! ## Exact decoded source entries -/ + +private theorem sourceAddressesNative : + orderedAnonConstAddrs env = + #[recursorBlockAddress, trueId.addr, familyBlockAddress, + recursorId.addr, falseId.addr, familyId.addr] := by + native_decide + +theorem sourceAddresses : + orderedAnonConstAddrs env = + #[recursorBlockAddress, trueId.addr, familyBlockAddress, + recursorId.addr, falseId.addr, familyId.addr] := + sourceAddressesNative + +private theorem sourceKeysNative : + env.consts.keys = + [recursorBlockAddress, falseId.addr, recursorId.addr, + trueId.addr, familyBlockAddress, familyId.addr] := by + native_decide + +theorem sourceKeys : + env.consts.keys = + [recursorBlockAddress, falseId.addr, recursorId.addr, + trueId.addr, familyBlockAddress, familyId.addr] := + sourceKeysNative + +private theorem sourceAddressesNodupNative : + (#[recursorBlockAddress, trueId.addr, familyBlockAddress, + recursorId.addr, falseId.addr, familyId.addr] : Array Address).toList.Nodup := by + native_decide + +private theorem recursorBlockLookupNative : + env.consts.get? recursorBlockAddress = some + (Ixon.LazyConstant.ofConstant recursorBlockConstant) := by + native_decide + +private theorem familyBlockLookupNative : + env.consts.get? familyBlockAddress = some + (Ixon.LazyConstant.ofConstant familyBlockConstant) := by + native_decide + +private theorem recursorProjectionLookupNative : + env.consts.get? recursorId.addr = some + (Ixon.LazyConstant.ofConstant recursorProjectionConstant) := by + native_decide + +private theorem familyProjectionLookupNative : + env.consts.get? familyId.addr = some + (Ixon.LazyConstant.ofConstant familyProjectionConstant) := by + native_decide + +private theorem falseProjectionLookupNative : + env.consts.get? falseId.addr = some + (Ixon.LazyConstant.ofConstant falseProjectionConstant) := by + native_decide + +private theorem trueProjectionLookupNative : + env.consts.get? trueId.addr = some + (Ixon.LazyConstant.ofConstant trueProjectionConstant) := by + native_decide + +private theorem recursorBlockHashNative : + Address.blake3 + (Ixon.LazyConstant.ofConstant recursorBlockConstant).rawBytes = + recursorBlockAddress := by + native_decide + +private theorem familyBlockHashNative : + Address.blake3 + (Ixon.LazyConstant.ofConstant familyBlockConstant).rawBytes = + familyBlockAddress := by + native_decide + +private theorem recursorProjectionHashNative : + Address.blake3 + (Ixon.LazyConstant.ofConstant recursorProjectionConstant).rawBytes = + recursorId.addr := by + native_decide + +private theorem familyProjectionHashNative : + Address.blake3 + (Ixon.LazyConstant.ofConstant familyProjectionConstant).rawBytes = + familyId.addr := by + native_decide + +private theorem falseProjectionHashNative : + Address.blake3 + (Ixon.LazyConstant.ofConstant falseProjectionConstant).rawBytes = + falseId.addr := by + native_decide + +private theorem trueProjectionHashNative : + Address.blake3 + (Ixon.LazyConstant.ofConstant trueProjectionConstant).rawBytes = + trueId.addr := by + native_decide + +private theorem familyBlockEntry : + ExactAnonEntry env familyBlockAddress familyBlockConstant := by + refine ⟨by native_decide, + Ixon.LazyConstant.ofConstant familyBlockConstant, + familyBlockLookupNative, rfl, by native_decide⟩ + +private theorem recursorBlockEntry : + ExactAnonEntry env recursorBlockAddress recursorBlockConstant := by + refine ⟨by native_decide, + Ixon.LazyConstant.ofConstant recursorBlockConstant, + recursorBlockLookupNative, rfl, by native_decide⟩ + +private theorem familyProjectionEntry : + ExactAnonEntry env familyId.addr familyProjectionConstant := by + refine ⟨by native_decide, + Ixon.LazyConstant.ofConstant familyProjectionConstant, + familyProjectionLookupNative, rfl, by native_decide⟩ + +private theorem falseProjectionEntry : + ExactAnonEntry env falseId.addr falseProjectionConstant := by + refine ⟨by native_decide, + Ixon.LazyConstant.ofConstant falseProjectionConstant, + falseProjectionLookupNative, rfl, by native_decide⟩ + +private theorem trueProjectionEntry : + ExactAnonEntry env trueId.addr trueProjectionConstant := by + refine ⟨by native_decide, + Ixon.LazyConstant.ofConstant trueProjectionConstant, + trueProjectionLookupNative, rfl, by native_decide⟩ + +private theorem recursorProjectionEntry : + ExactAnonEntry env recursorId.addr recursorProjectionConstant := by + refine ⟨by native_decide, + Ixon.LazyConstant.ofConstant recursorProjectionConstant, + recursorProjectionLookupNative, rfl, by native_decide⟩ + +private theorem sourceEntryCases {addr : Address} {constant : Ixon.Constant} + (hentry : ExactAnonEntry env addr constant) : + (addr = recursorBlockAddress ∧ constant = recursorBlockConstant) ∨ + (addr = trueId.addr ∧ constant = trueProjectionConstant) ∨ + (addr = familyBlockAddress ∧ constant = familyBlockConstant) ∨ + (addr = recursorId.addr ∧ constant = recursorProjectionConstant) ∨ + (addr = falseId.addr ∧ constant = falseProjectionConstant) ∨ + (addr = familyId.addr ∧ constant = familyProjectionConstant) := by + have haddr := hentry.1 + rw [sourceAddresses] at haddr + simp at haddr + rcases haddr with haddr | haddr | haddr | haddr | haddr | haddr + · subst addr + exact .inl ⟨rfl, + ExactAnonEntry.constant_unique hentry recursorBlockEntry⟩ + · subst addr + exact .inr (.inl ⟨rfl, + ExactAnonEntry.constant_unique hentry trueProjectionEntry⟩) + · subst addr + exact .inr (.inr (.inl ⟨rfl, + ExactAnonEntry.constant_unique hentry familyBlockEntry⟩)) + · subst addr + exact .inr (.inr (.inr (.inl ⟨rfl, + ExactAnonEntry.constant_unique hentry recursorProjectionEntry⟩))) + · subst addr + exact .inr (.inr (.inr (.inr (.inl ⟨rfl, + ExactAnonEntry.constant_unique hentry falseProjectionEntry⟩)))) + · subst addr + exact .inr (.inr (.inr (.inr (.inr ⟨rfl, + ExactAnonEntry.constant_unique hentry familyProjectionEntry⟩)))) + +private theorem recursorTargetsNonemptyNative : + (anonBlockTargets recursorBlockAddress #[.recr recursorIxon]).size > 0 := by + native_decide + +private theorem familyTargetsNonemptyNative : + (anonBlockTargets familyBlockAddress #[.indc familyIxon]).size > 0 := by + native_decide + +/-- The decoded environment satisfies the same exact work-enumeration +contract as the pre-serialization source. -/ +def sourceWF : AnonWorkEnvWF env where + keysNodup := by + rw [sourceAddresses] + exact sourceAddressesNodupNative + entry := by + intro addr haddr + rw [sourceAddresses] at haddr + simp at haddr + rcases haddr with rfl | rfl | rfl | rfl | rfl | rfl + · exact ⟨recursorBlockConstant, recursorBlockEntry⟩ + · exact ⟨trueProjectionConstant, trueProjectionEntry⟩ + · exact ⟨familyBlockConstant, familyBlockEntry⟩ + · exact ⟨recursorProjectionConstant, recursorProjectionEntry⟩ + · exact ⟨falseProjectionConstant, falseProjectionEntry⟩ + · exact ⟨familyProjectionConstant, familyProjectionEntry⟩ + blocksNonempty := by + intro addr constant members hentry hinfo + rcases sourceEntryCases hentry with + ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | + ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ + · cases hinfo + exact recursorTargetsNonemptyNative + · simp [trueProjectionConstant] at hinfo + · cases hinfo + exact familyTargetsNonemptyNative + · simp [recursorProjectionConstant] at hinfo + · simp [falseProjectionConstant] at hinfo + · simp [familyProjectionConstant] at hinfo + projectionComplete := by + intro block constant members target hentry hinfo htarget + rcases sourceEntryCases hentry with + ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | + ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ + · cases hinfo + simp [anonBlockTargets, anonMemberTargets, recursorIxon] at htarget + subst target + exact ⟨recursorProjectionConstant, recursorProjectionEntry, rfl⟩ + · simp [trueProjectionConstant] at hinfo + · cases hinfo + simp [anonBlockTargets, anonMemberTargets, familyIxon] at htarget + rcases htarget with htarget | ⟨index, hbound, htarget⟩ + · subst target + exact ⟨familyProjectionConstant, familyProjectionEntry, rfl⟩ + · have hindex : index = 0 ∨ index = 1 := by omega + rcases hindex with rfl | rfl + · subst target + exact ⟨falseProjectionConstant, falseProjectionEntry, rfl⟩ + · subst target + exact ⟨trueProjectionConstant, trueProjectionEntry, rfl⟩ + · simp [recursorProjectionConstant] at hinfo + · simp [falseProjectionConstant] at hinfo + · simp [familyProjectionConstant] at hinfo + projectionOwned := by + intro addr constant owner hentry howner + rcases sourceEntryCases hentry with + ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | + ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ + · simp [recursorBlockConstant, projectionOwner?] at howner + · simp [trueProjectionConstant, projectionOwner?] at howner + subst owner + exact ⟨familyBlockConstant, #[.indc familyIxon], familyBlockEntry, + rfl, by + simp [anonBlockTargets, anonMemberTargets, familyIxon, trueId] + right + exact ⟨1, by omega, rfl⟩⟩ + · simp [familyBlockConstant, projectionOwner?] at howner + · simp [recursorProjectionConstant, projectionOwner?] at howner + subst owner + exact ⟨recursorBlockConstant, #[.recr recursorIxon], + recursorBlockEntry, rfl, by + simp [anonBlockTargets, anonMemberTargets, recursorIxon, + recursorId]⟩ + · simp [falseProjectionConstant, projectionOwner?] at howner + subst owner + exact ⟨familyBlockConstant, #[.indc familyIxon], familyBlockEntry, + rfl, by + simp [anonBlockTargets, anonMemberTargets, familyIxon, falseId] + right + exact ⟨0, by omega, rfl⟩⟩ + · simp [familyProjectionConstant, projectionOwner?] at howner + subst owner + exact ⟨familyBlockConstant, #[.indc familyIxon], familyBlockEntry, + rfl, by + simp [anonBlockTargets, anonMemberTargets, familyIxon, familyId]⟩ + +private theorem constAddresses : IxonEnv.ConstAddressIntegrity env := by + intro addr lazy hlookup + have hmem : addr ∈ env.consts := + (Std.HashMap.getElem?_eq_some_iff.mp hlookup).choose + have hkey : addr ∈ env.consts.keys := Std.HashMap.mem_keys.mpr hmem + rw [sourceKeys] at hkey + simp at hkey + rcases hkey with rfl | rfl | rfl | rfl | rfl | rfl + · have hlazy := Option.some.inj + (hlookup.symm.trans recursorBlockLookupNative) + subst lazy + exact recursorBlockHashNative + · have hlazy := Option.some.inj + (hlookup.symm.trans falseProjectionLookupNative) + subst lazy + exact falseProjectionHashNative + · have hlazy := Option.some.inj + (hlookup.symm.trans recursorProjectionLookupNative) + subst lazy + exact recursorProjectionHashNative + · have hlazy := Option.some.inj + (hlookup.symm.trans trueProjectionLookupNative) + subst lazy + exact trueProjectionHashNative + · have hlazy := Option.some.inj + (hlookup.symm.trans familyBlockLookupNative) + subst lazy + exact familyBlockHashNative + · have hlazy := Option.some.inj + (hlookup.symm.trans familyProjectionLookupNative) + subst lazy + exact familyProjectionHashNative + +private theorem constMaterialization : + IxonEnv.ConstMaterializationIntegrity env := by + intro addr lazy hlookup + have hmem : addr ∈ env.consts := + (Std.HashMap.getElem?_eq_some_iff.mp hlookup).choose + have hkey : addr ∈ env.consts.keys := Std.HashMap.mem_keys.mpr hmem + rw [sourceKeys] at hkey + simp at hkey + rcases hkey with rfl | rfl | rfl | rfl | rfl | rfl + · have hlazy := Option.some.inj + (hlookup.symm.trans recursorBlockLookupNative) + subst lazy + exact ⟨recursorBlockConstant, rfl⟩ + · have hlazy := Option.some.inj + (hlookup.symm.trans falseProjectionLookupNative) + subst lazy + exact ⟨falseProjectionConstant, rfl⟩ + · have hlazy := Option.some.inj + (hlookup.symm.trans recursorProjectionLookupNative) + subst lazy + exact ⟨recursorProjectionConstant, rfl⟩ + · have hlazy := Option.some.inj + (hlookup.symm.trans trueProjectionLookupNative) + subst lazy + exact ⟨trueProjectionConstant, rfl⟩ + · have hlazy := Option.some.inj + (hlookup.symm.trans familyBlockLookupNative) + subst lazy + exact ⟨familyBlockConstant, rfl⟩ + · have hlazy := Option.some.inj + (hlookup.symm.trans familyProjectionLookupNative) + subst lazy + exact ⟨familyProjectionConstant, rfl⟩ + +private theorem blobKeysNative : env.blobs.keys = [] := by + native_decide + +private theorem blobAddresses : IxonEnv.BlobAddressIntegrity env := by + intro addr value hlookup + have hmem : addr ∈ env.blobs := + (Std.HashMap.getElem?_eq_some_iff.mp hlookup).choose + have hkey : addr ∈ env.blobs.keys := Std.HashMap.mem_keys.mpr hmem + rw [blobKeysNative] at hkey + simp at hkey + +/-! ## Collapsed block identity -/ + +def blockOfIdempotent : IxonEnv.BlockOfIdempotent env := by + intro addr + cases hlookup : env.getConst? addr with + | none => + simp [blockOfAddr, hlookup] + | some constant => + have hraw : ∃ lazy, env.consts.get? addr = some lazy := by + have hbind : + (env.consts.get? addr).bind Ixon.LazyConstant.get? = + some constant := by + simpa only [Ixon.Env.getConst?] using hlookup + rw [Option.bind_eq_some_iff] at hbind + obtain ⟨lazy, hstored, _⟩ := hbind + exact ⟨lazy, hstored⟩ + obtain ⟨lazy, hraw⟩ := hraw + have hmem : addr ∈ env.consts := + (Std.HashMap.getElem?_eq_some_iff.mp hraw).choose + have hkey : addr ∈ env.consts.keys := + Std.HashMap.mem_keys.mpr hmem + rw [sourceKeys] at hkey + simp at hkey + rcases hkey with rfl | rfl | rfl | rfl | rfl | rfl + · simp [blockOfAddr, recursorBlockEntry.getConst, + recursorBlockConstant] + · simp [blockOfAddr, falseProjectionEntry.getConst, + familyBlockEntry.getConst, falseProjectionConstant, + familyBlockConstant] + · simp [blockOfAddr, recursorProjectionEntry.getConst, + recursorBlockEntry.getConst, recursorProjectionConstant, + recursorBlockConstant] + · simp [blockOfAddr, trueProjectionEntry.getConst, + familyBlockEntry.getConst, trueProjectionConstant, + familyBlockConstant] + · simp [blockOfAddr, familyBlockEntry.getConst, + familyBlockConstant] + · simp [blockOfAddr, familyProjectionEntry.getConst, + familyBlockEntry.getConst, familyProjectionConstant, + familyBlockConstant] + +/-- Hash, materialization, blob, projection, and collapsed-block integrity of +the decoded anonymous environment. -/ +def representationWF : IxonEnv.RepresentationWF env where + constAddresses := constAddresses + constMaterialization := constMaterialization + blobAddresses := blobAddresses + source := sourceWF + blockOfIdempotent := blockOfIdempotent + +def input : IxonEnv.SerializedAnonInput bytes env where + source := recursorIxonEnv + encode := encode_eq + decoded := decoded + decode := decode_eq + erased := rfl + representation := representationWF + +/-! ## Eager catalog correspondence -/ + +private theorem buildAnonWorkNative : + buildAnonWork env = .ok booleanWork := by + native_decide + +theorem expectedAnonWork_eq : + expectedAnonWork env = booleanWork := by + exact Except.ok.inj + (sourceWF.buildAnonWork_eq_expected.symm.trans buildAnonWorkNative) + +def eagerOutcome := (ingressAll env true).run ({} : AnonEnv) + +def eagerSucceeded : Bool := + match eagerOutcome with + | .ok _ _ => true + | .error _ _ => false + +private theorem eagerSucceededNative : eagerSucceeded = true := by + native_decide + +def eagerWork : Array AnonWorkItem := + match eagerOutcome with + | .ok work _ => work + | .error _ _ => #[] + +def eagerAfter : AnonEnv := + match eagerOutcome with + | .ok _ after => after + | .error _ failed => failed + +private theorem eagerWorkNative : eagerWork = booleanWork := by + native_decide + +theorem eagerRun : eagerOutcome = .ok booleanWork eagerAfter := by + have success := eagerSucceededNative + have workEq := eagerWorkNative + unfold eagerSucceeded at success + unfold eagerWork at workEq + unfold eagerAfter + generalize houtcome : eagerOutcome = result at success workEq ⊢ + cases result <;> simp_all + +def isCataloguedId (id : KId .anon) : Bool := + id == familyId || id == falseId || id == trueId || id == recursorId + +private theorem isCataloguedId_iff (id : KId .anon) : + isCataloguedId id = true ↔ + id = familyId ∨ id = falseId ∨ id = trueId ∨ id = recursorId := by + simp [isCataloguedId, beq_iff_eq, or_assoc] + +private theorem eagerKeysClassifiedNative : + eagerAfter.consts.keys.all isCataloguedId = true := by + native_decide + +private theorem eagerKeyCases {id : KId .anon} + (hmem : id ∈ eagerAfter.consts.keys) : + id = familyId ∨ id = falseId ∨ id = trueId ∨ id = recursorId := by + have hall := eagerKeysClassifiedNative + rw [List.all_eq_true] at hall + exact (isCataloguedId_iff id).mp (hall id hmem) + +private theorem eagerFamilyNative : + eagerAfter.get? familyId = some familyConcrete := by + native_decide + +private theorem eagerFalseNative : + eagerAfter.get? falseId = some falseConcrete := by + native_decide + +private theorem eagerTrueNative : + eagerAfter.get? trueId = some trueConcrete := by + native_decide + +private theorem eagerRecursorNative : + eagerAfter.get? recursorId = some recursorConcrete := by + native_decide + +theorem eagerConstants : + LoadedAgrees stagedWorld.catalog eagerAfter := by + intro id constant hget + have hmap : eagerAfter.consts[id]? = some constant := by + simpa only [KEnv.get?] using hget + have hmem : id ∈ eagerAfter.consts := + (Std.HashMap.getElem?_eq_some_iff.mp hmap).choose + have hkey : id ∈ eagerAfter.consts.keys := Std.HashMap.mem_keys.mpr hmem + rcases eagerKeyCases hkey with rfl | rfl | rfl | rfl + · have hc := Option.some.inj (hget.symm.trans eagerFamilyNative) + subst constant + simpa [stagedWorld] using catalog_family + · have hc := Option.some.inj (hget.symm.trans eagerFalseNative) + subst constant + simpa [stagedWorld] using catalog_false + · have hc := Option.some.inj (hget.symm.trans eagerTrueNative) + subst constant + simpa [stagedWorld] using catalog_true + · have hc := Option.some.inj (hget.symm.trans eagerRecursorNative) + subst constant + simpa [stagedWorld] using catalog_recursor + +def isCataloguedBlock (id : KId .anon) : Bool := + id == familyBlockId || id == recursorBlockId + +private theorem isCataloguedBlock_iff (id : KId .anon) : + isCataloguedBlock id = true ↔ + id = familyBlockId ∨ id = recursorBlockId := by + simp [isCataloguedBlock, beq_iff_eq] + +private theorem eagerBlockKeysClassifiedNative : + eagerAfter.blocks.keys.all isCataloguedBlock = true := by + native_decide + +private theorem eagerBlockKeyCases {id : KId .anon} + (hmem : id ∈ eagerAfter.blocks.keys) : + id = familyBlockId ∨ id = recursorBlockId := by + have hall := eagerBlockKeysClassifiedNative + rw [List.all_eq_true] at hall + exact (isCataloguedBlock_iff id).mp + (hall id hmem) + +private theorem eagerFamilyBlockNative : + eagerAfter.getBlock? familyBlockId = some familyMembers := by + native_decide + +private theorem eagerRecursorBlockNative : + eagerAfter.getBlock? recursorBlockId = some recursorMembers := by + native_decide + +theorem eagerBlocks : LoadedBlocksAgrees stagedWorld.blocks eagerAfter := by + intro id members hget + have hmem : id ∈ eagerAfter.blocks := + (Std.HashMap.getElem?_eq_some_iff.mp hget).choose + have hkey : id ∈ eagerAfter.blocks.keys := Std.HashMap.mem_keys.mpr hmem + rcases eagerBlockKeyCases hkey with rfl | rfl + · have hm := Option.some.inj (hget.symm.trans eagerFamilyBlockNative) + subst members + simpa [stagedWorld] using world_family_block + · have hm := Option.some.inj (hget.symm.trans eagerRecursorBlockNative) + subst members + simpa [stagedWorld] using world_recursor_block + +def eagerAgreement : + EagerCatalogAgreement env stagedWorld (expectedAnonWork env) where + after := eagerAfter + run := by + rw [expectedAnonWork_eq] + exact eagerRun + constants := eagerConstants + blocks := eagerBlocks + +/-! ## Cold lazy-ingress catalog correspondence -/ + +def lazyFamilyOutcome := + ingressAnonAddrShallow env familyId.addr true ({} : AnonEnv) + +def lazyFamilyAfter : AnonEnv := + match lazyFamilyOutcome with + | .ok _ after => after + | .error _ failed => failed + +def lazyFamilySucceeded : Bool := + match lazyFamilyOutcome with + | .ok found _ => found + | .error _ _ => false + +private theorem lazyFamilySucceededNative : + lazyFamilySucceeded = true := by + native_decide + +theorem lazyFamilyRun : + lazyFamilyOutcome = .ok true lazyFamilyAfter := by + have success := lazyFamilySucceededNative + unfold lazyFamilySucceeded at success + unfold lazyFamilyAfter + generalize houtcome : lazyFamilyOutcome = result at success ⊢ + cases result <;> simp_all + +def isFamilyId (id : KId .anon) : Bool := + id == familyId || id == falseId || id == trueId + +private theorem isFamilyId_iff (id : KId .anon) : + isFamilyId id = true ↔ + id = familyId ∨ id = falseId ∨ id = trueId := by + simp [isFamilyId, beq_iff_eq, or_assoc] + +private theorem lazyFamilyKeysClassifiedNative : + lazyFamilyAfter.consts.keys.all isFamilyId = true := by + native_decide + +private theorem lazyFamilyKeyCases {id : KId .anon} + (hmem : id ∈ lazyFamilyAfter.consts.keys) : + id = familyId ∨ id = falseId ∨ id = trueId := by + have hall := lazyFamilyKeysClassifiedNative + rw [List.all_eq_true] at hall + exact (isFamilyId_iff id).mp (hall id hmem) + +private theorem lazyFamilyLoadedNative : + lazyFamilyAfter.get? familyId = some familyConcrete := by + native_decide + +private theorem lazyFalseLoadedNative : + lazyFamilyAfter.get? falseId = some falseConcrete := by + native_decide + +private theorem lazyTrueLoadedNative : + lazyFamilyAfter.get? trueId = some trueConcrete := by + native_decide + +theorem lazyFamilyConstants : + LoadedAgrees stagedWorld.catalog lazyFamilyAfter := by + intro id constant hget + have hmap : lazyFamilyAfter.consts[id]? = some constant := by + simpa only [KEnv.get?] using hget + have hmem : id ∈ lazyFamilyAfter.consts := + (Std.HashMap.getElem?_eq_some_iff.mp hmap).choose + have hkey : id ∈ lazyFamilyAfter.consts.keys := + Std.HashMap.mem_keys.mpr hmem + rcases lazyFamilyKeyCases hkey with rfl | rfl | rfl + · have hc := Option.some.inj (hget.symm.trans lazyFamilyLoadedNative) + subst constant + simpa [stagedWorld] using catalog_family + · have hc := Option.some.inj (hget.symm.trans lazyFalseLoadedNative) + subst constant + simpa [stagedWorld] using catalog_false + · have hc := Option.some.inj (hget.symm.trans lazyTrueLoadedNative) + subst constant + simpa [stagedWorld] using catalog_true + +private theorem lazyFamilyBlockKeysNative : + lazyFamilyAfter.blocks.keys.all (fun id => id == familyBlockId) = true := by + native_decide + +private theorem lazyFamilyBlockNative : + lazyFamilyAfter.getBlock? familyBlockId = some familyMembers := by + native_decide + +theorem lazyFamilyBlocks : + LoadedBlocksAgrees stagedWorld.blocks lazyFamilyAfter := by + intro id members hget + have hmem : id ∈ lazyFamilyAfter.blocks := + (Std.HashMap.getElem?_eq_some_iff.mp hget).choose + have hkey : id ∈ lazyFamilyAfter.blocks.keys := + Std.HashMap.mem_keys.mpr hmem + have hall := lazyFamilyBlockKeysNative + rw [List.all_eq_true] at hall + have hid : id = familyBlockId := eq_of_beq (hall id hkey) + subst id + have hm := Option.some.inj (hget.symm.trans lazyFamilyBlockNative) + subst members + simpa [stagedWorld] using world_family_block + +def lazyFamilyStep : + LazyCatalogStep env stagedWorld ({} : AnonEnv) familyId.addr where + after := lazyFamilyAfter + found := true + run := lazyFamilyRun + constants := lazyFamilyConstants + blocks := lazyFamilyBlocks + +def lazyRecursorOutcome := + ingressAnonAddrShallow env recursorId.addr true lazyFamilyAfter + +def lazyRecursorAfter : AnonEnv := + match lazyRecursorOutcome with + | .ok _ after => after + | .error _ failed => failed + +def lazyRecursorSucceeded : Bool := + match lazyRecursorOutcome with + | .ok found _ => found + | .error _ _ => false + +private theorem lazyRecursorSucceededNative : + lazyRecursorSucceeded = true := by + native_decide + +theorem lazyRecursorRun : + lazyRecursorOutcome = .ok true lazyRecursorAfter := by + have success := lazyRecursorSucceededNative + unfold lazyRecursorSucceeded at success + unfold lazyRecursorAfter + generalize houtcome : lazyRecursorOutcome = result at success ⊢ + cases result <;> simp_all + +private theorem lazyRecursorKeysClassifiedNative : + lazyRecursorAfter.consts.keys.all isCataloguedId = true := by + native_decide + +private theorem lazyRecursorKeyCases {id : KId .anon} + (hmem : id ∈ lazyRecursorAfter.consts.keys) : + id = familyId ∨ id = falseId ∨ id = trueId ∨ id = recursorId := by + have hall := lazyRecursorKeysClassifiedNative + rw [List.all_eq_true] at hall + exact (isCataloguedId_iff id).mp (hall id hmem) + +private theorem lazyFinalFamilyNative : + lazyRecursorAfter.get? familyId = some familyConcrete := by + native_decide + +private theorem lazyFinalFalseNative : + lazyRecursorAfter.get? falseId = some falseConcrete := by + native_decide + +private theorem lazyFinalTrueNative : + lazyRecursorAfter.get? trueId = some trueConcrete := by + native_decide + +private theorem lazyFinalRecursorNative : + lazyRecursorAfter.get? recursorId = some recursorConcrete := by + native_decide + +theorem lazyFinalConstants : + LoadedAgrees stagedWorld.catalog lazyRecursorAfter := by + intro id constant hget + have hmap : lazyRecursorAfter.consts[id]? = some constant := by + simpa only [KEnv.get?] using hget + have hmem : id ∈ lazyRecursorAfter.consts := + (Std.HashMap.getElem?_eq_some_iff.mp hmap).choose + have hkey : id ∈ lazyRecursorAfter.consts.keys := + Std.HashMap.mem_keys.mpr hmem + rcases lazyRecursorKeyCases hkey with rfl | rfl | rfl | rfl + · have hc := Option.some.inj (hget.symm.trans lazyFinalFamilyNative) + subst constant + simpa [stagedWorld] using catalog_family + · have hc := Option.some.inj (hget.symm.trans lazyFinalFalseNative) + subst constant + simpa [stagedWorld] using catalog_false + · have hc := Option.some.inj (hget.symm.trans lazyFinalTrueNative) + subst constant + simpa [stagedWorld] using catalog_true + · have hc := Option.some.inj (hget.symm.trans lazyFinalRecursorNative) + subst constant + simpa [stagedWorld] using catalog_recursor + +private theorem lazyFinalBlockKeysClassifiedNative : + lazyRecursorAfter.blocks.keys.all isCataloguedBlock = true := by + native_decide + +private theorem lazyFinalFamilyBlockNative : + lazyRecursorAfter.getBlock? familyBlockId = some familyMembers := by + native_decide + +private theorem lazyFinalRecursorBlockNative : + lazyRecursorAfter.getBlock? recursorBlockId = some recursorMembers := by + native_decide + +theorem lazyFinalBlocks : + LoadedBlocksAgrees stagedWorld.blocks lazyRecursorAfter := by + intro id members hget + have hmem : id ∈ lazyRecursorAfter.blocks := + (Std.HashMap.getElem?_eq_some_iff.mp hget).choose + have hkey : id ∈ lazyRecursorAfter.blocks.keys := + Std.HashMap.mem_keys.mpr hmem + have hall := lazyFinalBlockKeysClassifiedNative + rw [List.all_eq_true] at hall + rcases (isCataloguedBlock_iff id).mp (hall id hkey) with rfl | rfl + · have hm := Option.some.inj + (hget.symm.trans lazyFinalFamilyBlockNative) + subst members + simpa [stagedWorld] using world_family_block + · have hm := Option.some.inj + (hget.symm.trans lazyFinalRecursorBlockNative) + subst members + simpa [stagedWorld] using world_recursor_block + +def lazyRecursorStep : + LazyCatalogStep env stagedWorld lazyFamilyAfter recursorId.addr where + after := lazyRecursorAfter + found := true + run := lazyRecursorRun + constants := lazyFinalConstants + blocks := lazyFinalBlocks + +def lazyRequests : List Address := [familyId.addr, recursorId.addr] + +def lazyTrace : + LazyCatalogTrace env stagedWorld ({} : AnonEnv) lazyRequests + lazyRecursorAfter := by + exact .cons lazyFamilyStep (.cons lazyRecursorStep (.nil _)) + +/-! ## Serialized dependency binding -/ + +private theorem originalRecursorBlockLookupNative : + recursorIxonEnv.getConst? recursorBlockAddress = + some recursorBlockConstant := by + native_decide + +private theorem originalRecursorProjectionLookupNative : + recursorIxonEnv.getConst? recursorId.addr = + some recursorProjectionConstant := by + native_decide + +private theorem originalFalseProjectionLookupNative : + recursorIxonEnv.getConst? falseId.addr = + some falseProjectionConstant := by + native_decide + +private theorem originalTrueProjectionLookupNative : + recursorIxonEnv.getConst? trueId.addr = + some trueProjectionConstant := by + native_decide + +private theorem originalFamilyBlockLookupNative : + recursorIxonEnv.getConst? familyBlockAddress = + some familyBlockConstant := by + native_decide + +private theorem originalFamilyProjectionLookupNative : + recursorIxonEnv.getConst? familyId.addr = + some familyProjectionConstant := by + native_decide + +/-- Successful lookups in the in-memory source used by E3-S have the exact +same materialized value after serialization and pure decoding. The finite +key classification avoids any appeal to injectivity of content hashes. -/ +private theorem decodedGetConst_of_original {addr : Address} + {constant : Ixon.Constant} + (hget : recursorIxonEnv.getConst? addr = some constant) : + env.getConst? addr = some constant := by + have hraw : ∃ lazy, recursorIxonEnv.consts.get? addr = some lazy := by + have hbind : + (recursorIxonEnv.consts.get? addr).bind + Ixon.LazyConstant.get? = some constant := by + simpa only [Ixon.Env.getConst?] using hget + rw [Option.bind_eq_some_iff] at hbind + obtain ⟨lazy, hstored, _⟩ := hbind + exact ⟨lazy, hstored⟩ + obtain ⟨lazy, hraw⟩ := hraw + have hmem : addr ∈ recursorIxonEnv.consts := + (Std.HashMap.getElem?_eq_some_iff.mp hraw).choose + have hkey : addr ∈ recursorIxonEnv.consts.keys := + Std.HashMap.mem_keys.mpr hmem + rw [BooleanEnumerationFixture.sourceKeys] at hkey + simp at hkey + rcases hkey with rfl | rfl | rfl | rfl | rfl | rfl + · have hc := Option.some.inj + (hget.symm.trans originalRecursorBlockLookupNative) + subst constant + exact recursorBlockEntry.getConst + · have hc := Option.some.inj + (hget.symm.trans originalRecursorProjectionLookupNative) + subst constant + exact recursorProjectionEntry.getConst + · have hc := Option.some.inj + (hget.symm.trans originalFalseProjectionLookupNative) + subst constant + exact falseProjectionEntry.getConst + · have hc := Option.some.inj + (hget.symm.trans originalTrueProjectionLookupNative) + subst constant + exact trueProjectionEntry.getConst + · have hc := Option.some.inj + (hget.symm.trans originalFamilyBlockLookupNative) + subst constant + exact familyBlockEntry.getConst + · have hc := Option.some.inj + (hget.symm.trans originalFamilyProjectionLookupNative) + subst constant + exact familyProjectionEntry.getConst + +/-- Every dependency used by the E3-S Boolean proof is a reference stored in +the corresponding constant recovered from the decoded byte array. -/ +theorem dependencyBound : + SerializedDependencyBound env dependencyGraph := by + intro source target hdependency + obtain ⟨constant, hget, hsemantic⟩ := hdependency + exact ⟨constant, decodedGetConst_of_original hget, + hsemantic.target_mem_refs⟩ + +/-! ## Semantic and production-driver transport -/ + +private theorem finiteAddressSet_eq_of_entries_eq + {left right : FiniteAddressSet} + (h : left.entries = right.entries) : left = right := by + cases left + cases right + cases h + rfl + +theorem subjects_eq : + sourceWF.subjects = BooleanEnumerationFixture.sourceWF.subjects := by + apply finiteAddressSet_eq_of_entries_eq + change (orderedAnonConstAddrs env).toList = + (orderedAnonConstAddrs recursorIxonEnv).toList + rw [sourceAddresses, BooleanEnumerationFixture.sourceAddresses] + +theorem semanticSubjectWF : + SubjectWF stagedWorld dependencyGraph (expectedAnonWork env) + sourceWF.subjects noAssumptions := by + rw [expectedAnonWork_eq, subjects_eq, + ← BooleanEnumerationFixture.expectedAnonWork_eq] + exact BooleanEnumerationFixture.subjectWF + +private theorem checkEnvAnonNative : + checkEnvAnon env checkCfg = .ok successfulResults := by + native_decide + +theorem checkEnvAnon_eq : + checkEnvAnon env checkCfg = .ok successfulResults := + checkEnvAnonNative + +/-! ## Public T0 certificate -/ + +def certificate : + SerializedSubjectCertificate bytes stagedWorld dependencyGraph + noAssumptions lazyRequests where + env := env + input := input + eager := eagerAgreement + lazyAfter := lazyRecursorAfter + lazy := lazyTrace + lazyConstants := lazyFinalConstants + lazyBlocks := lazyFinalBlocks + dependencyBound := dependencyBound + cfg := checkCfg + results := successfulResults + driver := checkEnvAnon_eq + resultsSucceeded := allResultsSucceeded + semantic := semanticSubjectWF + +/-- T0-S: the serialized Boolean environment passes pure decoding, integrity +checks, exact eager and cold-lazy ingress, production checking, dependency +binding, and the existing semantic acceptance theorem. -/ +theorem subjectWF : + SerializedSubjectWF bytes stagedWorld dependencyGraph noAssumptions + lazyRequests := + ⟨certificate⟩ + +end BooleanSerialized +end Ix.Tc diff --git a/Ix/Tc/Verify/Monad.lean b/Ix/Tc/Verify/Monad.lean index a6ba44ed7..b49e3b0a0 100644 --- a/Ix/Tc/Verify/Monad.lean +++ b/Ix/Tc/Verify/Monad.lean @@ -58,6 +58,26 @@ 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⟩ +/-- Expose the invariant already carried by a successful `TcM.WF` result. +This is useful when the next verified action needs to construct semantic +provenance from the intermediate state rather than merely consume the stated +postcondition. -/ +theorem withInv + {I : TcState m → Prop} {s : TcState m} + {x : TcM m alpha} {Q : alpha → TcState m → Prop} + {E : TcError m → TcState m → Prop} + (hx : TcM.WF I s x Q E) : + TcM.WF I s x (fun result after => I after ∧ Q result after) E := by + intro hI + have hpost := hx hI + cases hrun : x s with + | ok result after => + rw [hrun] at hpost + exact ⟨hpost.1, hpost.1, hpost.2⟩ + | error err after => + rw [hrun] at hpost + exact hpost + /-- 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 diff --git a/Ix/Tc/Verify/NatFixture.lean b/Ix/Tc/Verify/NatFixture.lean index 17bdd1a3f..f60fd4209 100644 --- a/Ix/Tc/Verify/NatFixture.lean +++ b/Ix/Tc/Verify/NatFixture.lean @@ -411,6 +411,7 @@ def oracle : InductiveOracle RawProjRel.none catalog nameOf def worldNat : VerifyWorld where catalog := catalog + blocks := BlockCatalog.empty trusted := oracle.TrustBlock venv := natEnv nameOf := nameOf @@ -523,7 +524,7 @@ def worldGood : VerifyWorld where · exact worldNat.trustedCatalogued hold theorem nat_le_good : worldNat ≤ worldGood := by - exact ⟨rfl, rfl, TrustInsert.old, VEnv.addConst_le addGood⟩ + exact ⟨rfl, rfl, rfl, TrustInsert.old, VEnv.addConst_le addGood⟩ theorem trustedCatalogRelGood : TrustedCatalogRel RawProjRel.none worldGood := diff --git a/Ix/Tc/Verify/RecursiveMethods/CallDomains.lean b/Ix/Tc/Verify/RecursiveMethods/CallDomains.lean new file mode 100644 index 000000000..fa8d94d6f --- /dev/null +++ b/Ix/Tc/Verify/RecursiveMethods/CallDomains.lean @@ -0,0 +1,486 @@ +import Ix.Tc.Verify.Knot + +/-! +# Fuel-indexed recursive-method call domains + +`RunSupport` is the finite collision and result footprint of one concrete +checker run. It is not an all-depth method-call domain: successful inference +may construct a value which belongs to the run footprint without recursively +calling inference on that value at the same fuel depth. + +This module separates those roles. `Methods.CallDomain` records which calls +are admitted at one method-table depth, while `Methods.WFAtOn` retains one +fixed finite `RunSupport` for state, collision, cache, and successful-result +facts. A `CallScheduleAt` supplies a distinct domain for each finite +`methodsN` layer. Its induction theorem follows the production table exactly +and never asks one domain to be closed under arbitrarily many layers. + +The old `Methods.WFAt` contract remains available during migration. The +conversion theorems below identify it with the special case whose call domain +is the entire run support; `FiniteSupportBoundary` proves why that special case +cannot be the final public interface for sort-producing runs. +-/ + +namespace Ix.Tc + +namespace Methods + +/-- Calls admitted at one remaining-recursion-fuel depth. The policy +arguments are retained because the production table exposes them as distinct +back-edges. -/ +structure CallDomain where + whnf : KExpr .anon → Prop + whnfCore : KExpr .anon → Prop + whnfMode : KExpr .anon → NatSuccMode → Prop + whnfCoreFlags : KExpr .anon → WhnfFlags → Prop + infer : KExpr .anon → Prop + isDefEq : KExpr .anon → KExpr .anon → Prop + +namespace CallDomain + +/-- No recursive calls are admitted. -/ +def empty : CallDomain where + whnf := fun _ => False + whnfCore := fun _ => False + whnfMode := fun _ _ => False + whnfCoreFlags := fun _ _ => False + infer := fun _ => False + isDefEq := fun _ _ => False + +/-- Admit only inference calls satisfying `admitted`; every other method +field is empty. This is useful for exact syntax-directed leaves which make +no recursive callbacks. -/ +def inferOnly (admitted : KExpr .anon → Prop) : CallDomain where + whnf := fun _ => False + whnfCore := fun _ => False + whnfMode := fun _ _ => False + whnfCoreFlags := fun _ _ => False + infer := admitted + isDefEq := fun _ _ => False + +/-- The one-source inference domain. -/ +def singletonInfer (source : KExpr .anon) : CallDomain := + inferOnly (fun candidate => candidate = source) + +/-- The legacy same-support domain, useful only as a migration adapter. -/ +def support (scope : RunSupport) : CallDomain where + whnf := scope + whnfCore := scope + whnfMode := fun source _ => scope source + whnfCoreFlags := fun source _ => scope source + infer := scope + isDefEq := fun left right => scope left ∧ scope right + +/-- Every admitted input lies in the finite run footprint. -/ +structure Within (calls : CallDomain) (scope : RunSupport) : Prop where + whnf : ∀ {source}, calls.whnf source → scope source + whnfCore : ∀ {source}, calls.whnfCore source → scope source + whnfMode : ∀ {source mode}, calls.whnfMode source mode → scope source + whnfCoreFlags : ∀ {source flags}, + calls.whnfCoreFlags source flags → scope source + infer : ∀ {source}, calls.infer source → scope source + isDefEq : ∀ {left right}, + calls.isDefEq left right → scope left ∧ scope right + +theorem support_within (scope : RunSupport) : + (support scope).Within scope where + whnf h := h + whnfCore h := h + whnfMode h := h + whnfCoreFlags h := h + infer h := h + isDefEq h := h + +theorem empty_within (scope : RunSupport) : empty.Within scope where + whnf h := False.elim h + whnfCore h := False.elim h + whnfMode h := False.elim h + whnfCoreFlags h := False.elim h + infer h := False.elim h + isDefEq h := False.elim h + +theorem inferOnly_within {admitted : KExpr .anon → Prop} + {scope : RunSupport} + (hwithin : ∀ {source}, admitted source → scope source) : + (inferOnly admitted).Within scope where + whnf h := False.elim h + whnfCore h := False.elim h + whnfMode h := False.elim h + whnfCoreFlags h := False.elim h + infer h := hwithin h + isDefEq h := False.elim h + +theorem singletonInfer_within {source : KExpr .anon} {scope : RunSupport} + (hsource : scope source) : (singletonInfer source).Within scope := + inferOnly_within fun h => h ▸ hsource + +end CallDomain + +/-- Six-field semantic contract restricted to the calls admitted at one +finite table depth. Successful syntax-producing methods still return values +inside the shared finite run footprint. -/ +structure WFAtOn (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (scope : RunSupport) + (uvars : Nat) (calls : CallDomain) (methods : Methods .anon) : Prop where + within : calls.Within scope + whnf : ∀ {Delta s source sourceV}, + calls.whnf source → + TrKExprS world.venv uvars world.nameOf trProj Delta source sourceV → + TcM.WF (WhnfStateInv layer semantics trProj world scope uvars Delta) s + (methods.whnf source) + (fun result _ => scope result ∧ + WhnfPost trProj world uvars Delta sourceV result) + whnfCore : ∀ {Delta s source sourceV}, + calls.whnfCore source → + TrKExprS world.venv uvars world.nameOf trProj Delta source sourceV → + TcM.WF (WhnfStateInv layer semantics trProj world scope uvars Delta) s + (methods.whnfCore source) + (fun result _ => scope result ∧ + WhnfPost trProj world uvars Delta sourceV result) + whnfMode : ∀ {Delta s source sourceV} {mode : NatSuccMode}, + calls.whnfMode source mode → + TrKExprS world.venv uvars world.nameOf trProj Delta source sourceV → + TcM.WF (WhnfStateInv layer semantics trProj world scope uvars Delta) s + (methods.whnfMode source mode) + (fun result _ => scope result ∧ + WhnfPost trProj world uvars Delta sourceV result) + whnfCoreFlags : ∀ {Delta s source sourceV} {flags : WhnfFlags}, + calls.whnfCoreFlags source flags → + TrKExprS world.venv uvars world.nameOf trProj Delta source sourceV → + TcM.WF (WhnfStateInv layer semantics trProj world scope uvars Delta) s + (methods.whnfCoreFlags source flags) + (fun result _ => scope result ∧ + WhnfPost trProj world uvars Delta sourceV result) + infer : ∀ {Delta s source sourceV}, + calls.infer source → + TrKExprS world.venv uvars world.nameOf trProj Delta source sourceV → + TcM.WF (WhnfStateInv layer semantics trProj world scope uvars Delta) s + (methods.infer source) + (fun ty _ => scope ty ∧ + InferPost trProj world uvars Delta sourceV ty) + isDefEq : ∀ {Delta s left right leftV rightV}, + calls.isDefEq left right → + TrKExprS world.venv uvars world.nameOf trProj Delta left leftV → + TrKExprS world.venv uvars world.nameOf trProj Delta right rightV → + TcM.WF (WhnfStateInv layer semantics trProj world scope uvars Delta) s + (methods.isDefEq left right) + (fun answer _ => answer = true → + world.venv.IsDefEqU uvars Delta.toCtx leftV rightV) + +namespace WFAtOn + +/-- Every legacy same-support contract is a call-domain contract over the +entire support. -/ +theorem ofWFAt + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {uvars : Nat} {methods : Methods .anon} + (contract : Methods.WFAt layer semantics trProj world scope uvars + methods) : + Methods.WFAtOn layer semantics trProj world scope uvars + (.support scope) methods where + within := CallDomain.support_within scope + whnf hcall htr := contract.whnf hcall htr + whnfCore hcall htr := contract.whnfCore hcall htr + whnfMode hcall htr := contract.whnfMode hcall htr + whnfCoreFlags hcall htr := contract.whnfCoreFlags hcall htr + infer hcall htr := contract.infer hcall htr + isDefEq hcall hleft hright := + contract.isDefEq hcall.1 hcall.2 hleft hright + +/-- Conversely, the full-support call domain recovers the legacy contract. -/ +theorem toWFAt + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {uvars : Nat} {methods : Methods .anon} + (contract : Methods.WFAtOn layer semantics trProj world scope uvars + (.support scope) methods) : + Methods.WFAt layer semantics trProj world scope uvars methods where + whnf hsource htr := contract.whnf hsource htr + whnfCore hsource htr := contract.whnfCore hsource htr + whnfMode hsource htr := contract.whnfMode hsource htr + whnfCoreFlags hsource htr := contract.whnfCoreFlags hsource htr + infer hsource htr := contract.infer hsource htr + isDefEq hleft hright hleftTr hrightTr := + contract.isDefEq ⟨hleft, hright⟩ hleftTr hrightTr + +end WFAtOn + +/-- The exhausted table satisfies any finite call domain because every field +throws `maxRecFuel` without changing state. -/ +theorem methodsOut_wfAtOn + (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (scope : RunSupport) + (uvars : Nat) (calls : CallDomain) (within : calls.Within scope) : + Methods.WFAtOn layer semantics trProj world scope uvars calls + (methodsOut : Methods .anon) where + within := within + whnf _ _ := TcM.WF.throw (fun _ => trivial) + whnfCore _ _ := TcM.WF.throw (fun _ => trivial) + whnfMode _ _ := TcM.WF.throw (fun _ => trivial) + whnfCoreFlags _ _ := TcM.WF.throw (fun _ => trivial) + infer _ _ := TcM.WF.throw (fun _ => trivial) + isDefEq _ _ _ := TcM.WF.throw (fun _ => trivial) + +/-- One exact, possibly domain-changing induction step for the production +method table. -/ +def StepWFAtOn (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (scope : RunSupport) + (uvars : Nat) (before after : CallDomain) : Prop := + ∀ methods, + Methods.WFAtOn layer semantics trProj world scope uvars before methods → + Methods.WFAtOn layer semantics trProj world scope uvars after + (Methods.next methods) + +/-- A finite call-domain schedule for `methodsN depth`. Index zero belongs +to `methodsOut`; index `n+1` describes calls into the `n+1`-layer table and +may route its recursive back-edges only into index `n`. -/ +structure CallScheduleAt (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (scope : RunSupport) + (uvars : Nat) (calls : Nat → CallDomain) (depth : Nat) : Prop where + within : ∀ n, n ≤ depth → (calls n).Within scope + step : ∀ n, n < depth → + StepWFAtOn layer semantics trProj world scope uvars + (calls n) (calls (n + 1)) + +namespace CallScheduleAt + +/-- A finite schedule closes exactly the corresponding finite production +approximation—there is no quantification over greater fuel depths. -/ +theorem methodsN + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {uvars : Nat} {calls : Nat → CallDomain} {depth : Nat} + (schedule : CallScheduleAt layer semantics trProj world scope uvars + calls depth) : + ∀ n, n ≤ depth → + Methods.WFAtOn layer semantics trProj world scope uvars (calls n) + (Ix.Tc.methodsN (m := .anon) n) + | 0, _ => + methodsOut_wfAtOn layer semantics trProj world scope uvars (calls 0) + (schedule.within 0 (Nat.zero_le depth)) + | n + 1, hn => by + rw [Methods.methodsN_succ] + exact schedule.step n (Nat.lt_of_succ_le hn) + (Ix.Tc.methodsN (m := .anon) n) + (schedule.methodsN n (Nat.le_trans (Nat.le_succ n) hn)) + +/-- The contract selected at the schedule's terminal depth. -/ +theorem selected + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {uvars : Nat} {calls : Nat → CallDomain} {depth : Nat} + (schedule : CallScheduleAt layer semantics trProj world scope uvars + calls depth) : + Methods.WFAtOn layer semantics trProj world scope uvars (calls depth) + (Ix.Tc.methodsN (m := .anon) depth) := + schedule.methodsN depth (Nat.le_refl depth) + +/-- The method body executed by `TcM.runRec` sits one layer above its +`methodsN depth` callback table. A schedule through `depth + 1` therefore +supplies the exact contract for the public body, with no off-by-one appeal to +an all-depth closure. -/ +theorem nextSelected + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {uvars : Nat} {calls : Nat → CallDomain} {depth : Nat} + (schedule : CallScheduleAt layer semantics trProj world scope uvars + calls (depth + 1)) : + Methods.WFAtOn layer semantics trProj world scope uvars + (calls (depth + 1)) + (Methods.next (Ix.Tc.methodsN (m := .anon) depth)) := + schedule.step depth (Nat.lt_succ_self depth) + (Ix.Tc.methodsN (m := .anon) depth) + (schedule.methodsN depth (Nat.le_succ depth)) + +end CallScheduleAt + +end Methods + +namespace RecM + +/-- A reader action whose execution does not inspect the recursive method +table. Constructor-local leaf branches often satisfy this even though their +uniform dispatcher theorem is stated in `RecM`. -/ +def MethodIndependent (action : RecM .anon alpha) : Prop := + ∀ methods : Methods .anon, + action.run methods = action.run (methodsOut : Methods .anon) + +/-- Reader-level Hoare triple under one explicit method-call domain. -/ +def WFOn (layer : WhnfLayer) (semantics : CacheSemantics) + (trProj : RawProjRel) (world : VerifyWorld) (scope : RunSupport) + (uvars : Nat) (calls : Methods.CallDomain) (Delta : KVLCtx) + (s : TcState .anon) (action : RecM .anon alpha) + (Q : alpha → TcState .anon → Prop) + (E : TcError .anon → TcState .anon → Prop := fun _ _ => True) : Prop := + ∀ methods, + Methods.WFAtOn layer semantics trProj world scope uvars calls methods → + TcM.WF (WhnfStateInv layer semantics trProj world scope uvars Delta) s + (action.run methods) Q E + +namespace WFOn + +/-- Reuse an existing same-support proof for a method-independent action. +The old contract is needed only for the exhausted table chosen as a proof +witness; execution is then transported to the caller's actual bounded table. -/ +theorem ofWF_of_methodIndependent + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {uvars : Nat} {calls : Methods.CallDomain} {Delta : KVLCtx} + {s : TcState .anon} {action : RecM .anon alpha} + {Q : alpha → TcState .anon → Prop} + {E : TcError .anon → TcState .anon → Prop} + (hindependent : MethodIndependent action) + (h : RecM.WF layer semantics trProj world scope uvars Delta s + action Q E) : + RecM.WFOn layer semantics trProj world scope uvars calls Delta s + action Q E := by + intro methods contract + rw [hindependent methods] + exact h (methodsOut : Methods .anon) + (Methods.methodsOut_wfAt layer semantics trProj world scope uvars) + +theorem pure + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {uvars : Nat} {calls : Methods.CallDomain} {Delta : KVLCtx} + {s : TcState .anon} {Q : alpha → TcState .anon → Prop} + {E : TcError .anon → TcState .anon → Prop} {value : alpha} + (h : WhnfStateInv layer semantics trProj world scope uvars Delta s → + Q value s) : + RecM.WFOn layer semantics trProj world scope uvars calls Delta s + (pure value) Q E := by + intro methods contract + exact TcM.WF.pure h + +theorem throw + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {uvars : Nat} {calls : Methods.CallDomain} {Delta : KVLCtx} + {s : TcState .anon} {Q : alpha → TcState .anon → Prop} + {E : TcError .anon → TcState .anon → Prop} {err : TcError .anon} + (h : WhnfStateInv layer semantics trProj world scope uvars Delta s → + E err s) : + RecM.WFOn layer semantics trProj world scope uvars calls Delta s + (throw err) Q E := by + intro methods contract + exact TcM.WF.throw h + +theorem mono + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {uvars : Nat} {calls : Methods.CallDomain} {Delta : KVLCtx} + {s : TcState .anon} {action : RecM .anon alpha} + {Q Q' : alpha → TcState .anon → Prop} + {E E' : TcError .anon → TcState .anon → Prop} + (h : RecM.WFOn layer semantics trProj world scope uvars calls Delta s + action Q E) + (hQ : ∀ value after, Q value after → Q' value after) + (hE : ∀ err after, E err after → E' err after) : + RecM.WFOn layer semantics trProj world scope uvars calls Delta s + action Q' E' := by + intro methods contract + exact TcM.WF.mono (h methods contract) hQ hE + +/-- Expose invariant preservation in the success postcondition. -/ +theorem withInv + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {uvars : Nat} {calls : Methods.CallDomain} {Delta : KVLCtx} + {s : TcState .anon} {action : RecM .anon alpha} + {Q : alpha → TcState .anon → Prop} + {E : TcError .anon → TcState .anon → Prop} + (h : RecM.WFOn layer semantics trProj world scope uvars calls Delta s + action Q E) : + RecM.WFOn layer semantics trProj world scope uvars calls Delta s action + (fun value after => + WhnfStateInv layer semantics trProj world scope uvars Delta after ∧ + Q value after) + E := by + intro methods contract hI + have hpost := h methods contract hI + match hrun : action.run methods s with + | .ok value after => + rw [hrun] at hpost + exact ⟨hpost.1, hpost.1, hpost.2⟩ + | .error err after => + rw [hrun] at hpost + exact hpost + +theorem bind + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {uvars : Nat} {calls : Methods.CallDomain} {Delta : KVLCtx} + {s : TcState .anon} {action : RecM .anon alpha} + {next : alpha → RecM .anon beta} + {Q1 : alpha → TcState .anon → Prop} + {Q2 : beta → TcState .anon → Prop} + {E : TcError .anon → TcState .anon → Prop} + (haction : RecM.WFOn layer semantics trProj world scope uvars calls + Delta s action Q1 E) + (hnext : ∀ value after, Q1 value after → + RecM.WFOn layer semantics trProj world scope uvars calls Delta after + (next value) Q2 E) : + RecM.WFOn layer semantics trProj world scope uvars calls Delta s + (action >>= next) Q2 E := by + intro methods contract + exact TcM.WF.bind (haction methods contract) fun value after hvalue => + hnext value after hvalue methods contract + +theorem liftTcM + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {uvars : Nat} {calls : Methods.CallDomain} {Delta : KVLCtx} + {s : TcState .anon} {action : TcM .anon alpha} + {Q : alpha → TcState .anon → Prop} + {E : TcError .anon → TcState .anon → Prop} + (h : TcM.WF + (WhnfStateInv layer semantics trProj world scope uvars Delta) s + action Q E) : + RecM.WFOn layer semantics trProj world scope uvars calls Delta s + (liftM action) Q E := by + intro methods contract + exact h + +/-- Reader-level state observation is independent of the callback table. -/ +theorem get + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {uvars : Nat} {calls : Methods.CallDomain} {Delta : KVLCtx} + {s : TcState .anon} + {Q : TcState .anon → TcState .anon → Prop} + {E : TcError .anon → TcState .anon → Prop} + (h : WhnfStateInv layer semantics trProj world scope uvars Delta s → + Q s s) : + RecM.WFOn layer semantics trProj world scope uvars calls Delta s + (get : RecM .anon (TcState .anon)) Q E := by + intro methods contract + exact TcM.WF.get h + +end WFOn + +end RecM + +namespace TcM + +/-- Apply a reader proof to the exact finite table selected by a call-domain +schedule. -/ +theorem runRec_wfAtOn + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {uvars : Nat} {calls : Nat → Methods.CallDomain} + {Delta : KVLCtx} {s : TcState .anon} {action : RecM .anon alpha} + {Q : alpha → TcState .anon → Prop} + {E : TcError .anon → TcState .anon → Prop} + (schedule : Methods.CallScheduleAt layer semantics trProj world scope + uvars calls s.recFuel.toNat) + (haction : RecM.WFOn layer semantics trProj world scope uvars + (calls s.recFuel.toNat) Delta s action Q E) : + TcM.WF (WhnfStateInv layer semantics trProj world scope uvars Delta) s + (TcM.runRec action) Q E := by + simpa [TcM.runRec] using + haction (Ix.Tc.methodsN (m := .anon) s.recFuel.toNat) schedule.selected + +end TcM + +end Ix.Tc diff --git a/Ix/Tc/Verify/RecursiveMethods/FiniteSupportBoundary.lean b/Ix/Tc/Verify/RecursiveMethods/FiniteSupportBoundary.lean new file mode 100644 index 000000000..23322321a --- /dev/null +++ b/Ix/Tc/Verify/RecursiveMethods/FiniteSupportBoundary.lean @@ -0,0 +1,96 @@ +import Ix.Tc.Verify.Infer.Dispatcher + +/-! +# Finite-support boundary for recursive inference + +`RunSupport` deliberately describes the finite set of expressions whose +content addresses are observed by one concrete checker run. It must not also +be used as an all-depth recursive call domain. + +The distinction is already forced by sort inference. If one finite support +contains `sort u` and is closed under every successful sort-inference result, +then it contains `sort (succ^[n] u)` for every `n`. Their universe syntax +sizes are unbounded, contradicting finiteness. The theorems below make that +interface failure explicit so a recursive-method closure cannot accidentally +hide it behind an uninhabitable premise. +-/ + +namespace Ix.Tc + +namespace FiniteSupportBoundary + +/-- Iterate the production universe-successor constructor. -/ +private def iterSucc (u : KUniv .anon) : Nat → KUniv .anon + | 0 => u + | n + 1 => KUniv.mkSucc (iterSucc u n) + +private theorem iterSucc_size (u : KUniv .anon) (n : Nat) : + (iterSucc u n).size = u.size + n := by + induction n with + | zero => rfl + | succ n ih => + simp only [iterSucc, KUniv.mkSucc, KUniv.size, ih] + omega + +/-- A measure that observes precisely the universe carried by a sort. -/ +private def sortLevelSize : KExpr .anon → Nat + | .sort u _ => u.size + | _ => 0 + +/-- A simple upper bound for all sort-level sizes in a concrete list. -/ +private def sortLevelBound : List (KExpr .anon) → Nat + | [] => 0 + | e :: es => max (sortLevelSize e) (sortLevelBound es) + +private theorem sortLevelSize_le_bound_of_mem + {e : KExpr .anon} {es : List (KExpr .anon)} (h : e ∈ es) : + sortLevelSize e ≤ sortLevelBound es := by + induction es with + | nil => simp at h + | cons head tail ih => + rcases List.mem_cons.mp h with rfl | htail + · exact Nat.le_max_left .. + · exact Nat.le_trans (ih htail) (Nat.le_max_right ..) + +private theorem iterSucc_supported + (support : RunSupport) + (closed : ∀ {u : KUniv .anon} {info : ExprInfo .anon}, + support (.sort u info) → support (KExpr.mkSort (KUniv.mkSucc u))) + {u : KUniv .anon} (seed : support (KExpr.mkSort u)) (n : Nat) : + support (KExpr.mkSort (iterSucc u n)) := by + induction n with + | zero => exact seed + | succ n ih => + rw [KExpr.mkSort_shape (iterSucc u n) ()] at ih + exact closed ih + +/-- No finite run support containing a sort can be closed under arbitrarily +many applications of the production sort-inference result operation. -/ +theorem no_finite_sort_successor_closure + (support : RunSupport) + (closed : ∀ {u : KUniv .anon} {info : ExprInfo .anon}, + support (.sort u info) → support (KExpr.mkSort (KUniv.mkSucc u))) + {u : KUniv .anon} (seed : support (KExpr.mkSort u)) : False := by + obtain ⟨es, hes⟩ := support.exprFinite + let n := sortLevelBound es + 1 + have hsupported : support (KExpr.mkSort (iterSucc u n)) := + iterSucc_supported support closed seed n + have hmem : KExpr.mkSort (iterSucc u n) ∈ es := hes hsupported + have hbounded := sortLevelSize_le_bound_of_mem hmem + rw [KExpr.mkSort_shape (iterSucc u n) ()] at hbounded + change (iterSucc u n).size ≤ sortLevelBound es at hbounded + rw [iterSucc_size] at hbounded + dsimp [n] at hbounded + omega + +/-- The current all-depth syntax-inference resource is therefore +uninhabitable for every finite run support that contains a sort source. -/ +theorem SyntaxInferenceResources.no_sort_source + {support : RunSupport} (resources : SyntaxInferenceResources support) + {u : KUniv .anon} : ¬ support (KExpr.mkSort u) := by + intro seed + exact no_finite_sort_successor_closure support resources.sortResult seed + +end FiniteSupportBoundary + +end Ix.Tc diff --git a/Ix/Tc/Verify/RecursiveMethods/Inference.lean b/Ix/Tc/Verify/RecursiveMethods/Inference.lean new file mode 100644 index 000000000..de267c004 --- /dev/null +++ b/Ix/Tc/Verify/RecursiveMethods/Inference.lean @@ -0,0 +1,263 @@ +import Ix.Tc.Verify.Infer.CacheSoundness +import Ix.Tc.Verify.RecursiveMethods.CallDomains + +/-! +# Call-domain inference layer + +This is the first production layer migrated from the legacy same-support +closure. Cache behavior still uses one finite `RunSupport`, but uncached +dispatch is required only for sources admitted by the current inference call +domain. Recursive callbacks inside that dispatch are proved against the +strictly smaller table's domain. + +The cache shell is intentionally reproduced at this more precise interface +rather than recovered from `UncachedInference.Context`: that older context +contains the all-support `SyntaxInferenceResources` field whose sort clause is +provably uninhabitable for any finite support containing a sort. +-/ + +namespace Ix.Tc + +/-- Per-layer resources for production inference. `current` guards only the +outer calls proved at this layer; `predecessor` governs recursive back-edges +made by `inferUncached`. -/ +structure InferenceCallDomainContext + {trProj : RawProjRel} {world : VerifyWorld} (scope : RunSupport) + (model : KernelSuffixModel trProj world) + (current predecessor : Methods.CallDomain) : Type where + collisionFree : scope.CollisionFree + currentWithin : current.Within scope + theory : WhnfTheory trProj world model.keys.uvars + references : RecM.TrustedReferences world scope + uncached : ∀ {Delta : KVLCtx} {s : TcState .anon} {inferOnly : Bool} + {source : KExpr .anon} {sourceV : Lean4Lean.VExpr}, + current.infer source → + TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta source + sourceV → + RecM.WFOn .noAccel (kernelCacheSemantics model.keys trProj) trProj world + scope model.keys.uvars predecessor Delta s + (RecM.inferUncached RecM.inferCall inferOnly source) + (fun result _ => scope result ∧ + InferPost trProj world model.keys.uvars Delta sourceV result) + +namespace InferenceCallDomainContext + +private theorem cacheReferences + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {model : KernelSuffixModel trProj world} + {current predecessor : Methods.CallDomain} + (context : InferenceCallDomainContext scope model current predecessor) + {kind : ExprCacheKind} {key : Address × Address} + {ty : KExpr .anon} (hty : scope ty) : + (CacheEntry.expr kind key ty).ReferencesAuthorized + (CacheAuthority.stable world) scope := by + intro id href + apply Or.inl + rcases href with href | href + · obtain ⟨source, hsource, _, hreference⟩ := href + exact context.references hsource hreference + · exact context.references hty href + +private theorem cacheWriteFull_wfOn + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {model : KernelSuffixModel trProj world} + {predecessor : Methods.CallDomain} {Delta : KVLCtx} + {s : TcState .anon} {key : Address × Address} {ty : KExpr .anon} + (hnew : CacheProvenance (kernelCacheSemantics model.keys trProj) + (CacheAuthority.stable world) scope (.expr .infer key ty)) : + RecM.WFOn .noAccel (kernelCacheSemantics model.keys trProj) trProj world + scope model.keys.uvars predecessor Delta s + (RecM.cacheInferResult false key ty) (fun _ _ => True) := by + apply RecM.WFOn.ofWF_of_methodIndependent + · intro methods + funext state + rfl + · exact RecM.cacheInferResult_full_wf hnew + +private theorem cacheWriteInferOnly_wfOn + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {model : KernelSuffixModel trProj world} + {predecessor : Methods.CallDomain} {Delta : KVLCtx} + {s : TcState .anon} {key : Address × Address} {ty : KExpr .anon} + (hnew : CacheProvenance (kernelCacheSemantics model.keys trProj) + (CacheAuthority.stable world) scope (.expr .inferOnly key ty)) : + RecM.WFOn .noAccel (kernelCacheSemantics model.keys trProj) trProj world + scope model.keys.uvars predecessor Delta s + (RecM.cacheInferResult true key ty) (fun _ _ => True) := by + apply RecM.WFOn.ofWF_of_methodIndependent + · intro methods + funext state + rfl + · exact RecM.cacheInferResult_inferOnly_wf hnew + +/-- Execute one admitted uncached source and install its result in the cache +partition selected at entry. -/ +private theorem missTail_wfOn + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {model : KernelSuffixModel trProj world} + {current predecessor : Methods.CallDomain} + (context : InferenceCallDomainContext scope model current predecessor) + {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) + (hcall : current.infer source) + (hsource : TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta + source sourceV) : + RecM.WFOn .noAccel (kernelCacheSemantics model.keys trProj) trProj world + scope model.keys.uvars predecessor Delta s + (do + let ty ← RecM.inferUncached RecM.inferCall inferOnly source + RecM.cacheInferResult inferOnly key ty + pure ty) + (fun result _ => scope result ∧ + InferPost trProj world model.keys.uvars Delta sourceV result) := by + have hsourceSupport := context.currentWithin.infer hcall + cases inferOnly with + | false => + apply RecM.WFOn.bind + (RecM.WFOn.withInv (context.uncached hcall hsource)) + intro ty afterBody hbody + rcases hbody with ⟨_, hty, hpost⟩ + have hprovenance := model.inferProvenance + context.collisionFree .infer hsourceSupport hty hmatch + (InferMeaning.of_post hsource hpost) + (context.cacheReferences hty) + apply RecM.WFOn.bind + (Q1 := fun _ _ => True) + (cacheWriteFull_wfOn (predecessor := predecessor) hprovenance) + intro _ afterWrite _ + exact RecM.WFOn.pure fun _ => ⟨hty, hpost⟩ + | true => + apply RecM.WFOn.bind + (RecM.WFOn.withInv (context.uncached hcall hsource)) + intro ty afterBody hbody + rcases hbody with ⟨_, hty, hpost⟩ + have hprovenance := model.inferProvenance + context.collisionFree .inferOnly hsourceSupport hty hmatch + (InferMeaning.of_post hsource hpost) + (context.cacheReferences hty) + apply RecM.WFOn.bind + (Q1 := fun _ _ => True) + (cacheWriteInferOnly_wfOn (predecessor := predecessor) hprovenance) + intro _ afterWrite _ + exact RecM.WFOn.pure fun _ => ⟨hty, hpost⟩ + +/-- Production `inferWith` over one admitted source. Cache hits use the +shared finite cache semantics; only a genuine miss consumes the guarded +uncached proof. -/ +theorem inferWith_wfOn + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {model : KernelSuffixModel trProj world} + {current predecessor : Methods.CallDomain} + (context : InferenceCallDomainContext scope model current predecessor) + {Delta : KVLCtx} {s : TcState .anon} + {source : KExpr .anon} {sourceV : Lean4Lean.VExpr} + (hcall : current.infer source) + (hsource : TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta + source sourceV) : + RecM.WFOn .noAccel (kernelCacheSemantics model.keys trProj) trProj world + scope model.keys.uvars predecessor Delta s + (RecM.inferWith RecM.inferCall source) + (fun result _ => scope result ∧ + InferPost trProj world model.keys.uvars Delta sourceV result) := by + have hsourceSupport := context.currentWithin.infer hcall + unfold RecM.inferWith + apply RecM.WFOn.bind + (Q1 := fun observed after => observed = s ∧ after = s) + (RecM.WFOn.get fun _ => ⟨rfl, rfl⟩) + intro observed after hread + rcases hread with ⟨hObserved, hAfter⟩ + subst observed + subst after + apply RecM.WFOn.bind + (Q1 := fun key _ => + model.keys.Matches trProj world s Delta source key) + · apply RecM.WFOn.liftTcM + exact TcM.WF.mono (TcM.inferKey_model_matches_wf model) + (fun _ _ h => h.1) (fun _ _ h => h) + · intro key afterKey hmatch + apply RecM.WFOn.bind + (Q1 := fun currentState after => + currentState = afterKey ∧ after = afterKey) + (RecM.WFOn.get fun _ => ⟨rfl, rfl⟩) + intro currentState afterRead hread + rcases hread with ⟨hCurrent, hAfterRead⟩ + subst currentState + 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.WFOn.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.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_wfOn hmatch hcall hsource + | true => + simp only [pure_bind, if_true] + apply RecM.WFOn.bind + (Q1 := fun currentState after => + currentState = afterKey ∧ after = afterKey) + (RecM.WFOn.get fun _ => ⟨rfl, rfl⟩) + intro currentState afterInferOnlyRead hread + rcases hread with ⟨hCurrent, hAfterRead⟩ + subst currentState + 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.WFOn.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.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_wfOn hmatch hcall hsource + +/-- The exact inference field of `Methods.next predecessorMethods`. -/ +theorem nextInfer_wfAtOn + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {model : KernelSuffixModel trProj world} + {current predecessor : Methods.CallDomain} + (context : InferenceCallDomainContext scope model current predecessor) + (predecessorMethods : Methods .anon) + (predecessorWF : Methods.WFAtOn .noAccel + (kernelCacheSemantics model.keys trProj) trProj world scope + model.keys.uvars predecessor predecessorMethods) : + ∀ {Delta : KVLCtx} {s : TcState .anon} + {source : KExpr .anon} {sourceV : Lean4Lean.VExpr}, + current.infer source → + TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta source + sourceV → + TcM.WF + (WhnfStateInv .noAccel (kernelCacheSemantics model.keys trProj) + trProj world scope model.keys.uvars Delta) s + ((Methods.next predecessorMethods).infer source) + (fun result _ => scope result ∧ + InferPost trProj world model.keys.uvars Delta sourceV result) := by + intro Delta s source sourceV hcall hsource + simpa [Methods.next, RecM.infer] using + (context.inferWith_wfOn hcall hsource) predecessorMethods predecessorWF + +end InferenceCallDomainContext + +end Ix.Tc diff --git a/Ix/Tc/Verify/RecursiveMethods/Public.lean b/Ix/Tc/Verify/RecursiveMethods/Public.lean new file mode 100644 index 000000000..3987fdaa9 --- /dev/null +++ b/Ix/Tc/Verify/RecursiveMethods/Public.lean @@ -0,0 +1,221 @@ +import Ix.Tc.Verify.RecursiveMethods.CallDomains +import Ix.Tc.Verify.RecursiveMethods.Closure +import Ix.Tc.Verify.RecursiveMethods.ScopedCallDomains + +/-! +# Public recursive-method soundness over run-scoped bounded call domains + +The production entry points execute one method body over the finite callback +table selected by the caller's `recFuel`. Their proof certificate therefore +contains call domains only through `recFuel + 1`: depths through `recFuel` +justify the callback table, and the final successor layer justifies the outer +body itself. + +`RunSupport` remains the finite collision, cache, state, and result footprint +of the concrete run. It is deliberately not reused as the input domain of +every recursive method at every depth. This separation is what permits a +finite run to infer a sort and return its successor sort without demanding an +infinite successor-sort closure. +-/ + +namespace Ix.Tc + +/-- Legacy globally quantified evidence for one public recursive-method run. +New public roots consume `ScopedRecursiveMethodRunContext` below. This type +remains only so already-proved global-model clients can migrate separately. + +`calls n` +describes only method calls possible at table depth `n`; `support` separately +describes all syntax values whose addresses/results occur during the run. -/ +structure RecursiveMethodRunContext + {alpha : Type} (initial : TcState .anon) (program : TcM .anon alpha) + (requests : List WalkerRequest) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) where + run : RunAssumptions initial program requests support + proposition : PropositionClassifierContext trProj world support + calls : Nat → Methods.CallDomain + schedule : Methods.CallScheduleAt .noAccel + (kernelCacheSemantics proposition.model.keys trProj) + trProj world support proposition.model.keys.uvars calls + (initial.recFuel.toNat + 1) + +namespace RecursiveMethodRunContext + +/-- The exact invariant shared by the bounded public adapters. -/ +def Inv + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (context : RecursiveMethodRunContext initial program requests trProj + world support) (Delta : KVLCtx) : TcState .anon → Prop := + WhnfStateInv .noAccel + (kernelCacheSemantics context.proposition.model.keys trProj) + trProj world support context.proposition.model.keys.uvars Delta + +end RecursiveMethodRunContext + +/-- Complete finite-run evidence for one public recursive-method entry. The +method schedule preserves the concrete state-domain witness carried by the +run-scoped suffix model at every success and partial-error transition. -/ +structure ScopedRecursiveMethodRunContext + {alpha : Type} (initial : TcState .anon) (program : TcM .anon alpha) + (requests : List WalkerRequest) (trProj : RawProjRel) + (world : VerifyWorld) (support : RunSupport) where + run : RunAssumptions initial program requests support + model : ScopedKernelSuffixModel trProj world + calls : Nat → Methods.CallDomain + schedule : Methods.ScopedCallScheduleAt model .noAccel + (kernelCacheSemantics model.keys trProj) support calls + (initial.recFuel.toNat + 1) + +namespace ScopedRecursiveMethodRunContext + +/-- The checker invariant and finite suffix-state domain shared by all three +public recursive adapters. -/ +def Inv + {alpha : Type} {initial : TcState .anon} {program : TcM .anon alpha} + {requests : List WalkerRequest} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (context : ScopedRecursiveMethodRunContext initial program requests + trProj world support) (Delta : KVLCtx) : TcState .anon → Prop := + ScopedWhnfStateInv context.model .noAccel + (kernelCacheSemantics context.model.keys trProj) support Delta + +end ScopedRecursiveMethodRunContext + +namespace TcM.whnf + +/-- Public full-WHNF soundness from the exact finite successor-layer call +domain used by this run. -/ +theorem wf_legacy + {initial : TcState .anon} {e : KExpr .anon} + {requests : List WalkerRequest} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (context : RecursiveMethodRunContext initial (TcM.whnf e) requests + trProj world support) + {Delta : KVLCtx} {sourceV : Lean4Lean.VExpr} + (hcall : (context.calls (initial.recFuel.toNat + 1)).whnf e) + (hsource : TrKExprS world.venv + context.proposition.model.keys.uvars world.nameOf trProj Delta e + sourceV) : + TcM.WF (context.Inv Delta) initial (TcM.whnf e) + (fun result _ => support result ∧ + WhnfPost trProj world context.proposition.model.keys.uvars Delta + sourceV result) := by + have hnext := context.schedule.nextSelected + simpa [TcM.whnf, TcM.runRec, Methods.next] using + hnext.whnf hcall hsource + +/-- Public full-WHNF soundness over one finite suffix-state domain. -/ +theorem wf + {initial : TcState .anon} {e : KExpr .anon} + {requests : List WalkerRequest} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (context : ScopedRecursiveMethodRunContext initial (TcM.whnf e) requests + trProj world support) + {Delta : KVLCtx} {sourceV : Lean4Lean.VExpr} + (hcall : (context.calls (initial.recFuel.toNat + 1)).whnf e) + (hsource : TrKExprS world.venv context.model.keys.uvars world.nameOf + trProj Delta e sourceV) : + TcM.WF (context.Inv Delta) initial (TcM.whnf e) + (fun result _ => support result ∧ + WhnfPost trProj world context.model.keys.uvars Delta sourceV + result) := by + have hnext := context.schedule.nextSelected + simpa [TcM.whnf, TcM.runRec, Methods.next] using + hnext.whnf hcall hsource + +end TcM.whnf + +namespace TcM.infer + +/-- Public inference soundness from the exact finite successor-layer call +domain used by this run. -/ +theorem wf_legacy + {initial : TcState .anon} {e : KExpr .anon} + {requests : List WalkerRequest} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (context : RecursiveMethodRunContext initial (TcM.infer e) requests + trProj world support) + {Delta : KVLCtx} {sourceV : Lean4Lean.VExpr} + (hcall : (context.calls (initial.recFuel.toNat + 1)).infer e) + (hsource : TrKExprS world.venv + context.proposition.model.keys.uvars world.nameOf trProj Delta e + sourceV) : + TcM.WF (context.Inv Delta) initial (TcM.infer e) + (fun ty _ => support ty ∧ + InferPost trProj world context.proposition.model.keys.uvars Delta + sourceV ty) := by + have hnext := context.schedule.nextSelected + simpa [TcM.infer, TcM.runRec, Methods.next] using + hnext.infer hcall hsource + +/-- Public inference soundness over one finite suffix-state domain. -/ +theorem wf + {initial : TcState .anon} {e : KExpr .anon} + {requests : List WalkerRequest} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (context : ScopedRecursiveMethodRunContext initial (TcM.infer e) requests + trProj world support) + {Delta : KVLCtx} {sourceV : Lean4Lean.VExpr} + (hcall : (context.calls (initial.recFuel.toNat + 1)).infer e) + (hsource : TrKExprS world.venv context.model.keys.uvars world.nameOf + trProj Delta e sourceV) : + TcM.WF (context.Inv Delta) initial (TcM.infer e) + (fun ty _ => support ty ∧ + InferPost trProj world context.model.keys.uvars Delta sourceV ty) := by + have hnext := context.schedule.nextSelected + simpa [TcM.infer, TcM.runRec, Methods.next] using + hnext.infer hcall hsource + +end TcM.infer + +namespace TcM.isDefEq + +/-- Public definitional-equality soundness from the exact finite +successor-layer call domain used by this run. Only a true answer has semantic +content. -/ +theorem wf_legacy + {initial : TcState .anon} {a b : KExpr .anon} + {requests : List WalkerRequest} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (context : RecursiveMethodRunContext initial (TcM.isDefEq a b) requests + trProj world support) + {Delta : KVLCtx} {va vb : Lean4Lean.VExpr} + (hcall : (context.calls (initial.recFuel.toNat + 1)).isDefEq a b) + (ha : TrKExprS world.venv context.proposition.model.keys.uvars + world.nameOf trProj Delta a va) + (hb : TrKExprS world.venv context.proposition.model.keys.uvars + world.nameOf trProj Delta b vb) : + TcM.WF (context.Inv Delta) initial (TcM.isDefEq a b) + (fun answer _ => answer = true → + world.venv.IsDefEqU context.proposition.model.keys.uvars Delta.toCtx + va vb) := by + have hnext := context.schedule.nextSelected + simpa [TcM.isDefEq, TcM.runRec, Methods.next] using + hnext.isDefEq hcall ha hb + +/-- Public definitional-equality soundness over one finite suffix-state +domain. Scope preservation holds on both answers and on partial errors. -/ +theorem wf + {initial : TcState .anon} {a b : KExpr .anon} + {requests : List WalkerRequest} {trProj : RawProjRel} + {world : VerifyWorld} {support : RunSupport} + (context : ScopedRecursiveMethodRunContext initial (TcM.isDefEq a b) + requests trProj world support) + {Delta : KVLCtx} {va vb : Lean4Lean.VExpr} + (hcall : (context.calls (initial.recFuel.toNat + 1)).isDefEq a b) + (ha : TrKExprS world.venv context.model.keys.uvars world.nameOf trProj + Delta a va) + (hb : TrKExprS world.venv context.model.keys.uvars world.nameOf trProj + Delta b vb) : + TcM.WF (context.Inv Delta) initial (TcM.isDefEq a b) + (fun answer _ => answer = true → + world.venv.IsDefEqU context.model.keys.uvars Delta.toCtx va vb) := by + have hnext := context.schedule.nextSelected + simpa [TcM.isDefEq, TcM.runRec, Methods.next] using + hnext.isDefEq hcall ha hb + +end TcM.isDefEq + +end Ix.Tc diff --git a/Ix/Tc/Verify/RecursiveMethods/ScopedCallDomains.lean b/Ix/Tc/Verify/RecursiveMethods/ScopedCallDomains.lean new file mode 100644 index 000000000..6a1af55af --- /dev/null +++ b/Ix/Tc/Verify/RecursiveMethods/ScopedCallDomains.lean @@ -0,0 +1,317 @@ +import Ix.Tc.Verify.DefEq +import Ix.Tc.Verify.RecursiveMethods.CallDomains + +/-! +# Run-scoped recursive-method call domains + +The original bounded call-domain contract carries the kernel invariant but +not the finite context-digest state domain. K2S must retain both: a method +may construct or reuse a suffix key only while its concrete pre-state belongs +to `ScopedKernelSuffixModel.StateInScope`, and both success and partial-error +states must remain in that domain. + +This module deliberately parallels only the bounded public knot. The legacy +all-depth/global-model interfaces remain compatibility artifacts and are not +used to justify the scoped schedule below. +-/ + +namespace Ix.Tc + +namespace Methods + +/-- Six-field method contract over one finite call domain and one finite +suffix-model state domain. -/ +structure ScopedWFAtOn + {trProj : RawProjRel} {world : VerifyWorld} + (model : ScopedKernelSuffixModel trProj world) + (layer : WhnfLayer) (semantics : CacheSemantics) + (scope : RunSupport) (calls : CallDomain) + (methods : Methods .anon) : Prop where + within : calls.Within scope + whnf : ∀ {Delta s source sourceV}, + calls.whnf source → + TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta source + sourceV → + TcM.WF (ScopedWhnfStateInv model layer semantics scope Delta) s + (methods.whnf source) + (fun result _ => scope result ∧ + WhnfPost trProj world model.keys.uvars Delta sourceV result) + whnfCore : ∀ {Delta s source sourceV}, + calls.whnfCore source → + TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta source + sourceV → + TcM.WF (ScopedWhnfStateInv model layer semantics scope Delta) s + (methods.whnfCore source) + (fun result _ => scope result ∧ + WhnfPost trProj world model.keys.uvars Delta sourceV result) + whnfMode : ∀ {Delta s source sourceV} {mode : NatSuccMode}, + calls.whnfMode source mode → + TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta source + sourceV → + TcM.WF (ScopedWhnfStateInv model layer semantics scope Delta) s + (methods.whnfMode source mode) + (fun result _ => scope result ∧ + WhnfPost trProj world model.keys.uvars Delta sourceV result) + whnfCoreFlags : ∀ {Delta s source sourceV} {flags : WhnfFlags}, + calls.whnfCoreFlags source flags → + TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta source + sourceV → + TcM.WF (ScopedWhnfStateInv model layer semantics scope Delta) s + (methods.whnfCoreFlags source flags) + (fun result _ => scope result ∧ + WhnfPost trProj world model.keys.uvars Delta sourceV result) + infer : ∀ {Delta s source sourceV}, + calls.infer source → + TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta source + sourceV → + TcM.WF (ScopedWhnfStateInv model layer semantics scope Delta) s + (methods.infer source) + (fun ty _ => scope ty ∧ + InferPost trProj world model.keys.uvars Delta sourceV ty) + isDefEq : ∀ {Delta s left right leftV rightV}, + calls.isDefEq left right → + TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta left + leftV → + TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta right + rightV → + TcM.WF (ScopedWhnfStateInv model layer semantics scope Delta) s + (methods.isDefEq left right) + (fun answer _ => answer = true → + world.venv.IsDefEqU model.keys.uvars Delta.toCtx leftV rightV) + +/-- One domain-changing induction step for the run-scoped production table. -/ +def ScopedStepWFAtOn + {trProj : RawProjRel} {world : VerifyWorld} + (model : ScopedKernelSuffixModel trProj world) + (layer : WhnfLayer) (semantics : CacheSemantics) + (scope : RunSupport) (before after : CallDomain) : Prop := + ∀ methods, + ScopedWFAtOn model layer semantics scope before methods → + ScopedWFAtOn model layer semantics scope after (Methods.next methods) + +/-- A finite call schedule which preserves both the checker invariant and +the scoped suffix-state witness at every selected table depth. -/ +structure ScopedCallScheduleAt + {trProj : RawProjRel} {world : VerifyWorld} + (model : ScopedKernelSuffixModel trProj world) + (layer : WhnfLayer) (semantics : CacheSemantics) + (scope : RunSupport) (calls : Nat → CallDomain) (depth : Nat) : Prop where + within : ∀ n, n ≤ depth → (calls n).Within scope + step : ∀ n, n < depth → + ScopedStepWFAtOn model layer semantics scope (calls n) (calls (n + 1)) + +/-- The exhausted table changes no state, hence preserves any finite +suffix-state domain on its error outcome. -/ +theorem methodsOut_scopedWFAtOn + {trProj : RawProjRel} {world : VerifyWorld} + (model : ScopedKernelSuffixModel trProj world) + (layer : WhnfLayer) (semantics : CacheSemantics) + (scope : RunSupport) (calls : CallDomain) (within : calls.Within scope) : + ScopedWFAtOn model layer semantics scope calls + (methodsOut : Methods .anon) where + within := within + whnf _ _ := TcM.WF.throw (fun _ => trivial) + whnfCore _ _ := TcM.WF.throw (fun _ => trivial) + whnfMode _ _ := TcM.WF.throw (fun _ => trivial) + whnfCoreFlags _ _ := TcM.WF.throw (fun _ => trivial) + infer _ _ := TcM.WF.throw (fun _ => trivial) + isDefEq _ _ _ := TcM.WF.throw (fun _ => trivial) + +namespace ScopedCallScheduleAt + +/-- Close exactly the finite production approximation named by this scoped +schedule. -/ +theorem methodsN + {trProj : RawProjRel} {world : VerifyWorld} + {model : ScopedKernelSuffixModel trProj world} + {layer : WhnfLayer} {semantics : CacheSemantics} + {scope : RunSupport} {calls : Nat → CallDomain} {depth : Nat} + (schedule : ScopedCallScheduleAt model layer semantics scope calls depth) : + ∀ n, n ≤ depth → + ScopedWFAtOn model layer semantics scope (calls n) + (Ix.Tc.methodsN (m := .anon) n) + | 0, _ => + methodsOut_scopedWFAtOn model layer semantics scope (calls 0) + (schedule.within 0 (Nat.zero_le depth)) + | n + 1, hn => by + rw [Methods.methodsN_succ] + exact schedule.step n (Nat.lt_of_succ_le hn) + (Ix.Tc.methodsN (m := .anon) n) + (schedule.methodsN n (Nat.le_trans (Nat.le_succ n) hn)) + +theorem selected + {trProj : RawProjRel} {world : VerifyWorld} + {model : ScopedKernelSuffixModel trProj world} + {layer : WhnfLayer} {semantics : CacheSemantics} + {scope : RunSupport} {calls : Nat → CallDomain} {depth : Nat} + (schedule : ScopedCallScheduleAt model layer semantics scope calls depth) : + ScopedWFAtOn model layer semantics scope (calls depth) + (Ix.Tc.methodsN (m := .anon) depth) := + schedule.methodsN depth (Nat.le_refl depth) + +theorem nextSelected + {trProj : RawProjRel} {world : VerifyWorld} + {model : ScopedKernelSuffixModel trProj world} + {layer : WhnfLayer} {semantics : CacheSemantics} + {scope : RunSupport} {calls : Nat → CallDomain} {depth : Nat} + (schedule : ScopedCallScheduleAt model layer semantics scope calls + (depth + 1)) : + ScopedWFAtOn model layer semantics scope (calls (depth + 1)) + (Methods.next (Ix.Tc.methodsN (m := .anon) depth)) := + schedule.step depth (Nat.lt_succ_self depth) + (Ix.Tc.methodsN (m := .anon) depth) + (schedule.methodsN depth (Nat.le_succ depth)) + +end ScopedCallScheduleAt + +end Methods + +namespace RecM + +/-- Reader-level Hoare triple under a finite method-call domain and a finite +suffix-model state domain. -/ +def ScopedWFOn + {trProj : RawProjRel} {world : VerifyWorld} + (model : ScopedKernelSuffixModel trProj world) + (layer : WhnfLayer) (semantics : CacheSemantics) + (scope : RunSupport) (calls : Methods.CallDomain) (Delta : KVLCtx) + (s : TcState .anon) (action : RecM .anon alpha) + (Q : alpha → TcState .anon → Prop) + (E : TcError .anon → TcState .anon → Prop := fun _ _ => True) : Prop := + ∀ methods, + Methods.ScopedWFAtOn model layer semantics scope calls methods → + TcM.WF (ScopedWhnfStateInv model layer semantics scope Delta) s + (action.run methods) Q E + +namespace ScopedWFOn + +theorem pure + {trProj : RawProjRel} {world : VerifyWorld} + {model : ScopedKernelSuffixModel trProj world} + {layer : WhnfLayer} {semantics : CacheSemantics} + {scope : RunSupport} {calls : Methods.CallDomain} {Delta : KVLCtx} + {s : TcState .anon} {Q : alpha → TcState .anon → Prop} + {E : TcError .anon → TcState .anon → Prop} {value : alpha} + (h : ScopedWhnfStateInv model layer semantics scope Delta s → + Q value s) : + ScopedWFOn model layer semantics scope calls Delta s (pure value) Q E := + fun _ _ => TcM.WF.pure h + +theorem throw + {trProj : RawProjRel} {world : VerifyWorld} + {model : ScopedKernelSuffixModel trProj world} + {layer : WhnfLayer} {semantics : CacheSemantics} + {scope : RunSupport} {calls : Methods.CallDomain} {Delta : KVLCtx} + {s : TcState .anon} {Q : alpha → TcState .anon → Prop} + {E : TcError .anon → TcState .anon → Prop} {err : TcError .anon} + (h : ScopedWhnfStateInv model layer semantics scope Delta s → E err s) : + ScopedWFOn model layer semantics scope calls Delta s + (throw err) Q E := + fun _ _ => TcM.WF.throw h + +theorem mono + {trProj : RawProjRel} {world : VerifyWorld} + {model : ScopedKernelSuffixModel trProj world} + {layer : WhnfLayer} {semantics : CacheSemantics} + {scope : RunSupport} {calls : Methods.CallDomain} {Delta : KVLCtx} + {s : TcState .anon} {action : RecM .anon alpha} + {Q Q' : alpha → TcState .anon → Prop} + {E E' : TcError .anon → TcState .anon → Prop} + (h : ScopedWFOn model layer semantics scope calls Delta s action Q E) + (hQ : ∀ value after, Q value after → Q' value after) + (hE : ∀ err after, E err after → E' err after) : + ScopedWFOn model layer semantics scope calls Delta s action Q' E' := + fun methods contract => TcM.WF.mono (h methods contract) hQ hE + +theorem withInv + {trProj : RawProjRel} {world : VerifyWorld} + {model : ScopedKernelSuffixModel trProj world} + {layer : WhnfLayer} {semantics : CacheSemantics} + {scope : RunSupport} {calls : Methods.CallDomain} {Delta : KVLCtx} + {s : TcState .anon} {action : RecM .anon alpha} + {Q : alpha → TcState .anon → Prop} + {E : TcError .anon → TcState .anon → Prop} + (h : ScopedWFOn model layer semantics scope calls Delta s action Q E) : + ScopedWFOn model layer semantics scope calls Delta s action + (fun value after => + ScopedWhnfStateInv model layer semantics scope Delta after ∧ + Q value after) + E := + fun methods contract => TcM.WF.withInv (h methods contract) + +theorem bind + {trProj : RawProjRel} {world : VerifyWorld} + {model : ScopedKernelSuffixModel trProj world} + {layer : WhnfLayer} {semantics : CacheSemantics} + {scope : RunSupport} {calls : Methods.CallDomain} {Delta : KVLCtx} + {s : TcState .anon} {action : RecM .anon alpha} + {next : alpha → RecM .anon beta} + {Q1 : alpha → TcState .anon → Prop} + {Q2 : beta → TcState .anon → Prop} + {E : TcError .anon → TcState .anon → Prop} + (haction : ScopedWFOn model layer semantics scope calls Delta s + action Q1 E) + (hnext : ∀ value after, Q1 value after → + ScopedWFOn model layer semantics scope calls Delta after + (next value) Q2 E) : + ScopedWFOn model layer semantics scope calls Delta s + (action >>= next) Q2 E := by + intro methods contract + exact TcM.WF.bind (haction methods contract) fun value after hvalue => + hnext value after hvalue methods contract + +theorem liftTcM + {trProj : RawProjRel} {world : VerifyWorld} + {model : ScopedKernelSuffixModel trProj world} + {layer : WhnfLayer} {semantics : CacheSemantics} + {scope : RunSupport} {calls : Methods.CallDomain} {Delta : KVLCtx} + {s : TcState .anon} {action : TcM .anon alpha} + {Q : alpha → TcState .anon → Prop} + {E : TcError .anon → TcState .anon → Prop} + (h : TcM.WF (ScopedWhnfStateInv model layer semantics scope Delta) s + action Q E) : + ScopedWFOn model layer semantics scope calls Delta s + (liftM action) Q E := + fun _ _ => h + +theorem get + {trProj : RawProjRel} {world : VerifyWorld} + {model : ScopedKernelSuffixModel trProj world} + {layer : WhnfLayer} {semantics : CacheSemantics} + {scope : RunSupport} {calls : Methods.CallDomain} {Delta : KVLCtx} + {s : TcState .anon} + {Q : TcState .anon → TcState .anon → Prop} + {E : TcError .anon → TcState .anon → Prop} + (h : ScopedWhnfStateInv model layer semantics scope Delta s → Q s s) : + ScopedWFOn model layer semantics scope calls Delta s + (get : RecM .anon (TcState .anon)) Q E := + fun _ _ => TcM.WF.get h + +end ScopedWFOn + +end RecM + +namespace TcM + +/-- Apply a scoped reader proof to the exact finite table selected by the +state's recursion fuel. -/ +theorem runRec_scoped_wfAtOn + {trProj : RawProjRel} {world : VerifyWorld} + {model : ScopedKernelSuffixModel trProj world} + {layer : WhnfLayer} {semantics : CacheSemantics} + {scope : RunSupport} {calls : Nat → Methods.CallDomain} + {Delta : KVLCtx} {s : TcState .anon} {action : RecM .anon alpha} + {Q : alpha → TcState .anon → Prop} + {E : TcError .anon → TcState .anon → Prop} + (schedule : Methods.ScopedCallScheduleAt model layer semantics scope + calls s.recFuel.toNat) + (haction : RecM.ScopedWFOn model layer semantics scope + (calls s.recFuel.toNat) Delta s action Q E) : + TcM.WF (ScopedWhnfStateInv model layer semantics scope Delta) s + (TcM.runRec action) Q E := by + simpa [TcM.runRec] using + haction (Ix.Tc.methodsN (m := .anon) s.recFuel.toNat) schedule.selected + +end TcM + +end Ix.Tc diff --git a/Ix/Tc/Verify/RecursiveMethods/ScopedInference.lean b/Ix/Tc/Verify/RecursiveMethods/ScopedInference.lean new file mode 100644 index 000000000..6c23797d8 --- /dev/null +++ b/Ix/Tc/Verify/RecursiveMethods/ScopedInference.lean @@ -0,0 +1,292 @@ +import Ix.Tc.Verify.Infer.CacheSoundness +import Ix.Tc.Verify.RecursiveMethods.ScopedCallDomains + +/-! +# Run-scoped call-domain inference + +This is the finite-suffix-state counterpart of `RecursiveMethods.Inference`. +The production cache shell is proved directly over `ScopedWhnfStateInv`: +key construction advances the suffix scope through its memo update, while +interning and cache insertion use the exact digest-neutral state frame. + +No theorem in this module converts a `ScopedKernelSuffixModel` to the legacy +globally quantified `KernelSuffixModel`. +-/ + +namespace Ix.Tc + +namespace TcM + +/-- Direct interning preserves a run-scoped suffix model because its exact +state frame changes only the intern table. The successful result and frame +remain exposed for syntax-specific leaf proofs. -/ +theorem intern_scoped_wf + {trProj : RawProjRel} {world : VerifyWorld} + {model : ScopedKernelSuffixModel trProj world} + {layer : WhnfLayer} {semantics : CacheSemantics} + {support : RunSupport} {Delta : KVLCtx} + {e : KExpr .anon} {s : TcState .anon} + (hcollision : support.CollisionFree) (hsupport : support e) : + TcM.WF (ScopedWhnfStateInv model layer semantics support Delta) s + (TcM.intern e) + (fun result after => result = e ∧ InternUpdateFrame s after) := by + intro hI + obtain ⟨after, hrun, hbase, hframe⟩ := + TcM.intern_whnf_eval hcollision hsupport hI.1 + rw [hrun] + exact ⟨⟨hbase, model.preservesFrame hI.2 + (ContextDigestFrame.ofInternUpdateFrame hframe)⟩, rfl, hframe⟩ + +end TcM + +/-- Per-layer inference resources whose uncached body preserves the finite +suffix-state domain as well as the ordinary checker invariant. -/ +structure ScopedInferenceCallDomainContext + {trProj : RawProjRel} {world : VerifyWorld} (scope : RunSupport) + (model : ScopedKernelSuffixModel trProj world) + (current predecessor : Methods.CallDomain) : Type where + collisionFree : scope.CollisionFree + currentWithin : current.Within scope + theory : WhnfTheory trProj world model.keys.uvars + references : RecM.TrustedReferences world scope + uncached : ∀ {Delta : KVLCtx} {s : TcState .anon} {inferOnly : Bool} + {source : KExpr .anon} {sourceV : Lean4Lean.VExpr}, + current.infer source → + TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta source + sourceV → + RecM.ScopedWFOn model .noAccel + (kernelCacheSemantics model.keys trProj) scope predecessor Delta s + (RecM.inferUncached RecM.inferCall inferOnly source) + (fun result _ => scope result ∧ + InferPost trProj world model.keys.uvars Delta sourceV result) + +namespace ScopedInferenceCallDomainContext + +private theorem cacheReferences + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {model : ScopedKernelSuffixModel trProj world} + {current predecessor : Methods.CallDomain} + (context : ScopedInferenceCallDomainContext scope model current + predecessor) + {kind : ExprCacheKind} {key : Address × Address} + {ty : KExpr .anon} (hty : scope ty) : + (CacheEntry.expr kind key ty).ReferencesAuthorized + (CacheAuthority.stable world) scope := by + intro id href + apply Or.inl + rcases href with href | href + · obtain ⟨source, hsource, _, hreference⟩ := href + exact context.references hsource hreference + · exact context.references hty href + +/-- A validated inference-cache insertion changes no suffix-digest input +field, so it preserves both halves of the scoped invariant. -/ +private theorem cacheWriteFull_scopedWFOn + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {model : ScopedKernelSuffixModel trProj world} + {predecessor : Methods.CallDomain} {Delta : KVLCtx} + {s : TcState .anon} {key : Address × Address} {ty : KExpr .anon} + (hnew : CacheProvenance (kernelCacheSemantics model.keys trProj) + (CacheAuthority.stable world) scope (.expr .infer key ty)) : + RecM.ScopedWFOn model .noAccel + (kernelCacheSemantics model.keys trProj) scope predecessor Delta s + (RecM.cacheInferResult false key ty) (fun _ _ => True) := by + intro methods _ hI + rw [RecM.cacheInferResult_full_run] + refine ⟨⟨RecM.InferCacheUpdate.full_whnfStateInv hI.1 hnew, + model.preservesFrame hI.2 ?_⟩, trivial⟩ + constructor <;> rfl + +/-- An infer-only cache insertion has the same digest-neutral state frame. -/ +private theorem cacheWriteInferOnly_scopedWFOn + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {model : ScopedKernelSuffixModel trProj world} + {predecessor : Methods.CallDomain} {Delta : KVLCtx} + {s : TcState .anon} {key : Address × Address} {ty : KExpr .anon} + (hnew : CacheProvenance (kernelCacheSemantics model.keys trProj) + (CacheAuthority.stable world) scope (.expr .inferOnly key ty)) : + RecM.ScopedWFOn model .noAccel + (kernelCacheSemantics model.keys trProj) scope predecessor Delta s + (RecM.cacheInferResult true key ty) (fun _ _ => True) := by + intro methods _ hI + rw [RecM.cacheInferResult_inferOnly_run] + refine ⟨⟨RecM.InferCacheUpdate.inferOnly_whnfStateInv hI.1 hnew, + model.preservesFrame hI.2 ?_⟩, trivial⟩ + constructor <;> rfl + +/-- Execute one admitted uncached source and install its result without ever +leaving the model's finite suffix-state domain. -/ +private theorem missTail_scopedWFOn + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {model : ScopedKernelSuffixModel trProj world} + {current predecessor : Methods.CallDomain} + (context : ScopedInferenceCallDomainContext scope model current + predecessor) + {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) + (hcall : current.infer source) + (hsource : TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta + source sourceV) : + RecM.ScopedWFOn model .noAccel + (kernelCacheSemantics model.keys trProj) scope predecessor Delta s + (do + let ty ← RecM.inferUncached RecM.inferCall inferOnly source + RecM.cacheInferResult inferOnly key ty + pure ty) + (fun result _ => scope result ∧ + InferPost trProj world model.keys.uvars Delta sourceV result) := by + have hsourceSupport := context.currentWithin.infer hcall + cases inferOnly with + | false => + apply RecM.ScopedWFOn.bind + (RecM.ScopedWFOn.withInv (context.uncached hcall hsource)) + intro ty afterBody hbody + rcases hbody with ⟨_, hty, hpost⟩ + have hprovenance := model.transports.inferProvenance + context.collisionFree .infer hsourceSupport hty hmatch + (InferMeaning.of_post hsource hpost) + (context.cacheReferences hty) + apply RecM.ScopedWFOn.bind + (Q1 := fun _ _ => True) + (cacheWriteFull_scopedWFOn (predecessor := predecessor) hprovenance) + intro _ afterWrite _ + exact RecM.ScopedWFOn.pure fun _ => ⟨hty, hpost⟩ + | true => + apply RecM.ScopedWFOn.bind + (RecM.ScopedWFOn.withInv (context.uncached hcall hsource)) + intro ty afterBody hbody + rcases hbody with ⟨_, hty, hpost⟩ + have hprovenance := model.transports.inferProvenance + context.collisionFree .inferOnly hsourceSupport hty hmatch + (InferMeaning.of_post hsource hpost) + (context.cacheReferences hty) + apply RecM.ScopedWFOn.bind + (Q1 := fun _ _ => True) + (cacheWriteInferOnly_scopedWFOn (predecessor := predecessor) + hprovenance) + intro _ afterWrite _ + exact RecM.ScopedWFOn.pure fun _ => ⟨hty, hpost⟩ + +/-- Production `inferWith` over one admitted source, with scope preserved on +key errors, cache hits, uncached errors, and both cache-write partitions. -/ +theorem inferWith_scopedWFOn + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {model : ScopedKernelSuffixModel trProj world} + {current predecessor : Methods.CallDomain} + (context : ScopedInferenceCallDomainContext scope model current + predecessor) + {Delta : KVLCtx} {s : TcState .anon} + {source : KExpr .anon} {sourceV : Lean4Lean.VExpr} + (hcall : current.infer source) + (hsource : TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta + source sourceV) : + RecM.ScopedWFOn model .noAccel + (kernelCacheSemantics model.keys trProj) scope predecessor Delta s + (RecM.inferWith RecM.inferCall source) + (fun result _ => scope result ∧ + InferPost trProj world model.keys.uvars Delta sourceV result) := by + have hsourceSupport := context.currentWithin.infer hcall + unfold RecM.inferWith + apply RecM.ScopedWFOn.bind + (Q1 := fun observed after => observed = s ∧ after = s) + (RecM.ScopedWFOn.get fun _ => ⟨rfl, rfl⟩) + intro observed after hread + rcases hread with ⟨hObserved, hAfter⟩ + subst observed + subst after + apply RecM.ScopedWFOn.bind + (Q1 := fun key _ => + model.keys.Matches trProj world s Delta source key) + · apply RecM.ScopedWFOn.liftTcM + exact TcM.WF.mono (TcM.inferKey_scoped_model_matches_wf model) + (fun _ _ h => h.1) (fun _ _ h => h) + · intro key afterKey hmatch + apply RecM.ScopedWFOn.bind + (Q1 := fun currentState after => + currentState = afterKey ∧ after = afterKey) + (RecM.ScopedWFOn.get fun _ => ⟨rfl, rfl⟩) + intro currentState afterRead hread + rcases hread with ⟨hCurrent, hAfterRead⟩ + subst currentState + 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.ScopedWFOn.pure fun hI => by + have hprovenance := hI.1.1.caches.hit (.infer hhit) + have hmeaning := hprovenance.kernelInferMeaningOfMatches + .infer hsourceSupport hmatch + exact ⟨hprovenance.supported.2, + hmeaning.post context.theory hI.1.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_scopedWFOn hmatch hcall hsource + | true => + simp only [pure_bind, if_true] + apply RecM.ScopedWFOn.bind + (Q1 := fun currentState after => + currentState = afterKey ∧ after = afterKey) + (RecM.ScopedWFOn.get fun _ => ⟨rfl, rfl⟩) + intro currentState afterInferOnlyRead hread + rcases hread with ⟨hCurrent, hAfterRead⟩ + subst currentState + 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.ScopedWFOn.pure fun hI => by + have hprovenance := hI.1.1.caches.hit (.inferOnly hhit) + have hmeaning := hprovenance.kernelInferMeaningOfMatches + .inferOnly hsourceSupport hmatch + exact ⟨hprovenance.supported.2, + hmeaning.post context.theory hI.1.2.1.wf hsource⟩ + | none => + have hmiss : afterKey.env.inferOnlyCache[key]? = none := by + simpa [inferOnlyFound] using hinferOnlyFound + simp only [hmiss] + exact context.missTail_scopedWFOn hmatch hcall hsource + +/-- The inference field of one unfolded method-table layer, now directly +proved over the run-scoped suffix model. -/ +theorem nextInfer_scopedWFAtOn + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {model : ScopedKernelSuffixModel trProj world} + {current predecessor : Methods.CallDomain} + (context : ScopedInferenceCallDomainContext scope model current + predecessor) + (predecessorMethods : Methods .anon) + (predecessorWF : Methods.ScopedWFAtOn model .noAccel + (kernelCacheSemantics model.keys trProj) scope predecessor + predecessorMethods) : + ∀ {Delta : KVLCtx} {s : TcState .anon} + {source : KExpr .anon} {sourceV : Lean4Lean.VExpr}, + current.infer source → + TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta source + sourceV → + TcM.WF + (ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) scope Delta) s + ((Methods.next predecessorMethods).infer source) + (fun result _ => scope result ∧ + InferPost trProj world model.keys.uvars Delta sourceV result) := by + intro Delta s source sourceV hcall hsource + simpa [Methods.next, RecM.infer] using + (context.inferWith_scopedWFOn hcall hsource) predecessorMethods + predecessorWF + +end ScopedInferenceCallDomainContext + +end Ix.Tc diff --git a/Ix/Tc/Verify/RecursiveMethods/ScopedSortInference.lean b/Ix/Tc/Verify/RecursiveMethods/ScopedSortInference.lean new file mode 100644 index 000000000..ec900b324 --- /dev/null +++ b/Ix/Tc/Verify/RecursiveMethods/ScopedSortInference.lean @@ -0,0 +1,238 @@ +import Ix.Tc.Verify.Infer.LeafCases +import Ix.Tc.Verify.RecursiveMethods.ScopedInference + +/-! +# Positive-fuel inference under a run-scoped suffix model + +This module closes the smallest genuine production recursion schedule without +a global suffix premise. One sort source is admitted at every positive +method-table depth; its uncached body interns the successor sort and makes no +recursive callback. Key memoization, interning, and cache insertion all +preserve `StateInScope` explicitly. +-/ + +namespace Ix.Tc + +namespace ScopedInferenceCallDomainContext + +/-- Build the scoped production cache shell around the method-independent +sort leaf. -/ +def sort + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {model : ScopedKernelSuffixModel trProj world} + {u : KUniv .anon} {info : ExprInfo .anon} + (hcollision : scope.CollisionFree) + (hsourceSupport : scope (.sort u info)) + (hresultSupport : scope (KExpr.mkSort (KUniv.mkSucc u))) + (theory : WhnfTheory trProj world model.keys.uvars) + (references : RecM.TrustedReferences world scope) + (predecessor : Methods.CallDomain) : + ScopedInferenceCallDomainContext scope model + (.singletonInfer (.sort u info)) predecessor where + collisionFree := hcollision + currentWithin := Methods.CallDomain.singletonInfer_within hsourceSupport + theory := theory + references := references + uncached := by + intro Delta s inferOnly source sourceV hcall hsource + change source = .sort u info at hcall + subst source + cases hsource with + | sort hu => + unfold RecM.inferUncached + apply RecM.ScopedWFOn.mono + (RecM.ScopedWFOn.withInv <| + RecM.ScopedWFOn.liftTcM <| + TcM.intern_scoped_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.1.2.1.wf + · simpa only [KUniv.toVLevel_mkSucc] using + (Lean4Lean.VEnv.HasType.sort hu) + · intro _ _ _ + trivial + +end ScopedInferenceCallDomainContext + +namespace Methods + +/-- One production `Methods.next` layer is scoped-sound for exactly one sort +inference call when the predecessor satisfies its own finite call domain. -/ +theorem next_sort_scopedWFAtOn + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {model : ScopedKernelSuffixModel trProj world} + {u : KUniv .anon} {info : ExprInfo .anon} + {predecessor : Methods.CallDomain} + (context : ScopedInferenceCallDomainContext scope model + (.singletonInfer (.sort u info)) predecessor) + (predecessorMethods : Methods .anon) + (predecessorWF : Methods.ScopedWFAtOn model .noAccel + (kernelCacheSemantics model.keys trProj) scope predecessor + predecessorMethods) : + Methods.ScopedWFAtOn model .noAccel + (kernelCacheSemantics model.keys trProj) scope + (.singletonInfer (.sort u info)) (Methods.next predecessorMethods) where + within := context.currentWithin + whnf hcall := False.elim hcall + whnfCore hcall := False.elim hcall + whnfMode hcall := False.elim hcall + whnfCoreFlags hcall := False.elim hcall + infer hcall hsource := + context.nextInfer_scopedWFAtOn predecessorMethods predecessorWF hcall + hsource + isDefEq hcall := False.elim hcall + +namespace ScopedSortSchedule + +/-- Exact call domains for a finite sort execution. -/ +def calls (source : KExpr .anon) : Nat → CallDomain + | 0 => .empty + | _ + 1 => .singletonInfer source + +@[simp] theorem calls_zero (source : KExpr .anon) : + calls source 0 = .empty := rfl + +@[simp] theorem calls_succ (source : KExpr .anon) (n : Nat) : + calls source (n + 1) = .singletonInfer source := rfl + +/-- The same finite source/result footprint supports every finite table +depth. The successor-sort result is a result, not another admitted call, so +no infinite successor-sort closure is required. -/ +theorem finite + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {model : ScopedKernelSuffixModel trProj world} + {u : KUniv .anon} {info : ExprInfo .anon} + (hcollision : scope.CollisionFree) + (hsourceSupport : scope (.sort u info)) + (hresultSupport : scope (KExpr.mkSort (KUniv.mkSucc u))) + (theory : WhnfTheory trProj world model.keys.uvars) + (references : RecM.TrustedReferences world scope) + (depth : Nat) : + ScopedCallScheduleAt model .noAccel + (kernelCacheSemantics model.keys trProj) scope + (calls (.sort u info)) depth where + within n hn := by + cases n with + | zero => exact Methods.CallDomain.empty_within scope + | succ n => + exact Methods.CallDomain.singletonInfer_within hsourceSupport + step n hn := by + let context := ScopedInferenceCallDomainContext.sort hcollision + hsourceSupport hresultSupport theory references + (calls (.sort u info) n) + simpa [calls] using (next_sort_scopedWFAtOn context) + +/-- Recursion fuel one selects a depth-one callback table and requires the +outer sort body at depth two. -/ +theorem two + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {model : ScopedKernelSuffixModel trProj world} + {u : KUniv .anon} {info : ExprInfo .anon} + (hcollision : scope.CollisionFree) + (hsourceSupport : scope (.sort u info)) + (hresultSupport : scope (KExpr.mkSort (KUniv.mkSucc u))) + (theory : WhnfTheory trProj world model.keys.uvars) + (references : RecM.TrustedReferences world scope) : + ScopedCallScheduleAt model .noAccel + (kernelCacheSemantics model.keys trProj) scope + (calls (.sort u info)) 2 := + finite hcollision hsourceSupport hresultSupport theory references 2 + +end ScopedSortSchedule + +end Methods + +namespace TcM.infer + +/-- Public production sort inference at arbitrary finite fuel, proved +directly from a run-scoped suffix model. -/ +theorem sort_scoped_wf_bounded + {initial : TcState .anon} + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {model : ScopedKernelSuffixModel trProj world} + {u : KUniv .anon} {info : ExprInfo .anon} + (hcollision : scope.CollisionFree) + (hsourceSupport : scope (.sort u info)) + (hresultSupport : scope (KExpr.mkSort (KUniv.mkSucc u))) + (theory : WhnfTheory trProj world model.keys.uvars) + (references : RecM.TrustedReferences world scope) + {Delta : KVLCtx} {sourceV : Lean4Lean.VExpr} + (hsource : TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta + (.sort u info) sourceV) : + TcM.WF + (ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) scope Delta) + initial (TcM.infer (.sort u info)) + (fun result _ => scope result ∧ + InferPost trProj world model.keys.uvars Delta sourceV result) := by + have schedule := Methods.ScopedSortSchedule.finite hcollision + hsourceSupport hresultSupport theory references + (initial.recFuel.toNat + 1) + have hnext := schedule.nextSelected + simpa [TcM.infer, TcM.runRec, Methods.next, + Methods.ScopedSortSchedule.calls] using + hnext.infer (by rfl) hsource + +/-- Explicit fuel-one specialization of the scoped public sort run. -/ +theorem sort_scoped_wf_fuel_one + {initial : TcState .anon} + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {model : ScopedKernelSuffixModel trProj world} + {u : KUniv .anon} {info : ExprInfo .anon} + (hfuel : initial.recFuel.toNat = 1) + (hcollision : scope.CollisionFree) + (hsourceSupport : scope (.sort u info)) + (hresultSupport : scope (KExpr.mkSort (KUniv.mkSucc u))) + (theory : WhnfTheory trProj world model.keys.uvars) + (references : RecM.TrustedReferences world scope) + {Delta : KVLCtx} {sourceV : Lean4Lean.VExpr} + (hsource : TrKExprS world.venv model.keys.uvars world.nameOf trProj Delta + (.sort u info) sourceV) : + TcM.WF + (ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) scope Delta) + initial (TcM.infer (.sort u info)) + (fun result _ => scope result ∧ + InferPost trProj world model.keys.uvars Delta sourceV result) := by + have _fuelWitness : initial.recFuel.toNat = 1 := hfuel + exact sort_scoped_wf_bounded hcollision hsourceSupport hresultSupport + theory references hsource + +/-- The K2S construction can be consumed at the public positive-fuel entry +without first manufacturing a universally quantified suffix model. -/ +theorem sort_finiteOperational_wf_fuel_one + {initial : TcState .anon} + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {uvars : Nat} (spec : ContextDigestSpec trProj world uvars) + (digestScope : ContextDigestScope spec) + (hdigestCollision : digestScope.CollisionFree) + (suffixSemantics : ContextSuffixSemantics spec) + {u : KUniv .anon} {info : ExprInfo .anon} + (hfuel : initial.recFuel.toNat = 1) + (hcollision : scope.CollisionFree) + (hsourceSupport : scope (.sort u info)) + (hresultSupport : scope (KExpr.mkSort (KUniv.mkSucc u))) + (theory : WhnfTheory trProj world uvars) + (references : RecM.TrustedReferences world scope) + {Delta : KVLCtx} {sourceV : Lean4Lean.VExpr} + (hsource : TrKExprS world.venv uvars world.nameOf trProj Delta + (.sort u info) sourceV) : + let model := ScopedKernelSuffixModel.finiteOperational spec digestScope + hdigestCollision suffixSemantics + TcM.WF + (ScopedWhnfStateInv model .noAccel + (kernelCacheSemantics model.keys trProj) scope Delta) + initial (TcM.infer (.sort u info)) + (fun result _ => scope result ∧ + InferPost trProj world uvars Delta sourceV result) := by + dsimp only + exact sort_scoped_wf_fuel_one hfuel hcollision hsourceSupport + hresultSupport theory references hsource + +end TcM.infer + +end Ix.Tc diff --git a/Ix/Tc/Verify/RecursiveMethods/SortInference.lean b/Ix/Tc/Verify/RecursiveMethods/SortInference.lean new file mode 100644 index 000000000..2e4d849be --- /dev/null +++ b/Ix/Tc/Verify/RecursiveMethods/SortInference.lean @@ -0,0 +1,252 @@ +import Ix.Tc.Verify.Infer.LeafCases +import Ix.Tc.Verify.RecursiveMethods.Inference +import Ix.Tc.Verify.RecursiveMethods.Public + +/-! +# A positive-fuel inference schedule + +This module instantiates the call-domain machinery on the smallest genuine +production inference execution: one admitted sort source at method-table +depth one. The predecessor table admits no calls because the sort leaf only +interns its successor-sort result; it does not recurse through `Methods`. + +The finite `RunSupport` still contains both source and result. Crucially, +membership of the result does not make it another inference call, so this +contract does not demand closure under an infinite tower of successor sorts. +-/ + +namespace Ix.Tc + +namespace InferenceCallDomainContext + +/-- Build the guarded production cache shell around the method-independent +sort leaf. -/ +def sort + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {model : KernelSuffixModel trProj world} + {u : KUniv .anon} {info : ExprInfo .anon} + (hcollision : scope.CollisionFree) + (hsourceSupport : scope (.sort u info)) + (hresultSupport : scope (KExpr.mkSort (KUniv.mkSucc u))) + (theory : WhnfTheory trProj world model.keys.uvars) + (references : RecM.TrustedReferences world scope) + (predecessor : Methods.CallDomain) : + InferenceCallDomainContext scope model + (.singletonInfer (.sort u info)) predecessor where + collisionFree := hcollision + currentWithin := Methods.CallDomain.singletonInfer_within hsourceSupport + theory := theory + references := references + uncached := by + intro Delta s inferOnly source sourceV hcall hsource + change source = .sort u info at hcall + subst source + apply RecM.WFOn.ofWF_of_methodIndependent + · intro methods + funext state + rfl + · exact RecM.inferUncached_sort_wf theory hcollision hresultSupport + hsource + +end InferenceCallDomainContext + +namespace Methods + +/-- One production `Methods.next` layer is sound for exactly one sort +inference call when its predecessor admits no calls. -/ +theorem next_sort_wfAtOn + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {model : KernelSuffixModel trProj world} + {u : KUniv .anon} {info : ExprInfo .anon} + {predecessor : Methods.CallDomain} + (context : InferenceCallDomainContext scope model + (.singletonInfer (.sort u info)) predecessor) + (predecessorMethods : Methods .anon) + (predecessorWF : Methods.WFAtOn .noAccel + (kernelCacheSemantics model.keys trProj) trProj world scope + model.keys.uvars predecessor predecessorMethods) : + Methods.WFAtOn .noAccel (kernelCacheSemantics model.keys trProj) + trProj world scope model.keys.uvars + (.singletonInfer (.sort u info)) (Methods.next predecessorMethods) where + within := context.currentWithin + whnf hcall := False.elim hcall + whnfCore hcall := False.elim hcall + whnfMode hcall := False.elim hcall + whnfCoreFlags hcall := False.elim hcall + infer hcall hsource := + context.nextInfer_wfAtOn predecessorMethods predecessorWF hcall hsource + isDefEq hcall := False.elim hcall + +namespace SortSchedule + +/-- Exact call domains for the depth-one sort fixture. -/ +def calls (source : KExpr .anon) : Nat → CallDomain + | 0 => .empty + | _ + 1 => .singletonInfer source + +@[simp] theorem calls_zero (source : KExpr .anon) : + calls source 0 = .empty := rfl + +@[simp] theorem calls_succ (source : KExpr .anon) (n : Nat) : + calls source (n + 1) = .singletonInfer source := rfl + +/-- A non-circular, positive-fuel schedule for one real production method +layer. -/ +theorem one + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {model : KernelSuffixModel trProj world} + {u : KUniv .anon} {info : ExprInfo .anon} + (context : InferenceCallDomainContext scope model + (.singletonInfer (.sort u info)) .empty) : + CallScheduleAt .noAccel (kernelCacheSemantics model.keys trProj) + trProj world scope model.keys.uvars (calls (.sort u info)) 1 where + within n hn := by + cases n with + | zero => exact Methods.CallDomain.empty_within scope + | succ n => exact context.currentWithin + step n hn := by + cases n with + | zero => + simpa [calls] using + (next_sort_wfAtOn context) + | succ n => omega + +/-- The selected depth-one production table satisfies the exact singleton +sort-inference contract. -/ +theorem selected + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {model : KernelSuffixModel trProj world} + {u : KUniv .anon} {info : ExprInfo .anon} + (context : InferenceCallDomainContext scope model + (.singletonInfer (.sort u info)) .empty) : + Methods.WFAtOn .noAccel (kernelCacheSemantics model.keys trProj) + trProj world scope model.keys.uvars + (.singletonInfer (.sort u info)) + (Ix.Tc.methodsN (m := .anon) 1) := by + simpa [calls] using (one context).selected + +/-- The same finite source/result footprint supports every finite table depth: +after depth zero the admitted domain remains the singleton source, while each +sort body is method-independent. No higher successor sort is added. -/ +theorem finite + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {model : KernelSuffixModel trProj world} + {u : KUniv .anon} {info : ExprInfo .anon} + (hcollision : scope.CollisionFree) + (hsourceSupport : scope (.sort u info)) + (hresultSupport : scope (KExpr.mkSort (KUniv.mkSucc u))) + (theory : WhnfTheory trProj world model.keys.uvars) + (references : RecM.TrustedReferences world scope) + (depth : Nat) : + CallScheduleAt .noAccel (kernelCacheSemantics model.keys trProj) + trProj world scope model.keys.uvars (calls (.sort u info)) depth where + within n hn := by + cases n with + | zero => exact Methods.CallDomain.empty_within scope + | succ n => + exact Methods.CallDomain.singletonInfer_within hsourceSupport + step n hn := by + let context := InferenceCallDomainContext.sort hcollision hsourceSupport + hresultSupport theory references (calls (.sort u info) n) + simpa [calls] using (next_sort_wfAtOn context) + +/-- In particular, recursion fuel one has two justified body layers: the +public body and its one-layer callback table. -/ +theorem two + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {model : KernelSuffixModel trProj world} + {u : KUniv .anon} {info : ExprInfo .anon} + (hcollision : scope.CollisionFree) + (hsourceSupport : scope (.sort u info)) + (hresultSupport : scope (KExpr.mkSort (KUniv.mkSucc u))) + (theory : WhnfTheory trProj world model.keys.uvars) + (references : RecM.TrustedReferences world scope) : + CallScheduleAt .noAccel (kernelCacheSemantics model.keys trProj) + trProj world scope model.keys.uvars (calls (.sort u info)) 2 := + finite hcollision hsourceSupport hresultSupport theory references 2 + +end SortSchedule + +end Methods + +namespace TcM.infer + +/-- A public sort-inference run at any finite recursion fuel. The source and +its successor-sort result share one fixed finite result/collision footprint, +while the call schedule contains only the source at each positive table +depth. -/ +theorem sort_wf_bounded + {initial : TcState .anon} {requests : List WalkerRequest} + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {proposition : PropositionClassifierContext trProj world scope} + {u : KUniv .anon} {info : ExprInfo .anon} + (run : RunAssumptions initial (TcM.infer (.sort u info)) requests scope) + (hcollision : scope.CollisionFree) + (hsourceSupport : scope (.sort u info)) + (hresultSupport : scope (KExpr.mkSort (KUniv.mkSucc u))) + (theory : WhnfTheory trProj world proposition.model.keys.uvars) + (references : RecM.TrustedReferences world scope) + {Delta : KVLCtx} {sourceV : Lean4Lean.VExpr} + (hsource : TrKExprS world.venv proposition.model.keys.uvars world.nameOf + trProj Delta (.sort u info) sourceV) : + TcM.WF + (WhnfStateInv .noAccel + (kernelCacheSemantics proposition.model.keys trProj) trProj world + scope proposition.model.keys.uvars Delta) + initial (TcM.infer (.sort u info)) + (fun result _ => scope result ∧ + InferPost trProj world proposition.model.keys.uvars Delta sourceV + result) := by + let context : RecursiveMethodRunContext initial + (TcM.infer (.sort u info)) requests trProj world scope := { + run := run + proposition := proposition + calls := Methods.SortSchedule.calls (.sort u info) + schedule := Methods.SortSchedule.finite hcollision hsourceSupport + hresultSupport theory references (initial.recFuel.toNat + 1) } + exact TcM.infer.wf_legacy context (by + change (.sort u info : KExpr .anon) = .sort u info + rfl) hsource + +/-- Explicit positive-fuel specialization. At recursion fuel one, production +uses `methodsN 1` for callbacks and the schedule certifies its outer body at +depth two. -/ +theorem sort_wf_fuel_one + {initial : TcState .anon} {requests : List WalkerRequest} + {trProj : RawProjRel} {world : VerifyWorld} {scope : RunSupport} + {proposition : PropositionClassifierContext trProj world scope} + {u : KUniv .anon} {info : ExprInfo .anon} + (hfuel : initial.recFuel.toNat = 1) + (run : RunAssumptions initial (TcM.infer (.sort u info)) requests scope) + (hcollision : scope.CollisionFree) + (hsourceSupport : scope (.sort u info)) + (hresultSupport : scope (KExpr.mkSort (KUniv.mkSucc u))) + (theory : WhnfTheory trProj world proposition.model.keys.uvars) + (references : RecM.TrustedReferences world scope) + {Delta : KVLCtx} {sourceV : Lean4Lean.VExpr} + (hsource : TrKExprS world.venv proposition.model.keys.uvars world.nameOf + trProj Delta (.sort u info) sourceV) : + TcM.WF + (WhnfStateInv .noAccel + (kernelCacheSemantics proposition.model.keys trProj) trProj world + scope proposition.model.keys.uvars Delta) + initial (TcM.infer (.sort u info)) + (fun result _ => scope result ∧ + InferPost trProj world proposition.model.keys.uvars Delta sourceV + result) := by + let context : RecursiveMethodRunContext initial + (TcM.infer (.sort u info)) requests trProj world scope := { + run := run + proposition := proposition + calls := Methods.SortSchedule.calls (.sort u info) + schedule := by + rw [hfuel] + exact Methods.SortSchedule.two hcollision hsourceSupport + hresultSupport theory references } + exact TcM.infer.wf_legacy context (by + change (.sort u info : KExpr .anon) = .sort u info + rfl) hsource + +end TcM.infer + +end Ix.Tc diff --git a/Ix/Tc/Verify/ScopedSuffix/ClosedContext.lean b/Ix/Tc/Verify/ScopedSuffix/ClosedContext.lean new file mode 100644 index 000000000..1a3123f57 --- /dev/null +++ b/Ix/Tc/Verify/ScopedSuffix/ClosedContext.lean @@ -0,0 +1,194 @@ +import Ix.Tc.Verify.DefEq + +/-! +# Finite suffix model for closed checker states + +Closed public inputs take the real `ctxAddrForLbr` fast path for every loose +bound-variable radius. Their normalized semantic suffix input is therefore +just the reconciled ghost context, which is `[]`; the finite digest scope is +a singleton and its collision theorem is constructive. + +This is a production instantiation, not a mock key oracle: `execution` is +proved from `TcM.ctxAddrForLbr_empty`, and the model's state predicate fixes +the concrete fields needed to derive the empty reconciliation. +-/ + +namespace Ix.Tc + +/-- Concrete eager checker states with no legacy/opened local bindings and +no driver-owned lazy-ingress hook. -/ +structure ClosedContextState (s : TcState .anon) : Prop where + ctx : s.ctx = #[] + letVals : s.letVals = #[] + numLetBindings : s.numLetBindings = 0 + lctx : s.lctx = {} + lazyFault : s.lazyFault = none + +namespace ClosedContextState + +/-- A suffix memo update cannot open a local context. -/ +theorem contextKeyFrame {before after : TcState .anon} + (hbefore : ClosedContextState before) + (hframe : ContextKeyFrame before after) : + ClosedContextState after := by + rw [hframe] + exact { + ctx := hbefore.ctx + letVals := hbefore.letVals + numLetBindings := hbefore.numLetBindings + lctx := hbefore.lctx + lazyFault := hbefore.lazyFault } + +/-- Digest-neutral cache/intern updates retain closedness. -/ +theorem contextDigestFrame {before after : TcState .anon} + (hbefore : ClosedContextState before) + (hframe : ContextDigestFrame before after) : + ClosedContextState after where + ctx := hframe.ctx.trans hbefore.ctx + letVals := hframe.letVals.trans hbefore.letVals + numLetBindings := hframe.numLetBindings.trans hbefore.numLetBindings + lctx := hframe.lctx.trans hbefore.lctx + lazyFault := hframe.lazyFault.trans hbefore.lazyFault + +/-- Reconciliation from a concretely closed state has exactly the empty +semantic local context. -/ +theorem delta_eq_nil + {env : Lean4Lean.VEnv} {uvars : Nat} + {nameOf : Address → Option Lean.Name} {trProj : RawProjRel} + {s : TcState .anon} {Delta : KVLCtx} + (hclosed : ClosedContextState s) + (hctx : CtxRecon env uvars nameOf trProj s Delta) : + Delta = [] := by + have hrecon := hctx.recon + rw [hclosed.ctx, hclosed.letVals, hclosed.lctx] at hrecon + cases hrecon + rfl + +end ClosedContextState + +namespace ClosedContextDigest + +/-- Exact normalized input for the closed-context production path. The +radius is intentionally erased: with no legacy frames every request denotes +the same empty semantic suffix. -/ +def spec (trProj : RawProjRel) (world : VerifyWorld) (uvars : Nat) : + ContextDigestSpec trProj world uvars where + Input := KVLCtx + inputOf := fun _ Delta => Delta + digest := fun _ => emptyCtxAddr + StateValid := ClosedContextState + memoValid := by + intro s hclosed lbr cached hactive hlookup + simp [hclosed.ctx] at hactive + preserves := by + intro before after lbr ctxAddr hclosed hrun + exact hclosed.contextKeyFrame (TcM.ctxAddrForLbr_frame hrun) + framePreserves := by + intro before after hclosed hframe + exact hclosed.contextDigestFrame hframe + execution := by + intro before after lbr ctxAddr Delta hclosed hctx hrun + have hempty : before.ctx.isEmpty = true := by + simp [hclosed.ctx] + have heval := TcM.ctxAddrForLbr_empty hempty lbr + rw [heval] at hrun + injection hrun + +/-- The one normalized context input reachable from a closed state. -/ +def scope {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} : + ContextDigestScope (spec trProj world uvars) where + entries := [[]] + +/-- A singleton composite-input scope is collision-free independently of the +expression/universe address assumptions. -/ +theorem scope_collisionFree + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} : + (scope (trProj := trProj) (world := world) (uvars := uvars)).CollisionFree := by + intro left right hleft hright hdigest + simp [ContextDigestScope.Contains, scope] at hleft hright + subst left + subst right + rfl + +/-- Every possible suffix-key request from a closed reconciled state lands in +the singleton normalized-input scope. -/ +theorem scope_captures + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {s : TcState .anon} (hclosed : ClosedContextState s) : + (scope (trProj := trProj) (world := world) (uvars := uvars)).Captures s := by + intro after lbr ctxAddr Delta hctx hrun + have hDelta : Delta = [] := hclosed.delta_eq_nil hctx + subst Delta + simp only [ContextDigestScope.Contains, scope, spec] + exact List.mem_cons_self + +/-- Equality of normalized closed-context inputs is literal context equality, +so every semantic judgment transports by substitution. -/ +def suffixSemantics + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} : + ContextSuffixSemantics (spec trProj world uvars) where + whnf hinput hmeaning := by + cases hinput + exact hmeaning + infer hinput hmeaning := by + cases hinput + exact hmeaning + defEq hinput hmeaning := by + cases hinput + exact hmeaning + isProp hinput hmeaning := by + cases hinput + exact hmeaning + +/-- The concrete finite model used by closed positive-fuel executions. -/ +def model (trProj : RawProjRel) (world : VerifyWorld) (uvars : Nat) : + ScopedKernelSuffixModel trProj world := + ScopedKernelSuffixModel.finiteOperational (spec trProj world uvars) + scope scope_collisionFree suffixSemantics + +/-- Closedness supplies both parts of the finite model's state-domain +witness: production-state validity and singleton input capture. -/ +theorem model_stateInScope + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {s : TcState .anon} (hclosed : ClosedContextState s) : + (model trProj world uvars).StateInScope s := + ⟨hclosed, scope_captures hclosed⟩ + +/-- Membership in the concrete closed-state domain rules out lazy ingress. -/ +theorem model_noLazy + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {s : TcState .anon} + (hscope : (model trProj world uvars).StateInScope s) : + s.lazyFault = none := + hscope.1.lazyFault + +/-- The concrete closed model satisfies the driver's lazy-ingress contract +constructively: an in-scope state cannot contain a hook. -/ +theorem model_lazyFaultPreserves + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} + {layer : WhnfLayer} {support : RunSupport} {Delta : KVLCtx} : + TcM.LazyFaultPreserves + (ScopedWhnfStateInv (model trProj world uvars) layer + (kernelCacheSemantics (model trProj world uvars).keys trProj) + support Delta) := + TcM.LazyFaultPreserves.of_none fun hI => model_noLazy hI.2 + +/-- Production reset writes exactly the closed-context fields required by +the singleton suffix model, so it returns every in-scope input to the same +finite state domain. -/ +theorem model_resetPreservesScope + {trProj : RawProjRel} {world : VerifyWorld} {uvars : Nat} : + (model trProj world uvars).ResetPreservesScope := by + intro before after hbefore hrun + have hnoLazy := model_noLazy hbefore + have hclosed : ClosedContextState after := by + unfold TcM.reset at hrun + injection hrun with hafter + subst after + constructor <;> try rfl + exact hnoLazy + exact model_stateInScope hclosed + +end ClosedContextDigest + +end Ix.Tc diff --git a/Ix/Tc/Verify/State.lean b/Ix/Tc/Verify/State.lean index b8b32129f..878541a03 100644 --- a/Ix/Tc/Verify/State.lean +++ b/Ix/Tc/Verify/State.lean @@ -130,6 +130,27 @@ def KernelTcInv (semantics : CacheSemantics) (trProj : RawProjRel) namespace KernelStateWF +/-- Rebase a stable kernel invariant after ghost-only world growth. The +caller supplies the core relation for the larger world (normally produced by +`TcStateWF.promote`); cache and equivalence-manager facts transport +monotonically along the same world extension. -/ +theorem rebaseWorld {semantics : CacheSemantics} + {trProj : RawProjRel} {beforeWorld afterWorld : VerifyWorld} + {support : RunSupport} {s : TcState .anon} + (hle : beforeWorld ≤ afterWorld) + (hcore : TcStateWF trProj s afterWorld) + (h : KernelStateWF semantics trProj beforeWorld support s) : + KernelStateWF semantics trProj afterWorld support s := by + have hauth : CacheAuthority.stable beforeWorld ≤ + CacheAuthority.stable afterWorld := + CacheAuthority.stable_mono hle + exact + { core := hcore + internSupport := h.internSupport + caches := h.caches.mono hauth + equivalences := h.equivalences.mono + (fun hrel => semantics.equivMono hauth hrel) } + /-- Build the complete state invariant when the physical environment has no semantic cache entries. Constants, blocks, and intern tables may be nonempty. -/ theorem of_no_cache_entries {semantics : CacheSemantics} diff --git a/Ix/Tc/Verify/Statements.lean b/Ix/Tc/Verify/Statements.lean index 2f73dd28e..5d457294f 100644 --- a/Ix/Tc/Verify/Statements.lean +++ b/Ix/Tc/Verify/Statements.lean @@ -1,154 +1,52 @@ -import Ix.Tc.Check -import Ix.Tc.Verify.Execution -import Ix.Tc.Verify.State -import Lean4Lean.Theory.VEnv +import Ix.Tc.Verify.Check.PublicStandalone +import Ix.Tc.Verify.Check.PublicBlocks +import Ix.Tc.Verify.Driver.BooleanAcceptance +import Ix.Tc.Verify.Ingress.SerializedBoolean +import Ix.Tc.Verify.RecursiveMethods.Public /-! -# Statement skeleton: the headline `.WF` shapes - -Sorried statements of the program's target theorems, written against -the Hoare kernel (Verify/Monad.lean). The translation relations and the -run cache contract are `opaque` stubs — *stubs with types*: every statement -below is a legal proposition today whose shape changes only at named -architecture milestones as the concrete relations (`TrKExprS`/`TrKExpr` in -Verify/Trans.lean, finite `RunSupport`/`ResourceBounds` in -Verify/Support.lean, execution-indexed `RunAssumptions` in -Verify/Execution.lean, and `KernelTcInv`/`TrustedConstRel` in -Verify/State.lean and Verify/Env.lean) replace the stubs. G4 has replaced -the state-invariant stub itself; the judgment-level relations below and the -cache contract remain provisional. -Judgment plumbing (universe counts, contexts) deliberately routes through -the stub relations so the shapes don't churn while that plumbing is -designed; the theory anchor is `Lean4Lean`'s `VExpr`/`VConstant`. - -Two quantifier choices are load-bearing: - -* The cache contract is the fixed stub `StatementCacheSemantics`, not a - universally quantified `CacheSemantics`. `CacheSemantics` demands only the - `mono`/`blockError` laws, so degenerate contracts (e.g. - `CacheSemantics.blockErrorsOnly`, Verify/Whnf.lean) reject entries the - checker legitimately inserts; a `∀ semantics` triple would be falsified by - any run that warms a cache. The K1 insertion machinery is proved only for - the concrete `whnfCacheSemantics` family, and that family is what the stub - denotes on the WHNF slice. -* `support` is one fixed finite domain across the whole triple, on both - outcomes. This is honest because `RunAssumptions` covers the initial - intern range plus every recorded request, and `ExecutionRequests` confines - the run's interning to those requests (silent transitions must preserve - the intern table), so the fixed support prospectively covers the intern - table of every reachable post-state. - -Sorry frontier: every theorem in this file (they acquire proofs as the -whnf/infer/checkConst soundness layers land); the stubs themselves are -not sorries. +# Public checker theorem frontier + +All seven public theorem roots now use the concrete verification relations and +a finite, fuel-indexed production call schedule: + +* `TcM.whnf.wf`, `TcM.infer.wf`, and `TcM.isDefEq.wf` are the C1A adapters + from `RecursiveMethods/Public.lean`; +* `TcM.checkConst.wf` is K3's standalone axiom/definition-family theorem, + starting from `PendingDecl` and untyped validator ingress and producing a + real `StandaloneCheckResult`, a `VDecl.WF`-backed trusted-world promotion, + and the promoted post-state invariant; and +* `TcM.checkConst.blockDisposition` is E0's exhaustive successful-dispatch + theorem: the production call either performs one exact atomic coordinated + admission or takes the separately verified standalone branch; and +* `BooleanEnumerationFixture.subjectWF` is the E3-S acceptance root: the + production serial driver successfully checks the exact six-entry Boolean + source environment, and its two coordinated work rows satisfy `SubjectWF` + through transparent run-scoped K3/E0 resources, an explicit empty + assumption set, and certificate-backed E2 inductive evidence. +* `BooleanSerialized.subjectWF` is the T0-S representation root: the same + semantic result is connected to a successful pure Ixon byte decode, exact + hash-verified eager and cold-lazy ingress, serialized dependency refs, and + a successful run of the production anonymous driver. + +The K3 statement deliberately exposes `StandaloneRoute`. E0 now closes the +coordinated transaction, physical/ghost identity, and cache-publication +layers. Singleton definition blocks are constructive. Inductive and +recursor bodies remain relative in the generic adapter to an explicitly +supplied `InductiveOracle` resource; the public E3-S root instantiates both +resources from the Lean4Lean Boolean generation certificate. Quotient +semantics, mutual/nested inductives, indexed or parameterized families, and +multi-definition blocks remain outside this certificate-backed release +fragment. Collision, finite-resource, lazy-ingress, source-to-router +agreement, projection, and upstream metatheory obligations remain visible in +`SupportedCheckRun` and its transparent body constructors. There are no +opaque semantic statement stubs and no local `sorry` frontier in this module. + +The public root is defined at the end of the production proof itself rather +than copied or proof-erased here. This module is only the stable import +frontier, so its exported statement cannot drift from the actual validator, +bounded full-inference pipeline, fresh lookup, routing, atomic publication, +and rollback-aware checker implementation. The bounded roots are audited +against any dependency on the legacy all-depth +`RecursiveMethodClosureContext`. -/ - -namespace Ix.Tc - -open Lean4Lean (VExpr VConstant) - -/-- Cache contract under which the headline runs are stated: the semantic -meaning of every warm cache family the checker may populate. Its K1 slice is -the concrete `whnfCacheSemantics` family (Verify/Whnf.lean) over the -K2-constructed context-key model; the inference/defeq families land with K2. -The contract is a fixed stub rather than a quantified `CacheSemantics` -because the structure's `mono`/`blockError` laws alone admit contracts that -reject legitimately inserted entries, which no cache-warming run could -preserve. -/ -opaque StatementCacheSemantics : RawProjRel → CacheSemantics - -/-- The headline invariant is the concrete G4 invariant under the statement -cache contract: some current trusted world extends the caller's baseline and -justifies the loaded catalog, intern range, and every warm cache entry under -one finite run support. -/ -def KernelRunInv (trProj : RawProjRel) - (world₀ : VerifyWorld) (support : RunSupport) - (s : TcState .anon) : Prop := - KernelTcInv (StatementCacheSemantics trProj) trProj world₀ support s - -/-- Expression translation: `KExpr` denotes this theory-level `VExpr` in - the current state's context (the `TrExprS` analog over `KVLCtx`, - with owned `prj`/literal cases; concrete form: `TrKExprS`, - Verify/Trans.lean). -/ -opaque StatementTrKExpr : - {m : Mode} → TcState m → KExpr m → VExpr → Prop - -/-- Constant translation: the constant at `id` denotes this theory-level - `VConstant` (concrete G2b interface: exact loaded/trusted resolution via - `TrustedConstRel`, Verify/Env.lean). -/ -opaque StatementTrKConst : - {m : Mode} → TcState m → KId m → VConstant → Prop - -/-- The state's environment translates to a well-formed `VEnv` extension - in which `d` is a valid constant (the `NativeOracle` defeqs - enter as the env's `.extra` judgments). -/ -opaque StatementTrustedConst : - {m : Mode} → TcState m → VConstant → Prop - -/-- Theory-level definitional equality of the translations, in the - current state's environment and context (translation-layer plumbing). -/ -opaque StatementKDefEqU : - {m : Mode} → TcState m → VExpr → VExpr → Prop - -/-- Theory-level typing of the translations (translation-layer plumbing). -/ -opaque StatementKHasType : - {m : Mode} → TcState m → VExpr → VExpr → Prop - -/-- **`whnf` soundness shape**: reduction preserves the translation - up to theory-level defeq. -/ -theorem TcM.whnf.wf {s : TcState .anon} {e : KExpr .anon} {ve : VExpr} - {trProj : RawProjRel} - {world₀ : VerifyWorld} - {support : RunSupport} {requests : List WalkerRequest} - (hrun : RunAssumptions s (TcM.whnf e) requests support) - (he : StatementTrKExpr s e ve) : - TcM.WF (KernelRunInv trProj world₀ support) s (TcM.whnf e) - (fun e' s' => ∃ ve', StatementTrKExpr s' e' ve' ∧ - StatementKDefEqU s' ve ve') := by - sorry - -/-- **`infer` soundness shape**: the inferred type translates and - types the subject. -/ -theorem TcM.infer.wf {s : TcState .anon} {e : KExpr .anon} {ve : VExpr} - {trProj : RawProjRel} - {world₀ : VerifyWorld} - {support : RunSupport} {requests : List WalkerRequest} - (hrun : RunAssumptions s (TcM.infer e) requests support) - (he : StatementTrKExpr s e ve) : - TcM.WF (KernelRunInv trProj world₀ support) s (TcM.infer e) - (fun ty s' => ∃ vty, StatementTrKExpr s' ty vty ∧ - StatementKHasType s' ve vty) := by - sorry - -/-- **`isDefEq` soundness shape**: a `true` verdict implies - theory-level definitional equality. (`false` implies nothing — - incompleteness is not unsoundness.) -/ -theorem TcM.isDefEq.wf {s : TcState .anon} - {a b : KExpr .anon} {va vb : VExpr} - {trProj : RawProjRel} - {world₀ : VerifyWorld} - {support : RunSupport} {requests : List WalkerRequest} - (hrun : RunAssumptions s (TcM.isDefEq a b) requests support) - (ha : StatementTrKExpr s a va) (hb : StatementTrKExpr s b vb) : - TcM.WF (KernelRunInv trProj world₀ support) s - (TcM.isDefEq a b) - (fun r s' => r = true → StatementKDefEqU s' va vb) := by - sorry - -/-- **`checkConst` soundness shape** (the headline): acceptance means - the constant translates to a trusted theory-level constant — - conditional on the concrete execution-indexed finite run assumptions - (and, inside `StatementTrustedConst`, the `NativeOracle` defeqs and - upstream Theory debt). -/ -theorem TcM.checkConst.wf {s : TcState .anon} {id : KId .anon} - {trProj : RawProjRel} - {world₀ : VerifyWorld} - {support : RunSupport} {requests : List WalkerRequest} - (hrun : RunAssumptions s (TcM.checkConst id) requests support) : - TcM.WF (KernelRunInv trProj world₀ support) s - (TcM.checkConst id) - (fun _ s' => ∃ d, StatementTrKConst s' id d ∧ - StatementTrustedConst s' d) := by - sorry - -end Ix.Tc diff --git a/Ix/Tc/Verify/Suffix.lean b/Ix/Tc/Verify/Suffix.lean index cc2cf5bfb..9532e384a 100644 --- a/Ix/Tc/Verify/Suffix.lean +++ b/Ix/Tc/Verify/Suffix.lean @@ -64,6 +64,32 @@ theorem ctxAddrForLbr_cacheMiss simp [hactive, hcache] rfl +/-- Suffix-key construction is total. Naming this fact lets finite run +scopes reason about a context before a later memo write without appealing to +an untracked partial execution. -/ +theorem ctxAddrForLbr_total (lbr : UInt64) (s : TcState .anon) : + ∃ ctxAddr after, ctxAddrForLbr lbr s = .ok ctxAddr after := by + cases hactive : (lbr == 0 || s.ctx.isEmpty) with + | true => exact ⟨_, _, ctxAddrForLbr_trivial hactive⟩ + | false => + cases hcache : s.ctxAddrCache[(s.ctxId, lbr)]? with + | some cached => + exact ⟨_, _, ctxAddrForLbr_cacheHit hactive hcache⟩ + | none => + exact ⟨_, _, ctxAddrForLbr_cacheMiss hactive hcache⟩ + +/-- Every successful suffix-key execution has exactly the memo-only state +frame exposed by the generic Hoare proof. -/ +theorem ctxAddrForLbr_frame + {lbr : UInt64} {before after : TcState .anon} {ctxAddr : Address} + (hrun : ctxAddrForLbr lbr before = .ok ctxAddr after) : + ContextKeyFrame before after := by + have hwf := ctxAddrForLbr_wf + (I := fun _ : TcState .anon => True) + (fun _ _ => trivial) lbr before trivial + rw [hrun] at hwf + exact hwf.2 + /-- 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. -/ @@ -224,6 +250,62 @@ end operationalWhnfContextKeys /-! ## Finite composite-digest boundary -/ +/-- Exact frame for state updates which cannot affect suffix-key inputs or +their memo coherence. Environment caches and the intern table may change, +but every concrete field consulted by `ctxAddrForLbr` and every field needed +to reconcile the same ghost context is fixed. + +Context push/pop/open operations intentionally do not satisfy this frame; +their new scoped-state witnesses must be supplied by the finite execution +certificate. -/ +structure ContextDigestFrame (before after : TcState .anon) : Prop where + ctx : after.ctx = before.ctx + letVals : after.letVals = before.letVals + numLetBindings : after.numLetBindings = before.numLetBindings + ctxId : after.ctxId = before.ctxId + ctxIdStack : after.ctxIdStack = before.ctxIdStack + ctxAddrCache : after.ctxAddrCache = before.ctxAddrCache + lctx : after.lctx = before.lctx + nextFVarId : after.env.nextFVarId = before.env.nextFVarId + lazyFault : after.lazyFault = before.lazyFault + +namespace ContextDigestFrame + +@[refl] theorem refl (s : TcState .anon) : ContextDigestFrame s s where + ctx := rfl + letVals := rfl + numLetBindings := rfl + ctxId := rfl + ctxIdStack := rfl + ctxAddrCache := rfl + lctx := rfl + nextFVarId := rfl + lazyFault := rfl + +theorem trans {a b c : TcState .anon} + (hab : ContextDigestFrame a b) (hbc : ContextDigestFrame b c) : + ContextDigestFrame a c where + ctx := hbc.ctx.trans hab.ctx + letVals := hbc.letVals.trans hab.letVals + numLetBindings := hbc.numLetBindings.trans hab.numLetBindings + ctxId := hbc.ctxId.trans hab.ctxId + ctxIdStack := hbc.ctxIdStack.trans hab.ctxIdStack + ctxAddrCache := hbc.ctxAddrCache.trans hab.ctxAddrCache + lctx := hbc.lctx.trans hab.lctx + nextFVarId := hbc.nextFVarId.trans hab.nextFVarId + lazyFault := hbc.lazyFault.trans hab.lazyFault + +/-- Intern-table growth cannot change the normalized context-suffix input. +This bridge lets scoped proofs reuse the exact intern-only frame already +produced throughout the WHNF and inference verification. -/ +theorem ofInternUpdateFrame {before after : TcState .anon} + (hframe : InternUpdateFrame before after) : + ContextDigestFrame before after := by + rw [hframe] + constructor <;> rfl + +end ContextDigestFrame + /-- Declarative specification of the exact composite input hashed by `ctxAddrForLbr`. @@ -253,6 +335,11 @@ structure ContextDigestSpec (trProj : RawProjRel) (world : VerifyWorld) StateValid before → TcM.ctxAddrForLbr lbr before = .ok ctxAddr after → StateValid after + /-- State validity is insensitive to updates outside the digest-relevant + state projection. Cache writes and interning use this field; context + transitions do not. -/ + framePreserves : ∀ {before after : TcState .anon}, + StateValid before → ContextDigestFrame before after → StateValid after execution : ∀ {before after : TcState .anon} {lbr : UInt64} {ctxAddr : Address} {Delta : KVLCtx}, StateValid before → @@ -295,6 +382,42 @@ def Captures (scope : ContextDigestScope spec) TcM.ctxAddrForLbr lbr before = .ok ctxAddr after → scope.Contains (spec.inputOf lbr Delta) +/-- Adding or replacing suffix-memo entries does not enlarge the semantic +context-input domain required by a state. Reconciliation ignores the memo, +and totality supplies the corresponding execution from the pre-frame state. +This is the missing chaining fact for repeated scoped key computations. -/ +theorem Captures.contextKeyFrame + {scope : ContextDigestScope spec} {before after : TcState .anon} + (hcapture : scope.Captures before) + (hframe : ContextKeyFrame before after) : + scope.Captures after := by + intro final lbr ctxAddr Delta hctx _hrun + have hctxBefore : + CtxRecon world.venv uvars world.nameOf trProj before Delta := by + rw [hframe] at hctx + exact hctx.of_fields_eq rfl rfl rfl rfl (by simp) + obtain ⟨beforeAddr, beforeFinal, hbeforeRun⟩ := + TcM.ctxAddrForLbr_total lbr before + exact hcapture hctxBefore hbeforeRun + +/-- A state update fixing the digest-relevant projection also preserves the +finite set of semantic inputs required by that state. -/ +theorem Captures.contextDigestFrame + {scope : ContextDigestScope spec} {before after : TcState .anon} + (hcapture : scope.Captures before) + (hframe : ContextDigestFrame before after) : + scope.Captures after := by + intro final lbr ctxAddr Delta hctx _hrun + have hctxBefore : + CtxRecon world.venv uvars world.nameOf trProj before Delta := by + exact hctx.of_fields_eq hframe.ctx.symm hframe.letVals.symm + hframe.numLetBindings.symm hframe.lctx.symm (by + rw [hframe.nextFVarId] + exact Nat.le_refl _) + obtain ⟨beforeAddr, beforeFinal, hbeforeRun⟩ := + TcM.ctxAddrForLbr_total lbr before + exact hcapture hctxBefore hbeforeRun + end ContextDigestScope /-- The operational representation restricted to a finite run scope. Both diff --git a/Ix/Tc/Verify/Totalization.lean b/Ix/Tc/Verify/Totalization.lean index 6fce3dd56..37c6a6984 100644 --- a/Ix/Tc/Verify/Totalization.lean +++ b/Ix/Tc/Verify/Totalization.lean @@ -469,6 +469,21 @@ theorem RecM.charOfNatExpr_equation (n : Nat) : let natLit ← TcM.intern (RecM.natExprFromValue n : KExpr m) return some (← TcM.intern (KExpr.mkApp charOfNat natLit)) := rfl +theorem RecM.tryReduceStringLiteral_equation (p : Primitives m) + (id : KId m) (s : String) : + RecM.tryReduceStringLiteral p id s = (do + let isUtf8ByteSize := id.addr == p.stringUtf8ByteSize.addr + let isToByteArray := id.addr == p.stringToByteArray.addr + if isUtf8ByteSize then + return some (← TcM.intern + (RecM.natExprFromValue s.utf8ByteSize : KExpr m)) + if isToByteArray then + if s.isEmpty then + return some (← TcM.intern (.mkConst p.byteArrayEmpty #[])) + return none + let codepoint := (s.toList.getLast?.map (·.toNat)).getD 65 + RecM.charOfNatExpr codepoint) := rfl + theorem RecM.tryReduceString_equation (e : KExpr m) : RecM.tryReduceString e = (do let (head, args) := e.collectSpine @@ -738,24 +753,29 @@ theorem RecM.validateExprWellScoped_go_app RecM.peelRuleIhForalls.go flat root #[] := rfl @[simp] theorem RecM.checkPositivityDomain_equation - (dom : KExpr m) (blockAddrs : Array Address) : - RecM.checkPositivityDomain dom blockAddrs = - RecM.checkPositivityDomainFuel maxWhnfFuel.toNat dom blockAddrs := rfl + (dom : KExpr m) (groups : Array (PositivityGroup m)) + (activeAddrs : Array Address) : + RecM.checkPositivityDomain dom groups activeAddrs = + RecM.checkPositivityDomainFuel maxWhnfFuel.toNat dom groups + activeAddrs := rfl @[simp] theorem RecM.checkPositivityDomainFuel_zero - (dom : KExpr m) (blockAddrs : Array Address) : - RecM.checkPositivityDomainFuel 0 dom blockAddrs = + (dom : KExpr m) (groups : Array (PositivityGroup m)) + (activeAddrs : Array Address) : + RecM.checkPositivityDomainFuel 0 dom groups activeAddrs = throw .maxRecDepth := rfl @[simp] theorem RecM.checkNestedCtorFieldsFuel_zero (ctorTy : KExpr m) (nParams : Nat) (paramArgs : Array (KExpr m)) - (us : Array (KUniv m)) (augmentedAddrs : Array Address) : + (us : Array (KUniv m)) (groups : Array (PositivityGroup m)) + (activeAddrs : Array Address) : RecM.checkNestedCtorFieldsFuel 0 ctorTy nParams paramArgs us - augmentedAddrs = throw .maxRecDepth := rfl + groups activeAddrs = throw .maxRecDepth := rfl @[simp] theorem RecM.checkNestedCtorFieldsLoopFuel_zero - (ty : KExpr m) (augmentedAddrs : Array Address) : - RecM.checkNestedCtorFieldsLoopFuel 0 ty augmentedAddrs = + (ty : KExpr m) (groups : Array (PositivityGroup m)) + (activeAddrs : Array Address) : + RecM.checkNestedCtorFieldsLoopFuel 0 ty groups activeAddrs = throw .maxRecDepth := rfl theorem RecM.countForalls_equation (ty : KExpr m) : diff --git a/Ix/Tc/Verify/Whnf.lean b/Ix/Tc/Verify/Whnf.lean index db206771c..95d21ff1e 100644 --- a/Ix/Tc/Verify/Whnf.lean +++ b/Ix/Tc/Verify/Whnf.lean @@ -300,18 +300,26 @@ end WhnfContextKeys.Matches namespace CacheSemantics -/-- Minimal fallback used by a WHNF-only verification slice: cached block -errors remain replayable, while every semantic family not owned by K1 is -rejected. K2 replaces this fallback when inference and defeq caches become -available. -/ -def blockErrorsOnly : CacheSemantics where - Valid _ _ entry := +/-- Minimal fallback used by reducer-only verification slices: cached block +errors remain replayable, and a cached success is accepted exactly when its +immutable block catalog entry is nonempty and every exact member is trusted. +Every non-block semantic family is rejected. -/ +def blockResults : CacheSemantics where + Valid authority _ entry := match entry with + | .blockResult block (.ok ()) => authority.world.AcceptedBlock block | .blockResult _ (.error _) => True | _ => False mono := by intro before after support entry hle h - exact h + cases entry with + | blockResult block result => + cases result with + | ok value => + cases value + exact h.mono hle.world + | error => trivial + | _ => exact h Equiv _ _ := Eq equivEquivalence := by intro authority support @@ -322,6 +330,17 @@ def blockErrorsOnly : CacheSemantics where blockError := by intro authority support block err trivial + blockSuccess := by + intro authority support block h + exact h + blockSuccessSound := by + intro authority support block h + exact h + +/-- Compatibility spelling retained for existing K1/K2 clients. Unlike its +pre-E0 definition, successful block verdicts now have the exact sound meaning +specified by `blockResults`. -/ +abbrev blockErrorsOnly : CacheSemantics := blockResults end CacheSemantics @@ -377,6 +396,12 @@ def isRecCacheSemantics (fallback : CacheSemantics) : CacheSemantics where blockError := by intro authority support block err exact fallback.blockError authority support block err + blockSuccess := by + intro authority support block h + exact fallback.blockSuccess authority support block h + blockSuccessSound := by + intro authority support block h + exact fallback.blockSuccessSound authority support block h /-- 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 @@ -465,6 +490,12 @@ def whnfCacheSemantics (keys : WhnfContextKeys) (trProj : RawProjRel) blockError := by intro authority support block err exact fallback.blockError authority support block err + blockSuccess := by + intro authority support block h + exact fallback.blockSuccess authority support block h + blockSuccessSound := by + intro authority support block h + exact fallback.blockSuccessSound authority support block h namespace CacheProvenance @@ -699,6 +730,22 @@ def WhnfStateInv (layer : WhnfLayer) (semantics : CacheSemantics) namespace WhnfStateInv +/-- Transport a fixed-state method invariant across ghost-only trusted-world +growth. The larger-world core is supplied by the promotion theorem; context, +cache, and equivalence facts are monotone because promotion fixes the catalog +and address-to-name map. -/ +theorem rebaseWorld + {layer : WhnfLayer} {semantics : CacheSemantics} + {trProj : RawProjRel} {beforeWorld afterWorld : VerifyWorld} + {support : RunSupport} {uvars : Nat} {Δ : KVLCtx} + {s : TcState .anon} + (hle : beforeWorld ≤ afterWorld) + (hcore : TcStateWF trProj s afterWorld) + (h : WhnfStateInv layer semantics trProj beforeWorld support uvars Δ s) : + WhnfStateInv layer semantics trProj afterWorld support uvars Δ s := by + refine ⟨h.1.rebaseWorld hle hcore, ?_, h.2.2⟩ + simpa only [← hle.nameOf] using h.2.1.mono hle.venv + /-- Changing only operational bookkeeping fields preserves the complete fixed-world WHNF invariant. The explicit field equations keep fuel and instrumentation updates from being mistaken for semantic state changes. -/ diff --git a/Ix/Tc/Verify/Whnf/Delta/CacheSemantics.lean b/Ix/Tc/Verify/Whnf/Delta/CacheSemantics.lean index 52869e80e..8f721d12c 100644 --- a/Ix/Tc/Verify/Whnf/Delta/CacheSemantics.lean +++ b/Ix/Tc/Verify/Whnf/Delta/CacheSemantics.lean @@ -72,6 +72,12 @@ def unfoldCacheSemantics (uvars : Nat) (trProj : RawProjRel) blockError := by intro authority support block err exact fallback.blockError authority support block err + blockSuccess := by + intro authority support block h + exact fallback.blockSuccess authority support block h + blockSuccessSound := by + intro authority support block h + exact fallback.blockSuccessSound authority support block h namespace CacheProvenance diff --git a/Ix/Tc/Verify/Whnf/Iota/NatReduction.lean b/Ix/Tc/Verify/Whnf/Iota/NatReduction.lean index 3043f811a..9c34fe7d0 100644 --- a/Ix/Tc/Verify/Whnf/Iota/NatReduction.lean +++ b/Ix/Tc/Verify/Whnf/Iota/NatReduction.lean @@ -92,12 +92,14 @@ theorem checkedReduction {pattern : RecursorRulePattern} (hpattern : RawRecursorRulePatternRel env catalog nameOf id recursor rule pattern) + (henv : env.WF) {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} + (hGamma : Lean4Lean.OnCtx Gamma (env.IsType uvars)) (hmatch : Lean4Lean.Pattern.Matches (RecursorIotaPattern pattern.recursorName pattern.majorIdx pattern.constructorName @@ -111,7 +113,7 @@ theorem checkedReduction (pattern.rhs.apply levels captures) := by rcases hpattern with ⟨_, _, _, _, _, _, _, hsound⟩ - exact hsound Lean4Lean.VEnv.LE.rfl hmatch htype hchecks + exact hsound Lean4Lean.VEnv.LE.rfl henv hGamma hmatch htype hchecks end RawRecursorRulePatternRel @@ -169,7 +171,8 @@ theorem checkedRhsSuffix obtain ⟨throughType, hthroughType⟩ := hsuffix.startHasType hsourceType have hthroughEq := - hpattern.checkedReduction hmatch hthroughType hchecks + hpattern.checkedReduction world.venvWF hDelta.toCtx hmatch hthroughType + hchecks exact hsuffix.rebase world.venvWF hDelta hrhsTr hthroughEq end NatRecLiteralTranslationSplit diff --git a/Ix/Tc/Verify/Whnf/Iota/RuleSuffixTransport.lean b/Ix/Tc/Verify/Whnf/Iota/RuleSuffixTransport.lean index 1e7640413..31daeebf8 100644 --- a/Ix/Tc/Verify/Whnf/Iota/RuleSuffixTransport.lean +++ b/Ix/Tc/Verify/Whnf/Iota/RuleSuffixTransport.lean @@ -108,7 +108,8 @@ theorem checkedRhsSuffixQuot obtain ⟨throughType, hthroughType⟩ := hsuffix.startHasType hsourceType have hthroughEq := - hpattern.checkedReduction hmatch hthroughType hchecks + hpattern.checkedReduction world.venvWF hDelta.toCtx hmatch hthroughType + hchecks exact hsuffix.rebaseQuot world.venvWF hDelta hrhsTr hthroughEq end NatRecLiteralTranslationSplit diff --git a/Ix/Tc/Verify/Whnf/Iota/SelectedRule.lean b/Ix/Tc/Verify/Whnf/Iota/SelectedRule.lean index 4c30a228f..b53cf19a5 100644 --- a/Ix/Tc/Verify/Whnf/Iota/SelectedRule.lean +++ b/Ix/Tc/Verify/Whnf/Iota/SelectedRule.lean @@ -622,7 +622,8 @@ theorem checkedMeaning (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 + have hsourceFinal := hpattern.checkedReduction world.venvWF hDelta.toCtx + hmatch hsourceType hchecks change finalV = pattern.rhs.apply levels captures at haligned rw [← haligned] at hsourceFinal obtain ⟨resultV, hresultTr, hresultEq⟩ := hfinalTr diff --git a/Ix/Tc/Verify/Whnf/NoDelta/StringPrimitive.lean b/Ix/Tc/Verify/Whnf/NoDelta/StringPrimitive.lean index 53b1098c2..99af60b5d 100644 --- a/Ix/Tc/Verify/Whnf/NoDelta/StringPrimitive.lean +++ b/Ix/Tc/Verify/Whnf/NoDelta/StringPrimitive.lean @@ -133,6 +133,7 @@ theorem tryReduceString_inv_wf simp only [Bool.false_eq_true, if_false] cases harg : args[0]! with | str value blob stringInfo => + unfold tryReduceStringLiteral simp only cases hutf8 : (id.addr == prims.stringUtf8ByteSize.addr) with @@ -159,7 +160,7 @@ theorem tryReduceString_inv_wf simp only [if_true] cases hempty : value.isEmpty with | true => - simp only [if_true] + simp only [if_true, pure_bind] let requested : KExpr .anon := KExpr.mkConst prims.byteArrayEmpty #[] have hrequested : support requested := by @@ -179,7 +180,7 @@ theorem tryReduceString_inv_wf simp only [Bool.false_eq_true, if_false] exact RecM.WF.pure fun _ => trivial | false => - simp only [Bool.false_eq_true, if_false] + simp only [Bool.false_eq_true, if_false, pure_bind] have hback : (id.addr == prims.stringBack.addr || id.addr == diff --git a/Ix/Tc/Verify/World.lean b/Ix/Tc/Verify/World.lean index 63d864e1d..f5cad0701 100644 --- a/Ix/Tc/Verify/World.lean +++ b/Ix/Tc/Verify/World.lean @@ -9,6 +9,8 @@ whole-`KEnv` relation conflates: * `Catalog`: immutable ghost input, including pending and unrelated declarations; +* `BlockCatalog`: immutable ghost input recording the exact ordered members + assigned to each coordinated checker block; * `VerifyWorld.trusted`: the ghost index intended to track declarations already admitted to the semantic world; * `VerifyWorld.venv`: the well-formed Lean4Lean environment for that trusted @@ -51,6 +53,25 @@ def Contains (catalog : Catalog) (id : KId .anon) : Prop := end Catalog +/-- Immutable ghost block input. A successful block-cache verdict is only +meaningful relative to the exact ordered member array registered for its +block. As with `Catalog`, this is input identity rather than a typing fact. -/ +abbrev BlockCatalog := KId .anon → Option (Array (KId .anon)) + +namespace BlockCatalog + +/-- The empty block catalog. -/ +def empty : BlockCatalog := fun _ => none + +/-- `block` has this exact ordered member array in the immutable input. -/ +def Contains (blocks : BlockCatalog) (block : KId .anon) + (members : Array (KId .anon)) : Prop := + blocks block = some members + +@[simp] theorem empty_apply (block : KId .anon) : empty block = none := rfl + +end BlockCatalog + /-- Ghost semantic state for verification. `trustedCatalogued` is representation coherence only. It prevents the @@ -64,6 +85,9 @@ structure VerifyWorld where nameOf : Address → Option Lean.Name venvWF : venv.WF trustedCatalogued : ∀ {id}, trusted id → Catalog.Contains catalog id + /-- Exact block identity is immutable ghost input. The default preserves + the pre-E0 standalone fixtures, which do not exercise coordinated blocks. -/ + blocks : BlockCatalog := BlockCatalog.empty namespace VerifyWorld @@ -77,6 +101,19 @@ def ofCatalog (catalog : Catalog) : VerifyWorld where nameOf := fun _ => none venvWF := ⟨[], .empty⟩ trustedCatalogued := fun {_} h => False.elim h + blocks := BlockCatalog.empty + +/-- An arbitrary declaration and block catalog with no trusted declarations. +No typing or block-coherence premise is imposed at this input boundary. -/ +def ofCatalogAndBlocks (catalog : Catalog) (blocks : BlockCatalog) : + VerifyWorld where + catalog := catalog + trusted := fun _ => False + venv := .empty + nameOf := fun _ => none + venvWF := ⟨[], .empty⟩ + trustedCatalogued := fun {_} h => False.elim h + blocks := blocks /-- The completely empty verification world. -/ def empty : VerifyWorld := ofCatalog Catalog.empty @@ -90,6 +127,21 @@ def empty : VerifyWorld := ofCatalog Catalog.empty @[simp] theorem ofCatalog_venv (catalog : Catalog) : (ofCatalog catalog).venv = .empty := rfl +@[simp] theorem ofCatalog_blocks (catalog : Catalog) : + (ofCatalog catalog).blocks = BlockCatalog.empty := rfl + +@[simp] theorem ofCatalogAndBlocks_catalog (catalog : Catalog) + (blocks : BlockCatalog) : + (ofCatalogAndBlocks catalog blocks).catalog = catalog := rfl + +@[simp] theorem ofCatalogAndBlocks_blocks (catalog : Catalog) + (blocks : BlockCatalog) : + (ofCatalogAndBlocks catalog blocks).blocks = blocks := rfl + +@[simp] theorem ofCatalogAndBlocks_trusted (catalog : Catalog) + (blocks : BlockCatalog) (id : KId .anon) : + ¬(ofCatalogAndBlocks catalog blocks).trusted id := fun h => h + /-- Adversarial sanity check for the new boundary: a declaration can be catalogued without becoming trusted. There is intentionally no WF premise. -/ theorem ofCatalog_catalogued_not_trusted {catalog : Catalog} @@ -104,6 +156,7 @@ environment to grow. Concrete lazy-loaded entries are related separately by `LoadedExtension` below because they live in `KEnv`, not `VerifyWorld`. -/ protected structure LE (before after : VerifyWorld) : Prop where catalog : before.catalog = after.catalog + blocks : before.blocks = after.blocks nameOf : before.nameOf = after.nameOf trusted : ∀ {id}, before.trusted id → after.trusted id venv : before.venv ≤ after.venv @@ -113,10 +166,11 @@ instance : LE VerifyWorld := ⟨VerifyWorld.LE⟩ namespace LE theorem rfl {world : VerifyWorld} : world ≤ world := - ⟨Eq.refl _, Eq.refl _, fun {_} h => h, VEnv.LE.rfl⟩ + ⟨Eq.refl _, Eq.refl _, Eq.refl _, fun {_} h => h, VEnv.LE.rfl⟩ theorem trans {a b c : VerifyWorld} (hab : a ≤ b) (hbc : b ≤ c) : a ≤ c := ⟨hab.catalog.trans hbc.catalog, + hab.blocks.trans hbc.blocks, hab.nameOf.trans hbc.nameOf, fun {_} h => hbc.trusted (hab.trusted h), hab.venv.trans hbc.venv⟩ @@ -128,8 +182,47 @@ theorem catalogued_iff {before after : VerifyWorld} (h : before ≤ after) Catalog.Contains after.catalog id := by rw [h.catalog] +/-- Exact block identity is invariant under world extension. -/ +theorem block_iff {before after : VerifyWorld} (h : before ≤ after) + {block : KId .anon} {members : Array (KId .anon)} : + BlockCatalog.Contains before.blocks block members ↔ + BlockCatalog.Contains after.blocks block members := by + rw [h.blocks] + end LE +/-- Stable meaning of a successful coordinated-block verdict: the immutable +block catalog identifies a nonempty exact member array, and every one of +those members has been admitted to the semantic world. -/ +def AcceptedBlock (world : VerifyWorld) (block : KId .anon) : Prop := + ∃ members, BlockCatalog.Contains world.blocks block members ∧ + members.size > 0 ∧ ∀ id ∈ members, world.trusted id + +namespace AcceptedBlock + +/-- Acceptance cannot lose meaning as the trusted Theory world grows. -/ +theorem mono {before after : VerifyWorld} (hle : before ≤ after) + {block : KId .anon} (h : before.AcceptedBlock block) : + after.AcceptedBlock block := by + obtain ⟨members, hblock, hnonempty, htrusted⟩ := h + refine ⟨members, ?_, hnonempty, ?_⟩ + · simpa only [← hle.blocks] using hblock + · intro id hid + exact hle.trusted (htrusted id hid) + +/-- A successful block verdict covers every member of its exact catalogued +array; it cannot silently certify a proper subset. -/ +theorem trusted {world : VerifyWorld} {block id : KId .anon} + {members : Array (KId .anon)} (h : world.AcceptedBlock block) + (hblock : world.blocks block = some members) (hid : id ∈ members) : + world.trusted id := by + obtain ⟨actual, hactual, _, hall⟩ := h + have hm : actual = members := Option.some.inj (hactual.symm.trans hblock) + subst members + exact hall id hid + +end AcceptedBlock + end VerifyWorld /-- Every concrete constant currently loaded in `env` is exactly the entry @@ -183,6 +276,38 @@ end Insert end LoadedAgrees +/-- Every concrete block currently loaded in `env` is exactly the ordered +member array committed by the immutable block catalog. The implication is +one-way so lazy ingress may leave catalogued blocks absent. -/ +def LoadedBlocksAgrees (blocks : BlockCatalog) (env : KEnv .anon) : Prop := + ∀ {block members}, env.blocks[block]? = some members → + blocks block = some members + +namespace LoadedBlocksAgrees + +theorem lookup {blocks : BlockCatalog} {env : KEnv .anon} + (h : LoadedBlocksAgrees blocks env) {block : KId .anon} + {members : Array (KId .anon)} + (hget : env.blocks[block]? = some members) : + blocks block = some members := + h hget + +/-- Empty concrete state agrees with every block catalog. -/ +theorem empty (blocks : BlockCatalog) : + LoadedBlocksAgrees blocks ({} : KEnv .anon) := by + intro block members hget + simp at hget + +/-- Since world extension fixes the block catalog, loaded agreement is +invariant under it. -/ +theorem world_iff {before after : VerifyWorld} (h : before ≤ after) + {env : KEnv .anon} : + LoadedBlocksAgrees before.blocks env ↔ + LoadedBlocksAgrees after.blocks env := by + rw [h.blocks] + +end LoadedBlocksAgrees + /-- The loaded-constant portion of a concrete environment only grows. Cache, intern-table, block, and fuel evolution are intentionally outside this relation and will be conjoined by the later state invariant. -/ diff --git a/Ix/Tc/Whnf.lean b/Ix/Tc/Whnf.lean index e165d8364..7b12c0ddf 100644 --- a/Ix/Tc/Whnf.lean +++ b/Ix/Tc/Whnf.lean @@ -645,6 +645,22 @@ def charOfNatExpr (n : Nat) : RecM m (Option (KExpr m)) := do let natLit ← TcM.intern (natExprFromValue n : KExpr m) return some (← TcM.intern (KExpr.mkApp charOfNat natLit)) +/-- Reduce an already recognized String literal under a constant head. This +named seam keeps the literal cases independently verifiable while preserving +the original primitive tests and intern order. -/ +def tryReduceStringLiteral (p : Primitives m) (id : KId m) + (s : String) : RecM m (Option (KExpr m)) := do + let isUtf8ByteSize := id.addr == p.stringUtf8ByteSize.addr + let isToByteArray := id.addr == p.stringToByteArray.addr + if isUtf8ByteSize then + return some (← TcM.intern (natExprFromValue s.utf8ByteSize : KExpr m)) + if isToByteArray then + if s.isEmpty then + return some (← TcM.intern (.mkConst p.byteArrayEmpty #[])) + return none + let codepoint := (s.toList.getLast?.map (·.toNat)).getD 65 + charOfNatExpr codepoint + /-- String literal primitives: `String.back` / legacy back / `utf8ByteSize` / `toByteArray ""`. -/ def tryReduceString (e : KExpr m) : RecM m (Option (KExpr m)) := do @@ -660,14 +676,7 @@ def tryReduceString (e : KExpr m) : RecM m (Option (KExpr m)) := do if !isBack && !isUtf8ByteSize && !isToByteArray then return none let .str s _ _ := args[0]! | return none - if isUtf8ByteSize then - return some (← TcM.intern (natExprFromValue s.utf8ByteSize : KExpr m)) - if isToByteArray then - if s.isEmpty then - return some (← TcM.intern (.mkConst p.byteArrayEmpty #[])) - return none - let codepoint := (s.toList.getLast?.map (·.toNat)).getD 65 - charOfNatExpr codepoint + tryReduceStringLiteral p id s def discoverBlockInductives (blockId : KId m) : RecM m (Array (KId m)) := do @@ -724,6 +733,13 @@ matching Rust's `&mut` catch-and-continue behavior. -/ @[inline] def tryOptional (x : RecM m α) : RecM m (Option α) := try? x +/-- The result of the pure front-end classifier for native reduction. A +completed plan returns immediately; a marker plan still has to pass the +stateful re-entrancy guard before its argument can be reduced. -/ +inductive NativeReductionPlan (m : Mode) where + | done (result : Option (KExpr m)) + | marker (isReduceBool : Bool) (arg : KExpr m) + mutual /-- Full WHNF: loop of whnf-no-delta → native/nat/decidable/string → delta. -/ @@ -1570,6 +1586,53 @@ def tryNatOffsetStuck (e : KExpr m) : RecM m (Option (KExpr m)) := do let inner ← TcM.intern (KExpr.mkApp head wa) return some (← TcM.intern (KExpr.mkApp inner (natExprFromValue n))) +/-- Build the canonical `Decidable.isTrue` proof term for a successful +native Nat decision. This seam records the exact left-to-right intern order +without mixing construction with the surrounding reducer classifier. -/ +def buildNatDecidableTrue (p : Primitives m) (prop : KExpr m) + (args : Array (KExpr m)) (proofTrueFn : KId m) (u1 : KUniv m) : + RecM m (KExpr m) := do + let eqRefl ← TcM.intern (.mkConst p.eqRefl #[u1]) + let boolTy ← TcM.intern (.mkConst p.boolType #[]) + let boolTrue ← TcM.intern (.mkConst p.boolTrue #[]) + let reflProof ← TcM.intern (KExpr.mkApp eqRefl boolTy) + let reflProof ← TcM.intern (KExpr.mkApp reflProof boolTrue) + let proofConst ← TcM.intern (.mkConst proofTrueFn #[]) + let proof ← TcM.intern (KExpr.mkApp proofConst args[0]!) + let proof ← TcM.intern (KExpr.mkApp proof args[1]!) + let proof ← TcM.intern (KExpr.mkApp proof reflProof) + let isTrue ← TcM.intern (.mkConst p.decidableIsTrue #[]) + let result ← TcM.intern (KExpr.mkApp isTrue prop) + TcM.intern (KExpr.mkApp result proof) + +/-- Build the canonical `Decidable.isFalse` proof term for a failed native +Nat equality decision. As above, the helper preserves the production intern +sequence exactly. -/ +def buildNatDecidableFalse (p : Primitives m) (prop : KExpr m) + (args : Array (KExpr m)) (proofFalseFn : KId m) (u1 : KUniv m) : + RecM m (KExpr m) := do + let eqRefl ← TcM.intern (.mkConst p.eqRefl #[u1]) + let boolTy ← TcM.intern (.mkConst p.boolType #[]) + let boolFalse ← TcM.intern (.mkConst p.boolFalse #[]) + let reflProof ← TcM.intern (KExpr.mkApp eqRefl boolTy) + let reflProof ← TcM.intern (KExpr.mkApp reflProof boolFalse) + let proofConst ← TcM.intern (.mkConst proofFalseFn #[]) + let proof ← TcM.intern (KExpr.mkApp proofConst args[0]!) + let proof ← TcM.intern (KExpr.mkApp proof args[1]!) + let proof ← TcM.intern (KExpr.mkApp proof reflProof) + let isFalse ← TcM.intern (.mkConst p.decidableIsFalse #[]) + let result ← TcM.intern (KExpr.mkApp isFalse prop) + TcM.intern (KExpr.mkApp result proof) + +/-- Recover the proposition carried by a `Decidable` expression. Inference +runs under the validation-only policy and is caught as an accelerator miss; +normalizing the inferred type remains a recursive WHNF edge. -/ +def inferDecidableProp (e : KExpr m) : RecM m (Option (KExpr m)) := do + let some eTy ← try? (TcM.withInferOnly ((← read).infer e)) + | return none + let eTyWhnf ← whnfRec eTy + return eTyWhnf.collectSpine.2[0]? + /-- Native Nat.decLe/decEq/decLt on literals → `Decidable.isTrue/isFalse` with the canonical kernel proof terms; `decLt n m → decLe (n+1) m`; Int decidables get literal *normalization* only. `decLe false` falls to @@ -1604,43 +1667,16 @@ def tryReduceDecidable (e : KExpr m) : RecM m (Option (KExpr m)) := do result ← TcM.intern (KExpr.mkApp result args[1]!) return some (← finishAppResult result args 2) -- The proposition from `e : Decidable prop`. - let some prop ← (do - let some eTy ← try? (TcM.withInferOnly ((← read).infer e)) - | return none - let eTyWhnf ← whnfRec eTy - let (_, typeArgs) := eTyWhnf.collectSpine - return typeArgs[0]?) | return none + let some prop ← inferDecidableProp e | return none let (bResult, proofTrueFn, proofFalseFn) := if isDecLe then (aVal.ble bVal, p.natLeOfBleEqTrue, p.natNotLeOfNotBleEqTrue) else (aVal == bVal, p.natEqOfBeqEqTrue, p.natNeOfBeqEqFalse) - let resultExpr ← if bResult then do - let eqRefl ← TcM.intern (.mkConst p.eqRefl #[u1]) - let boolTy ← TcM.intern (.mkConst p.boolType #[]) - let boolTrue ← TcM.intern (.mkConst p.boolTrue #[]) - let reflProof ← TcM.intern (KExpr.mkApp eqRefl boolTy) - let reflProof ← TcM.intern (KExpr.mkApp reflProof boolTrue) - let proofConst ← TcM.intern (.mkConst proofTrueFn #[]) - let proof ← TcM.intern (KExpr.mkApp proofConst args[0]!) - let proof ← TcM.intern (KExpr.mkApp proof args[1]!) - let proof ← TcM.intern (KExpr.mkApp proof reflProof) - let isTrue ← TcM.intern (.mkConst p.decidableIsTrue #[]) - let r ← TcM.intern (KExpr.mkApp isTrue prop) - TcM.intern (KExpr.mkApp r proof) - else if isDecEq then do - let eqRefl ← TcM.intern (.mkConst p.eqRefl #[u1]) - let boolTy ← TcM.intern (.mkConst p.boolType #[]) - let boolFalse ← TcM.intern (.mkConst p.boolFalse #[]) - let reflProof ← TcM.intern (KExpr.mkApp eqRefl boolTy) - let reflProof ← TcM.intern (KExpr.mkApp reflProof boolFalse) - let proofConst ← TcM.intern (.mkConst proofFalseFn #[]) - let proof ← TcM.intern (KExpr.mkApp proofConst args[0]!) - let proof ← TcM.intern (KExpr.mkApp proof args[1]!) - let proof ← TcM.intern (KExpr.mkApp proof reflProof) - let isFalse ← TcM.intern (.mkConst p.decidableIsFalse #[]) - let r ← TcM.intern (KExpr.mkApp isFalse prop) - TcM.intern (KExpr.mkApp r proof) + let resultExpr ← if bResult then + buildNatDecidableTrue p prop args proofTrueFn u1 + else if isDecEq then + buildNatDecidableFalse p prop args proofFalseFn u1 else -- decLe false: fall through to delta. return none @@ -1822,47 +1858,13 @@ def tryReduceBitvec (e : KExpr m) : RecM m (Option (KExpr m)) := do return some (← finishAppResult result args 2) return none -/-- Native reduction: `Lean.reduceBool/reduceNat` markers, - `System.Platform.numBits ⇒ 64` (also the `Subtype.val (getNumBits ())` - form), and the PUnit/Unit SizeOf singletons. -/ -def tryReduceNative (e : KExpr m) : RecM m (Option (KExpr m)) := do - if (← get).noAccel then return none - let (head, args) := e.collectSpine - let .const id _ _ := head | return none - let p ← prims - let headAddr := id.addr - let isUnitSizeofImpl := headAddr == p.punitSizeOf1.addr && args.size == 1 - if e.lbr > 0 then - if isUnitSizeofImpl then - return some (natLiteral 1) - return none - -- `System.Platform.numBits` via the subtype projection of getNumBits (). - if headAddr == p.subtypeVal.addr && args.size == 3 then - let (valueHead, valueArgs) := args[2]!.collectSpine - if valueArgs.size == 1 then - if let .const valueId _ _ := valueHead then - if valueId.addr == p.systemPlatformGetNumBits.addr then - return some (natLiteral 64) - -- PUnit/Unit SizeOf instance is extensionally the constant 1. - if headAddr == p.sizeOfSizeOf.addr && args.size == 3 then - let (tyHead, _) := args[0]!.collectSpine - if let .const tyId _ _ := tyHead then - if tyId.addr == p.unit.addr || tyId.addr == p.punit.addr then - return some (natLiteral 1) - if isUnitSizeofImpl then - return some (natLiteral 1) - if headAddr == p.systemPlatformNumBits.addr && args.isEmpty then - return some (natLiteral 64) - let isReduceBool := headAddr == p.reduceBool.addr - let isReduceNat := headAddr == p.reduceNat.addr - if !isReduceBool && !isReduceNat then - return none - if args.size != 1 then - return none - -- Re-entrancy guard: whnf → native → whnf → native. - if (← get).inNativeReduce then - return none - let .const argId argUs _ := args[0]! | return none +/-- Execute an already recognized `Lean.reduceBool`/`Lean.reduceNat` marker. +This seam owns the lazy declaration lookup, universe instantiation, +re-entrancy guard, recursive callback, guard restoration, and final result +classifier. -/ +def tryReduceNativeMarker (p : Primitives m) (isReduceBool : Bool) + (argId : KId m) (argUs : Array (KUniv m)) : + RecM m (Option (KExpr m)) := do let body ← match (← TcM.tryGetConst argId) with | some (.defn (val := val) ..) => pure val | _ => return none @@ -1890,6 +1892,60 @@ def tryReduceNative (e : KExpr m) : RecM m (Option (KExpr m)) := do | .nat .. => return some result | _ => return none +/-- Classify the syntax-only native reductions after the primitive table and +constant-headed spine have been obtained. Keeping this decision tree pure +separates it from the re-entrancy guard and recursive callback. -/ +def planNativeReduction (p : Primitives m) (e : KExpr m) + (headAddr : Address) (args : Array (KExpr m)) : + NativeReductionPlan m := Id.run do + let isUnitSizeofImpl := headAddr == p.punitSizeOf1.addr && args.size == 1 + if e.lbr > 0 then + if isUnitSizeofImpl then + return .done (some (natLiteral 1)) + return .done none + -- `System.Platform.numBits` via the subtype projection of getNumBits (). + if headAddr == p.subtypeVal.addr && args.size == 3 then + let (valueHead, valueArgs) := args[2]!.collectSpine + if valueArgs.size == 1 then + if let .const valueId _ _ := valueHead then + if valueId.addr == p.systemPlatformGetNumBits.addr then + return .done (some (natLiteral 64)) + -- PUnit/Unit SizeOf instance is extensionally the constant 1. + if headAddr == p.sizeOfSizeOf.addr && args.size == 3 then + let (tyHead, _) := args[0]!.collectSpine + if let .const tyId _ _ := tyHead then + if tyId.addr == p.unit.addr || tyId.addr == p.punit.addr then + return .done (some (natLiteral 1)) + if isUnitSizeofImpl then + return .done (some (natLiteral 1)) + if headAddr == p.systemPlatformNumBits.addr && args.isEmpty then + return .done (some (natLiteral 64)) + let isReduceBool := headAddr == p.reduceBool.addr + let isReduceNat := headAddr == p.reduceNat.addr + if !isReduceBool && !isReduceNat then + return .done none + if args.size != 1 then + return .done none + return .marker isReduceBool args[0]! + +/-- Native reduction: `Lean.reduceBool/reduceNat` markers, + `System.Platform.numBits ⇒ 64` (also the `Subtype.val (getNumBits ())` + form), and the PUnit/Unit SizeOf singletons. -/ +def tryReduceNative (e : KExpr m) : RecM m (Option (KExpr m)) := do + if (← get).noAccel then return none + let (head, args) := e.collectSpine + let .const id _ _ := head | return none + let p ← prims + let headAddr := id.addr + match planNativeReduction p e headAddr args with + | .done result => pure result + | .marker isReduceBool arg => + -- Re-entrancy guard: whnf → native → whnf → native. + if (← get).inNativeReduce then + return none + let .const argId argUs _ := arg | return none + tryReduceNativeMarker p isReduceBool argId argUs + -- ### `is_rec` verification (inductive.rs `computed_is_rec` — hosted here -- because struct-likeness needs it; `Ix.Tc.Inductive` reuses it) diff --git a/Tests/Ix/AuxGen/RecursorTests.lean b/Tests/Ix/AuxGen/RecursorTests.lean index e0aabeb1e..c13efd8b1 100644 --- a/Tests/Ix/AuxGen/RecursorTests.lean +++ b/Tests/Ix/AuxGen/RecursorTests.lean @@ -10,7 +10,7 @@ Property tests for the pure (kernel-free) helpers of Every expected value was derived by hand-tracing the Rust bodies (`reorder_flat_by_layout`, `infer_implicit`, `name_append_after`, -`collect_binders`, `maximize_occurrence_levels`, +`collect_binders`, `match_classes_against_app`, `collect_const_refs`); expression/level assertions are hash-based `==` (bit-parity, not just structural). @@ -24,7 +24,8 @@ namespace Tests.AuxGen.Recursor open LSpec open Ix.AuxGen -open Ix (Name Level Expr) +open Ix (Name Level Expr ConstantVal InductiveVal ConstructorVal ConstantInfo + Environment) def nm (s : String) : Name := Name.mkStr .mkAnon s def u : Level := Level.mkParam (nm "u") @@ -144,26 +145,64 @@ def collectBindersTests : TestSeq := let ty := Expr.mkForallE (nm "x") dom prop .default (collectBinders ty 1)[0]!.domain == prop : Bool)) -/-- `maximize_occurrence_levels` (nested.rs:1958) + `level_max_raw`. -/ -def maximizeLevelsTests : TestSeq := - test "levelMaxRaw: only equality/zero simplifications" - ((levelMaxRaw u u == u && levelMaxRaw Level.mkZero u == u - && levelMaxRaw u Level.mkZero == u - && levelMaxRaw u v == Level.mkMax u v : Bool)) - ++ test "maximizeOccurrenceLevels merges same-name aux levels pointwise" - ((let mk := fun (ls : Array Level) => - ({ name := nm "Array", specParams := #[], occurrenceLevelArgs := ls - ownParams := 1, nIndices := 0 } : FvarFlatMember) - let orig : FvarFlatMember := - { name := nm "T", specParams := #[], occurrenceLevelArgs := #[u] - ownParams := 0, nIndices := 0 } - let out := maximizeOccurrenceLevels #[orig, mk #[u], mk #[Level.mkMax u v]] 1 - -- level_max_raw(u, max u v) = Max(u, max u v) (raw — no subsumption); - -- both aux entries get the merged value; the original is untouched. - let merged := levelMaxRaw u (Level.mkMax u v) - out[0]!.occurrenceLevelArgs == #[u] - && out[1]!.occurrenceLevelArgs == #[merged] - && out[2]!.occurrenceLevelArgs == #[merged] : Bool)) +/-- Hand-built metadata for the same phantom-universe specialization that +Lean expands into two distinct nested auxiliaries. -/ +def universeSpecializedNestedEnv : Environment := Id.run do + let phantom := nm "Phantom" + let phantomMk := nm "Phantom.mk" + let root := nm "UniverseNested" + let left := nm "UniverseNested.left" + let right := nm "UniverseNested.right" + let p := nm "p" + let q := nm "q" + let rootApp := Expr.mkConst root #[u, v] + let mut consts : Std.HashMap Name ConstantInfo := {} + consts := consts.insert phantom (.inductInfo { + cnst := ⟨phantom, #[p, q], + Expr.mkForallE (nm "alpha") (Expr.mkSort (Level.mkParam p)) prop + .default⟩, + numParams := 1, numIndices := 0, all := #[phantom], ctors := #[phantomMk], + numNested := 0, isRec := false, isUnsafe := false, isReflexive := false }) + consts := consts.insert phantomMk (.ctorInfo { + cnst := ⟨phantomMk, #[p, q], + Expr.mkForallE (nm "alpha") (Expr.mkSort (Level.mkParam p)) + (Expr.mkForallE (nm "beta") (Expr.mkSort (Level.mkParam q)) + (Expr.mkApp (Expr.mkConst phantom #[Level.mkParam p, Level.mkParam q]) + (Expr.mkBVar 1)) .default) .default⟩, + induct := phantom, cidx := 0, numParams := 1, numFields := 1, + isUnsafe := false }) + consts := consts.insert root (.inductInfo { + cnst := ⟨root, #[nm "u", nm "v"], prop⟩, + numParams := 0, numIndices := 0, all := #[root], ctors := #[left, right], + numNested := 2, isRec := true, isUnsafe := false, isReflexive := false }) + let addRootCtor := fun consts name level cidx => + let nested := Expr.mkApp (Expr.mkConst phantom #[Level.mkZero, level]) rootApp + consts.insert name (.ctorInfo { + cnst := ⟨name, #[nm "u", nm "v"], + Expr.mkForallE (nm "nested") nested rootApp .default⟩, + induct := root, cidx, numParams := 0, numFields := 1, isUnsafe := false }) + consts := addRootCtor consts left u 0 + consts := addRootCtor consts right v 1 + return { consts } + +def runUniverseSpecializedFlat : Option (Array CompileFlatMember) := + let cenv := Ix.CompileM.CompileEnv.new universeSpecializedNestedEnv + let blockEnv : Ix.CompileM.BlockEnv := + { all := {}, current := nm "UniverseNested", mutCtx := default, univCtx := [] } + match Ix.CompileM.CompileM.run cenv blockEnv {} + (buildCompileFlatBlock #[nm "UniverseNested"]) with + | .ok (flat, _) => some flat + | .error _ => none + +def universeSpecializationTests : TestSeq := + test "flat identity retains phantom universe specializations" + ((match runUniverseSpecializedFlat with + | some flat => + flat.size == 3 && flat[1]!.name == nm "Phantom" + && flat[2]!.name == nm "Phantom" + && flat[1]!.occurrenceLevelArgs == #[Level.mkZero, u] + && flat[2]!.occurrenceLevelArgs == #[Level.mkZero, v] + | none => false : Bool)) def mkFlatInfo (s : String) (isAux : Bool) (specParams : Array Expr) (ownParams : Nat) : FlatInfo := @@ -219,7 +258,7 @@ def collectConstRefsTests : TestSeq := public def suite : List TestSeq := [reorderTests, reorderErrorTests, inferImplicitTests, nameAppendAfterTests, - collectBindersTests, maximizeLevelsTests, matchClassesTests, + collectBindersTests, universeSpecializationTests, matchClassesTests, collectConstRefsTests] end Tests.AuxGen.Recursor diff --git a/Tests/Ix/Tc/CheckTests.lean b/Tests/Ix/Tc/CheckTests.lean index 382c0d749..976a67084 100644 --- a/Tests/Ix/Tc/CheckTests.lean +++ b/Tests/Ix/Tc/CheckTests.lean @@ -36,6 +36,21 @@ def checkOn (ixon : Ixon.Env) (addr : Address) : Except (TcError .anon) Unit := | .ok () _ => .ok () | .error e _ => .error e +/-- Run `checkConst` against an already-ingressed environment. Adversarial + metadata tests use this boundary to model an incomplete/malformed block + index without changing the serialized fixture's expression graph. -/ +def checkKEnvOn (env : KEnv .anon) (id : KId .anon) : + Except (TcError .anon) Unit := + match (TcM.checkConst id).run (.ofEnvAnon env) with + | .ok () _ => .ok () + | .error e _ => .error e + +def kenvFailsContaining (env : KEnv .anon) (id : KId .anon) + (frag : String) : Bool := + match checkKEnvOn env id with + | .error e => ((toString e).splitOn frag).length > 1 + | .ok () => false + def passes (ixon : Ixon.Env) (addr : Address) : Bool := (checkOn ixon addr).isOk @@ -143,8 +158,11 @@ def totalizationTests : TestSeq := ++ test "nested-positivity zero depth fails before changing state" ((let initial : TcState .anon := { TcState.ofEnvAnon {} with recFuel := 7 } - match ((RecM.checkPositivityDomainFuel 0 (.mkSort .mkZero) #[]).run - default).run initial with + let groups : Array (PositivityGroup .anon) := #[] + let addrs : Array Address := #[] + match ((RecM.checkPositivityDomainFuel 0 + (.mkSort .mkZero : KExpr .anon) groups addrs).run default).run + initial with | .error .maxRecDepth s => s.recFuel == 7 && s.lctx.size == 0 | _ => false) : Bool) ++ test "forall counting restores the local context" @@ -200,6 +218,67 @@ def safetyTests : TestSeq := /-! ### Quot validation -/ +/-- Direct kernel environment for the canonical bundle installed by Lean's + `Environment.addQuot`. Direct construction is intentional: it lets the + adversarial tests retain a reserved primitive address while changing only + the loaded declaration, which serialized content-addressed ingress would + reject earlier as an integrity mismatch. -/ +def canonicalQuotEnv : KEnv .anon := Id.run do + let p := Primitives.ofAnonAddrs + let mut env : KEnv .anon := {} + env := env.insert p.eq + (.indc () () 1 2 1 false p.eq 0 + (RecM.canonicalEqType (m := .anon)) #[p.eqRefl] ()) + env := env.insert p.eqRefl + (.ctor () () false 1 p.eq 0 2 0 (RecM.canonicalEqReflType p)) + env := env.insert p.quotType + (.quot () () .type 1 (RecM.canonicalQuotType p .type)) + env := env.insert p.quotCtor + (.quot () () .ctor 1 (RecM.canonicalQuotType p .ctor)) + env := env.insert p.quotLift + (.quot () () .lift 2 (RecM.canonicalQuotType p .lift)) + env := env.insert p.quotInd + (.quot () () .ind 1 (RecM.canonicalQuotType p .ind)) + return env + +def replaceQuotType (env : KEnv .anon) (id : KId .anon) (ty : AE) : + KEnv .anon := + match env.get? id with + | some (.quot name levelParams kind lvls _) => + env.insert id (.quot name levelParams kind lvls ty) + | _ => env + +def replaceQuotMetadata (env : KEnv .anon) (id : KId .anon) + (kind : Ix.QuotKind) (lvls : UInt64) : KEnv .anon := + match env.get? id with + | some (.quot name levelParams _ _ ty) => + env.insert id (.quot name levelParams kind lvls ty) + | _ => env + +def replaceEqType (env : KEnv .anon) (ty : AE) : KEnv .anon := + let p := Primitives.ofAnonAddrs + env.insert p.eq (.indc () () 1 2 1 false p.eq 0 ty #[p.eqRefl] ()) + +def replaceEqReflType (env : KEnv .anon) (ty : AE) : KEnv .anon := + let p := Primitives.ofAnonAddrs + env.insert p.eqRefl (.ctor () () false 1 p.eq 0 2 0 ty) + +/-- A well-typed type satisfying the old minimum-forall test but carrying no + quotient semantics. -/ +def forgedForallType (n : Nat) : AE := + (List.range n).foldl + (fun body _ => KExpr.mkAll () () (.mkSort .mkZero) body) + (.mkSort .mkZero) + +/-- Same binders as Eq, but returns `Sort 1` instead of `Prop`; this keeps the + canonical Quot.lift type inferable so the exact Eq prerequisite is what + rejects the environment. -/ +def forgedEqType : AE := + let u : KUniv .anon := .mkParam 0 () + KExpr.mkAll () () (.mkSort u) + (KExpr.mkAll () () (.mkVar 0 ()) + (KExpr.mkAll () () (.mkVar 1 ()) (.mkSort (.mkSucc .mkZero)))) + def quotTests : TestSeq := test "quot at a non-primitive address is rejected" ((let (ixon, aAddr) := envA @@ -207,6 +286,54 @@ def quotTests : TestSeq := ⟨.quot ⟨.type, 1, .ref 0 #[]⟩, #[], #[aAddr], #[]⟩ let (ixon, qAddr) := storeConst ixon fakeQuot failsContaining ixon qAddr "unknown quot address" : Bool)) + ++ test "canonical Quot bundle is accepted" + ((let p := Primitives.ofAnonAddrs + (checkKEnvOn canonicalQuotEnv p.quotType).isOk + && (checkKEnvOn canonicalQuotEnv p.quotCtor).isOk + && (checkKEnvOn canonicalQuotEnv p.quotLift).isOk + && (checkKEnvOn canonicalQuotEnv p.quotInd).isOk : Bool)) + ++ test "quot kind must agree with its reserved address" + ((let p := Primitives.ofAnonAddrs + let env := replaceQuotMetadata canonicalQuotEnv p.quotType .ctor 1 + kenvFailsContaining env p.quotType "kind mismatch" : Bool)) + ++ test "Quot.lift requires exactly two universe parameters" + ((let p := Primitives.ofAnonAddrs + let env := replaceQuotMetadata canonicalQuotEnv p.quotLift .lift 3 + kenvFailsContaining env p.quotLift "expects 2 universe params" : Bool)) + ++ test "forged Quot type with two foralls is rejected" + ((let p := Primitives.ofAnonAddrs + let env := replaceQuotType canonicalQuotEnv p.quotType + (forgedForallType 2) + kenvFailsContaining env p.quotType "type is not canonical" : Bool)) + ++ test "forged Quot.mk type with three foralls is rejected" + ((let p := Primitives.ofAnonAddrs + let env := replaceQuotType canonicalQuotEnv p.quotCtor + (forgedForallType 3) + kenvFailsContaining env p.quotCtor "type is not canonical" : Bool)) + ++ test "forged Quot.lift type with six foralls is rejected" + ((let p := Primitives.ofAnonAddrs + let env := replaceQuotType canonicalQuotEnv p.quotLift + (forgedForallType 6) + kenvFailsContaining env p.quotLift "type is not canonical" : Bool)) + ++ test "forged Quot.ind type with five foralls is rejected" + ((let p := Primitives.ofAnonAddrs + let env := replaceQuotType canonicalQuotEnv p.quotInd + (forgedForallType 5) + kenvFailsContaining env p.quotInd "type is not canonical" : Bool)) + ++ test "Quot.lift rejects a noncanonical Eq type" + ((let p := Primitives.ofAnonAddrs + let env := replaceEqType canonicalQuotEnv forgedEqType + kenvFailsContaining env p.quotLift "Eq type is not canonical" : Bool)) + ++ test "Quot.lift rejects a noncanonical Eq.refl type" + ((let p := Primitives.ofAnonAddrs + let env := replaceEqReflType canonicalQuotEnv (forgedForallType 2) + kenvFailsContaining env p.quotLift "Eq.refl type is not canonical" : Bool)) + ++ test "Quot.lift rejects noncanonical Eq.refl metadata" + ((let p := Primitives.ofAnonAddrs + let env := canonicalQuotEnv.insert p.eqRefl + (.ctor () () false 1 p.eq 0 2 1 (RecM.canonicalEqReflType p)) + kenvFailsContaining env p.quotLift + "Eq.refl metadata is not canonical" : Bool)) /-! ### Block coordination -/ @@ -418,6 +545,37 @@ def indFailsWith (block : Ixon.Constant) (frag : String) let (ixon, blockAddr) := storeMutsWithProjs extra block failsContaining ixon (indcProjAddr blockAddr 0) frag +/-- A two-constructor family used to probe constructor header metadata. -/ +def ctorMetadataFixture : + KEnv .anon × KId .anon × KId .anon × KId .anon := Id.run do + let ind : Ixon.Inductive := + ⟨false, 0, 0, 0, .sort 0, + #[⟨false, 0, 0, 0, 0, .recur 0 #[]⟩, + ⟨false, 0, 1, 0, 0, .recur 0 #[]⟩]⟩ + let (ixon, blockAddr) := storeMutsWithProjs {} + ⟨.muts #[.indc ind], #[], #[], #[.succ .zero]⟩ + let blockId : KId .anon := ⟨blockAddr, ()⟩ + let indId : KId .anon := ⟨indcProjAddr blockAddr 0, ()⟩ + let ctorId : KId .anon := ⟨ctorProjAddr blockAddr 0 0, ()⟩ + return (ingressEnvOf ixon, blockId, indId, ctorId) + +def replaceCtorMetadata (env : KEnv .anon) (ctorId : KId .anon) + (isUnsafe : Bool) (lvls cidx params fields : UInt64) : KEnv .anon := + match env.get? ctorId with + | some (.ctor name levelParams _ _ induct _ _ _ ty) => + env.insert ctorId + (.ctor name levelParams isUnsafe lvls induct cidx params fields ty) + | _ => env + +def removeInductiveCtors (env : KEnv .anon) (indId : KId .anon) : + KEnv .anon := + match env.get? indId with + | some (.indc name levelParams lvls params indices isUnsafe block memberIdx + ty _ leanAll) => + env.insert indId (.indc name levelParams lvls params indices isUnsafe + block memberIdx ty #[] leanAll) + | _ => env + def inductiveTests : TestSeq := test "Nat-like recursive inductive validates" -- N : Sort 1, zero : N, succ : N → N @@ -441,6 +599,101 @@ def inductiveTests : TestSeq := .all (.all (.recur 0 #[]) (.recur 0 #[])) (.recur 0 #[])⟩]⟩ indFailsWith ⟨.muts #[.indc ind], #[], #[], #[.succ .zero]⟩ "strict positivity" : Bool)) + ++ test "non-uniform parameter in a recursive field is rejected (F2)" + -- I : (A : Sort 1) → Sort 1, + -- I.mk : (A : Sort 1) → I ExternalA → I A. + ((let (extra, aAddr) := envA + let ind : Ixon.Inductive := + ⟨false, 0, 1, 0, .all (.sort 0) (.sort 0), + #[⟨false, 0, 0, 1, 1, + .all (.sort 0) + (.all (.app (.recur 0 #[]) (.ref 0 #[])) + (.app (.recur 0 #[]) (.var 1)))⟩]⟩ + indFailsWith + ⟨.muts #[.indc ind], #[], #[aAddr], #[.succ .zero]⟩ + "non-uniform parameter" (extra := extra) : Bool)) + ++ test "non-uniform universe in a recursive field is rejected (F2)" + -- J.{u} : Sort 1, J.mk.{u} : J.{0} → J.{u}. + ((let ind : Ixon.Inductive := + ⟨false, 1, 0, 0, .sort 2, + #[⟨false, 1, 0, 0, 1, + .all (.recur 0 #[1]) (.recur 0 #[0])⟩]⟩ + indFailsWith + ⟨.muts #[.indc ind], #[], #[], #[.var 0, .zero, .succ .zero]⟩ + "non-uniform universe arguments" : Bool)) + ++ test "recursive field index mentioning the block is rejected (F3)" + -- K : Sort 1 → Sort 1, K.mk : K (K ExternalA) → K ExternalA. + ((let (extra, aAddr) := envA + let ind : Ixon.Inductive := + ⟨false, 0, 0, 1, .all (.sort 0) (.sort 0), + #[⟨false, 0, 0, 0, 1, + .all + (.app (.recur 0 #[]) + (.app (.recur 0 #[]) (.ref 0 #[]))) + (.app (.recur 0 #[]) (.ref 0 #[]))⟩]⟩ + indFailsWith + ⟨.muts #[.indc ind], #[], #[aAddr], #[.succ .zero]⟩ + "index mentions an active inductive" (extra := extra) : Bool)) + ++ test "ill-typed phantom nested argument is checked before rewriting (#14576)" + ((let (extra, aAddr) := envA + -- Phantom : Sort 1 → Sort 1; Phantom.mk : (A : Sort 1) → Phantom A. + -- Its parameter is absent from constructor fields. + let phantom : Ixon.Inductive := + ⟨false, 0, 1, 0, .all (.sort 0) (.sort 0), + #[⟨false, 0, 0, 1, 0, + .all (.sort 0) (.app (.recur 0 #[]) (.var 0))⟩]⟩ + let (extra, phantomBlockAddr) := storeMutsWithProjs extra + ⟨.muts #[.indc phantom], #[], #[], #[.succ .zero]⟩ + let phantomAddr := indcProjAddr phantomBlockAddr 0 + -- Bad.mk : Phantom (A A) → Bad. A : Sort 1 is not a function, so + -- the original stored constructor is ill-typed. A rewrite that erased + -- Phantom's parameter would lose this error. + let bad : Ixon.Inductive := + ⟨false, 0, 0, 0, .sort 0, + #[⟨false, 0, 0, 0, 1, + .all + (.app (.ref 0 #[]) (.app (.ref 1 #[]) (.ref 1 #[]))) + (.recur 0 #[])⟩]⟩ + indFailsWith + ⟨.muts #[.indc bad], #[], #[phantomAddr, aAddr], #[.succ .zero]⟩ + "function expected" (extra := extra) : Bool)) + ++ test "distinct specializations of an active nested helper are accepted" + ((let (extra, aAddr) := envA + -- Opt : Sort 1 → Sort 1. + let opt : Ixon.Inductive := + ⟨false, 0, 1, 0, .all (.sort 0) (.sort 0), + #[⟨false, 0, 0, 1, 0, + .all (.sort 0) (.app (.recur 0 #[]) (.var 0))⟩, + ⟨false, 0, 1, 1, 1, + .all (.sort 0) + (.all (.var 0) (.app (.recur 0 #[]) (.var 1)))⟩]⟩ + let (extra, optBlockAddr) := storeMutsWithProjs extra + ⟨.muts #[.indc opt], #[], #[], #[.succ .zero]⟩ + let optAddr := indcProjAddr optBlockAddr 0 + -- Helper A has an unrelated `Opt ExternalA`, a root-carrying `Opt A`, + -- and a positive A field. While checking Root below, Opt is already + -- active at the specialization `Opt (Helper Root)`. + let helper : Ixon.Inductive := + ⟨false, 0, 1, 0, .all (.sort 0) (.sort 0), + #[⟨false, 0, 0, 1, 3, + .all (.sort 0) + (.all (.app (.ref 0 #[]) (.ref 1 #[])) + (.all (.app (.ref 0 #[]) (.var 1)) + (.all (.var 2) + (.app (.recur 0 #[]) (.var 3)))))⟩]⟩ + let (extra, helperBlockAddr) := storeMutsWithProjs extra + ⟨.muts #[.indc helper], #[], #[optAddr, aAddr], #[.succ .zero]⟩ + let helperAddr := indcProjAddr helperBlockAddr 0 + -- Root.mk : Opt (Helper Root) → Root. + let root : Ixon.Inductive := + ⟨false, 0, 0, 0, .sort 0, + #[⟨false, 0, 0, 0, 1, + .all + (.app (.ref 0 #[]) (.app (.ref 1 #[]) (.recur 0 #[]))) + (.recur 0 #[])⟩]⟩ + indPasses + ⟨.muts #[.indc root], #[], #[optAddr, helperAddr], #[.succ .zero]⟩ + (extra := extra) : Bool)) ++ test "unsafe inductive skips positivity (A3 exemption)" ((let ind : Ixon.Inductive := ⟨true, 0, 0, 0, .sort 0, @@ -477,6 +730,46 @@ def inductiveTests : TestSeq := ⟨false, 0, 0, 0, .sort 0, #[⟨false, 0, 0, 1, 0, .recur 0 #[]⟩]⟩ indFailsWith ⟨.muts #[.indc ind], #[], #[], #[.succ .zero]⟩ "params mismatch" : Bool)) + ++ test "standalone ctor params mismatch is rejected" + ((let (env, blockId, _, ctorId) := ctorMetadataFixture + let env := replaceCtorMetadata env ctorId false 0 0 1 0 + let env := { env with blocks := env.blocks.erase blockId } + kenvFailsContaining env ctorId "ctor params mismatch" : Bool)) + ++ test "standalone ctor cidx mismatch is rejected" + ((let (env, blockId, _, ctorId) := ctorMetadataFixture + let env := replaceCtorMetadata env ctorId false 0 1 0 0 + let env := { env with blocks := env.blocks.erase blockId } + kenvFailsContaining env ctorId "ctor cidx mismatch" : Bool)) + ++ test "standalone ctor universe arity mismatch is rejected" + ((let (env, blockId, _, ctorId) := ctorMetadataFixture + let env := replaceCtorMetadata env ctorId false 1 0 0 0 + let env := { env with blocks := env.blocks.erase blockId } + kenvFailsContaining env ctorId "ctor universe arity mismatch" : Bool)) + ++ test "unlisted ctor in an inductive block is rejected" + ((let (env, _, indId, _) := ctorMetadataFixture + let env := removeInductiveCtors env indId + kenvFailsContaining env indId "not listed by parent" : Bool)) + ++ test "ctor safety must match its parent inductive" + ((let (env, _, indId, ctorId) := ctorMetadataFixture + let env := replaceCtorMetadata env ctorId true 0 0 0 0 + kenvFailsContaining env indId "ctor safety mismatch" : Bool)) + ++ test "ctor fields metadata is exact (telescope negative control)" + ((let ind : Ixon.Inductive := + ⟨false, 0, 0, 0, .sort 0, + #[⟨false, 0, 0, 0, 0, + .all (.recur 0 #[]) (.recur 0 #[])⟩]⟩ + indFailsWith ⟨.muts #[.indc ind], #[], #[], #[.succ .zero]⟩ + "head is not the inductive" : Bool)) + ++ test "inductive params-plus-indices overflow is rejected" + ((let ind : Ixon.Inductive := + ⟨false, 0, 18446744073709551615, 1, .sort 0, #[]⟩ + indFailsWith ⟨.muts #[.indc ind], #[], #[], #[.succ .zero]⟩ + "inductive params + indices metadata sum overflow" : Bool)) + ++ test "generated recursor universe arity overflow is rejected" + ((let ind : Ixon.Inductive := + ⟨false, 18446744073709551615, 0, 0, .sort 0, #[]⟩ + indFailsWith ⟨.muts #[.indc ind], #[], #[], #[.succ .zero]⟩ + "generated recursor universe arity metadata sum overflow" : Bool)) ++ test "mutual peers in different universes are rejected (S3)" ((let indB : Ixon.Inductive := ⟨false, 0, 0, 0, .sort 0, #[]⟩ let indC : Ixon.Inductive := ⟨false, 0, 0, 0, .sort 1, #[]⟩ @@ -489,6 +782,18 @@ def inductiveTests : TestSeq := let indC : Ixon.Inductive := ⟨false, 0, 0, 0, .sort 0, #[]⟩ indPasses ⟨.muts #[.indc indB, .indc indC], #[], #[], #[.succ .zero]⟩ : Bool)) + ++ test "mutual peers must share universe-parameter arity" + ((let indB : Ixon.Inductive := ⟨false, 0, 0, 0, .sort 0, #[]⟩ + let indC : Ixon.Inductive := ⟨false, 1, 0, 0, .sort 0, #[]⟩ + indFailsWith + ⟨.muts #[.indc indB, .indc indC], #[], #[], #[.succ .zero]⟩ + "same universe arity" : Bool)) + ++ test "mutual peers must share the declaration safety flag" + ((let indB : Ixon.Inductive := ⟨false, 0, 0, 0, .sort 0, #[]⟩ + let indC : Ixon.Inductive := ⟨true, 0, 0, 0, .sort 0, #[]⟩ + indFailsWith + ⟨.muts #[.indc indB, .indc indC], #[], #[], #[.succ .zero]⟩ + "same safety flag" : Bool)) ++ test "index mentioning a block inductive is rejected (A2)" -- Block [B : Sort 1 (no ctors), I : Sort 1 → Sort 1] with -- `mk : I (B → B)` — the index arg is well-typed but mentions B. @@ -509,9 +814,11 @@ def inductiveTests : TestSeq := `∀ (motive : B → Sort u) (minor : motive B.mk) (t : B), motive t` with the single rule `λ motive minor, minor`. Returns `(env, recProjAddr)`. -/ -def recFixture (k : Bool) (tamperRule : Bool) : Ixon.Env × Address := Id.run do +def recFixtureWithMetadata (indUnsafe recUnsafe : Bool) (recLvls : UInt64) + (k : Bool) (tamperRule : Bool) : Ixon.Env × Address := Id.run do let ind : Ixon.Inductive := - ⟨false, 0, 0, 0, .sort 0, #[⟨false, 0, 0, 0, 0, .recur 0 #[]⟩]⟩ + ⟨indUnsafe, 0, 0, 0, .sort 0, + #[⟨indUnsafe, 0, 0, 0, 0, .recur 0 #[]⟩]⟩ let (env, bBlockAddr) := storeMutsWithProjs {} ⟨.muts #[.indc ind], #[], #[], #[.succ .zero]⟩ let bAddr := indcProjAddr bBlockAddr 0 @@ -529,11 +836,45 @@ def recFixture (k : Bool) (tamperRule : Bool) : Ixon.Env × Address := Id.run do else .lam motiveTy (.lam (.app (.var 0) (.ref 1 #[])) (.var 0)) let recr : Ixon.Recursor := - ⟨k, false, 1, 0, 0, 1, 1, recTyp, #[⟨0, ruleRhs⟩]⟩ + ⟨k, recUnsafe, recLvls, 0, 0, 1, 1, recTyp, #[⟨0, ruleRhs⟩]⟩ let (env, recBlockAddr) := storeMutsWithProjs env ⟨.muts #[.recr recr], #[], #[bAddr, mkAddr], #[.var 0]⟩ return (env, recrProjAddr recBlockAddr 0) +def recFixture (k : Bool) (tamperRule : Bool) : Ixon.Env × Address := + recFixtureWithMetadata false false 1 k tamperRule + +/-- F1 exploit fixture: a fabricated recursor over `B` whose attacker-supplied + `motives = 2` used to bypass both type and rule comparison. -/ +def badMultiMotiveRecFixture : Ixon.Env × Address := Id.run do + let ind : Ixon.Inductive := + ⟨false, 0, 0, 0, .sort 0, #[]⟩ + let (env, bBlockAddr) := storeMutsWithProjs {} + ⟨.muts #[.indc ind], #[], #[], #[.succ .zero]⟩ + let bAddr := indcProjAddr bBlockAddr 0 + -- (C : B → Prop) → (junk : B) → (b : B) → C b + let recTyp : Ixon.Expr := + .all (.all (.ref 0 #[]) (.sort 0)) + (.all (.ref 0 #[]) + (.all (.ref 0 #[]) + (.app (.var 2) (.var 0)))) + let recr : Ixon.Recursor := + -- Keep large-eliminator metadata canonical so the fixture tests + -- the fabricated motive count rather than failing at the earlier arity gate. + ⟨false, false, 1, 0, 0, 2, 0, recTyp, #[]⟩ + let (env, recBlockAddr) := storeMutsWithProjs env + ⟨.muts #[.recr recr], #[], #[bAddr], #[.zero]⟩ + return (env, recrProjAddr recBlockAddr 0) + +/-- The four serialized recursor arities must not wrap while computing the + major-premise position. -/ +def overflowRecursorFixture : Ixon.Env × Address := Id.run do + let recr : Ixon.Recursor := + ⟨false, false, 0, 18446744073709551615, 0, 1, 0, .sort 0, #[]⟩ + let (env, recBlockAddr) := storeMutsWithProjs {} + ⟨.muts #[.recr recr], #[], #[], #[.zero]⟩ + return (env, recrProjAddr recBlockAddr 0) + def recursorTests : TestSeq := test "canonical-shaped recursor validates against generation" ((let (ixon, recAddr) := recFixture false false @@ -544,6 +885,20 @@ def recursorTests : TestSeq := ++ test "tampered rule RHS is rejected" ((let (ixon, recAddr) := recFixture false true failsContaining ixon recAddr "RHS mismatch" : Bool)) + ++ test "fabricated multi-motive recursor is rejected (F1)" + ((let (ixon, recAddr) := badMultiMotiveRecFixture + failsContaining ixon recAddr "arity metadata mismatch" : Bool)) + ++ test "recursor major-index overflow is rejected before layout use" + ((let (ixon, recAddr) := overflowRecursorFixture + failsContaining ixon recAddr + "recursor major index metadata sum overflow" : Bool)) + ++ test "recursor universe arity must match canonical generation" + ((let (ixon, recAddr) := recFixtureWithMetadata false false 2 false false + failsContaining ixon recAddr + "check_recursor: universe arity mismatch" : Bool)) + ++ test "safe recursor cannot be attached to an unsafe inductive" + ((let (ixon, recAddr) := recFixtureWithMetadata true false 1 false false + failsContaining ixon recAddr "check_recursor: safety mismatch" : Bool)) /-! ### Parallel driver (`Ix.Tc.ParCheck`) -/ diff --git a/Tests/Ix/Tc/WhnfTests.lean b/Tests/Ix/Tc/WhnfTests.lean index ce55b97c4..708beac9f 100644 --- a/Tests/Ix/Tc/WhnfTests.lean +++ b/Tests/Ix/Tc/WhnfTests.lean @@ -362,6 +362,21 @@ def nativeTests : TestSeq := (KExpr.mkApp f x) && whnfEq emptyEnv (appN (pAddr P.quotInd) [a, r, β, f, mk]) (KExpr.mkApp f x)) + ++ test "quot reduction preserves the post-major suffix" + (let a := pConst (aId "A"); let r := pConst (aId "r") + let f := pConst (aId "f"); let x := pConst (aId "x") + let β := pConst (aId "B"); let extra := pConst (aId "extra") + let mk := appN (pAddr P.quotCtor) [a, r, x] + whnfEq emptyEnv (appN (pAddr P.quotInd) [a, r, β, f, mk, extra]) + (appN f [x, extra])) + ++ test "quot reduction requires exact Quot.mk arity" + (let a := pConst (aId "A"); let r := pConst (aId "r") + let f := pConst (aId "f"); let h := pConst (aId "h") + let x := pConst (aId "x"); let β := pConst (aId "B") + let extra := pConst (aId "extra") + let mk := appN (pAddr P.quotCtor) [a, r, x, extra] + let e := appN (pAddr P.quotLift) [a, r, β, f, h, mk] + whnfEq emptyEnv e e) ++ test "Int decidable literals normalize to ctor form" -- Int.decEq (Int.ofNat (succ-numeral 2)) (Int.ofNat 2) rebuilds args -- as canonical literals. diff --git a/crates/compile/src/compile/aux_gen/nested.rs b/crates/compile/src/compile/aux_gen/nested.rs index ecb3a6ecb..366338d62 100644 --- a/crates/compile/src/compile/aux_gen/nested.rs +++ b/crates/compile/src/compile/aux_gen/nested.rs @@ -1765,8 +1765,8 @@ pub fn build_compile_flat_block_with_overlay( block_param_decls.iter().map(|d| d.fvar_name.clone()).collect(); let mut flat: Vec = Vec::new(); - // Dedup tracker: (ext_ind_name, spec_param content hashes). - let mut aux_seen: Vec<(Name, Vec)> = Vec::new(); + // Dedup tracker: (external name, universe hashes, parameter hashes). + let mut aux_seen: Vec<(Name, Vec, Vec)> = Vec::new(); // Precompute the set of block original names once. Threaded through // `try_detect_nested_fvar` for O(1) "is head in the block?" checks on @@ -1878,15 +1878,6 @@ pub fn build_compile_flat_block_with_overlay( } } - // Maximize occurrence levels: Lean uses a single set of levels per external - // inductive name across ALL occurrences in the block. When `Array` appears - // with both `Array.{u}` (containing Type u) and `Array.{max u v}` (containing - // Type (max u v)), Lean uses `max u v` for all Array auxiliaries. - // - // For each external inductive name, compute the pointwise max of all - // occurrence_level_args, then apply that to all auxiliaries with that name. - maximize_occurrence_levels(&mut flat, ordered_originals.len()); - // Convert FVar-form spec_params back to BVar form for the output. // Abstract block-param FVars outermost-first: _bp_0 → BVar(n-1), // _bp_1 → BVar(n-2), ..., _bp_{n-1} → BVar(0). @@ -1945,66 +1936,11 @@ fn abstract_spec_params_to_bvars( /// rather than BVar range arithmetic. /// /// Ported from the kernel's `try_detect_nested` (`src/ix/kernel/inductive.rs:483-612`). -/// Maximize occurrence levels across all auxiliaries sharing the same external -/// inductive name. -/// -/// Lean's kernel computes a single set of universe levels per external inductive -/// across all its nested occurrences in the block. When `Array` appears as both -/// `Array.{u}` (containing `Type u`) and `Array.{max u v}` (containing -/// `Type (max u v)`), all Array auxiliaries use `max u v`. -/// -/// This function computes the pointwise max of `occurrence_level_args` across -/// all auxiliaries with the same `name`, then updates all of them. -fn maximize_occurrence_levels(flat: &mut [FvarFlatMember], n_originals: usize) { - use ix_common::env::LevelData; - use rustc_hash::FxHashMap; - - // Group auxiliary members by external inductive name. - // Key: ext_ind name, Value: (n_levels, merged_levels) - let mut max_levels: FxHashMap> = FxHashMap::default(); - - for entry in flat.iter().skip(n_originals) { - let merged = max_levels - .entry(entry.name.clone()) - .or_insert_with(|| entry.occurrence_level_args.clone()); - // Pointwise max: for each level position, take the broader level. - if merged.len() == entry.occurrence_level_args.len() { - for (m, e) in merged.iter_mut().zip(entry.occurrence_level_args.iter()) { - *m = level_max_raw(m, e); - } - } - } - - // Apply the maximized levels to all auxiliaries. - for entry in flat.iter_mut().skip(n_originals) { - if let Some(merged) = max_levels.get(&entry.name) - && merged.len() == entry.occurrence_level_args.len() - { - entry.occurrence_level_args = merged.clone(); - } - } - - /// Raw level max: `max(a, b)` with only zero elimination. - /// Matches Lean's `mkLevelMax` behavior. - fn level_max_raw(a: &Level, b: &Level) -> Level { - if a == b { - return a.clone(); - } - if matches!(a.as_data(), LevelData::Zero(_)) { - return b.clone(); - } - if matches!(b.as_data(), LevelData::Zero(_)) { - return a.clone(); - } - Level::max(a.clone(), b.clone()) - } -} - fn try_detect_nested_fvar( dom: &LeanExpr, block_names: &FxHashSet, flat: &mut Vec, - aux_seen: &mut Vec<(Name, Vec)>, + aux_seen: &mut Vec<(Name, Vec, Vec)>, lean_env: &LeanEnv, overlay: Option<&LeanEnv>, block_param_fvar_names: &[Name], @@ -2090,19 +2026,24 @@ fn try_detect_nested_fvar( } } - // Dedup: check if we've already seen this (ext_ind_name, spec_params) pair. - // Use blake3 content hashes for structural equality. Since the FVar naming - // is deterministic (_bp_0, _bp_1, ...), hashing in FVar form is stable. + // Dedup by the complete nested application identity. Universe arguments + // cannot be merged by family name: Lean emits distinct motives for + // otherwise identical term parameters at different phantom universe + // specializations. + let level_hashes: Vec = + head_levels.iter().map(|level| *level.get_hash()).collect(); let spec_hashes: Vec = spec_params.iter().map(|e| *e.get_hash()).collect(); - if aux_seen.iter().any(|(name, hashes)| { + if aux_seen.iter().any(|(name, levels, hashes)| { *name == head_name + && levels.len() == level_hashes.len() + && levels.iter().zip(level_hashes.iter()).all(|(a, b)| a == b) && hashes.len() == spec_hashes.len() && hashes.iter().zip(spec_hashes.iter()).all(|(a, b)| a == b) }) { return; } - aux_seen.push((head_name.clone(), spec_hashes)); + aux_seen.push((head_name.clone(), level_hashes, spec_hashes)); // Use the raw levels from the Const node in the constructor type. // These match the Lean kernel's `restore_nested` output, which @@ -2574,6 +2515,144 @@ mod tests { assert!(flat[0].spec_params.is_empty()); } + /// Exact producer-side analogue of Lean's two-phantom-universe nested + /// fixture. The external family and term parameter are identical; only + /// its second universe argument differs, so both auxiliaries must survive. + fn universe_specialized_nested_compile_env() -> LeanEnv { + use ix_common::env::{BinderInfo, ConstructorVal}; + + let mut env = LeanEnv::default(); + let phantom = mk_name_for("Phantom"); + let phantom_mk = mk_name_for("Phantom.mk"); + let root = mk_name_for("UniverseNested"); + let left = mk_name_for("UniverseNested.left"); + let right = mk_name_for("UniverseNested.right"); + let p = mk_name_for("p"); + let q = mk_name_for("q"); + let u = mk_name_for("u"); + let v = mk_name_for("v"); + let param = |name: &Name| LL::param(name.clone()); + let root_app = || LeanExpr::cnst(root.clone(), vec![param(&u), param(&v)]); + + env.insert( + phantom.clone(), + ConstantInfo::InductInfo(InductiveVal { + cnst: ConstantVal { + name: phantom.clone(), + level_params: vec![p.clone(), q.clone()], + typ: LeanExpr::all( + mk_name_for("alpha"), + LeanExpr::sort(param(&p)), + sort0(), + BinderInfo::Default, + ), + }, + num_params: Nat::from(1u64), + num_indices: Nat::from(0u64), + all: vec![phantom.clone()], + ctors: vec![phantom_mk.clone()], + num_nested: Nat::from(0u64), + is_rec: false, + is_unsafe: false, + is_reflexive: false, + }), + ); + env.insert( + phantom_mk.clone(), + ConstantInfo::CtorInfo(ConstructorVal { + cnst: ConstantVal { + name: phantom_mk, + level_params: vec![p.clone(), q.clone()], + typ: LeanExpr::all( + mk_name_for("alpha"), + LeanExpr::sort(param(&p)), + LeanExpr::all( + mk_name_for("beta"), + LeanExpr::sort(param(&q)), + LeanExpr::app( + LeanExpr::cnst(phantom.clone(), vec![param(&p), param(&q)]), + LeanExpr::bvar(Nat::from(1u64)), + ), + BinderInfo::Default, + ), + BinderInfo::Default, + ), + }, + induct: phantom.clone(), + cidx: Nat::from(0u64), + num_params: Nat::from(1u64), + num_fields: Nat::from(1u64), + is_unsafe: false, + }), + ); + + env.insert( + root.clone(), + ConstantInfo::InductInfo(InductiveVal { + cnst: ConstantVal { + name: root.clone(), + level_params: vec![u.clone(), v.clone()], + typ: sort0(), + }, + num_params: Nat::from(0u64), + num_indices: Nat::from(0u64), + all: vec![root.clone()], + ctors: vec![left.clone(), right.clone()], + num_nested: Nat::from(2u64), + is_rec: true, + is_unsafe: false, + is_reflexive: false, + }), + ); + for (name, level, cidx) in + [(left, param(&u), 0u64), (right, param(&v), 1u64)] + { + let nested = LeanExpr::app( + LeanExpr::cnst(phantom.clone(), vec![LL::zero(), level]), + root_app(), + ); + env.insert( + name.clone(), + ConstantInfo::CtorInfo(ConstructorVal { + cnst: ConstantVal { + name, + level_params: vec![u.clone(), v.clone()], + typ: LeanExpr::all( + mk_name_for("nested"), + nested, + root_app(), + BinderInfo::Default, + ), + }, + induct: root.clone(), + cidx: Nat::from(cidx), + num_params: Nat::from(0u64), + num_fields: Nat::from(1u64), + is_unsafe: false, + }), + ); + } + env + } + + #[test] + fn compile_flat_identity_includes_universe_specialization() { + let env = universe_specialized_nested_compile_env(); + let flat = + build_compile_flat_block(&[mk_name_for("UniverseNested")], &env).unwrap(); + assert_eq!(flat.len(), 3); + assert_eq!(flat[1].name, mk_name_for("Phantom")); + assert_eq!(flat[2].name, mk_name_for("Phantom")); + assert_eq!( + flat[1].occurrence_level_args, + vec![LL::zero(), LL::param(mk_name_for("u"))] + ); + assert_eq!( + flat[2].occurrence_level_args, + vec![LL::zero(), LL::param(mk_name_for("v"))] + ); + } + #[test] fn build_compile_flat_block_empty_originals_errors() { let env = LeanEnv::default(); diff --git a/crates/ffi/blake3_native_decide.c b/crates/ffi/blake3_native_decide.c new file mode 100644 index 000000000..52b52db00 --- /dev/null +++ b/crates/ffi/blake3_native_decide.c @@ -0,0 +1,108 @@ +/* + * Lean's native evaluator calls the boxed symbols generated for opaque + * extern declarations, while the pinned Blake3 Rust cdylib exports the raw + * rs_blake3_* ABI. Normal executables get these tiny adapters from the + * generated Blake3.Rust object. Verification modules are elaborated before + * executable linking, so Lake loads this equivalent shim for native_decide. + */ + +#include +#include + +extern lean_object *rs_blake3_init(lean_object *); +extern lean_object *rs_blake3_init_keyed(lean_object *); +extern lean_object *rs_blake3_init_derive_key(lean_object *); +extern lean_object *rs_blake3_hasher_update(lean_object *, lean_object *); +extern lean_object *rs_blake3_hasher_finalize(lean_object *, size_t); + +LEAN_EXPORT lean_object * +lp_Blake3_Blake3_Rust_hasherInit___boxed(lean_object *unit) { + return rs_blake3_init(unit); +} + +LEAN_EXPORT lean_object * +lp_Blake3_Blake3_Rust_hasherInitKeyed___boxed(lean_object *key) { + lean_object *result = rs_blake3_init_keyed(key); + lean_dec_ref(key); + return result; +} + +LEAN_EXPORT lean_object * +lp_Blake3_Blake3_Rust_hasherInitDeriveKey___boxed(lean_object *context) { + lean_object *result = rs_blake3_init_derive_key(context); + lean_dec_ref(context); + return result; +} + +LEAN_EXPORT lean_object * +lp_Blake3_Blake3_Rust_hasherUpdate___boxed(lean_object *hasher, + lean_object *bytes) { + lean_object *result = rs_blake3_hasher_update(hasher, bytes); + lean_dec_ref(bytes); + return result; +} + +LEAN_EXPORT lean_object * +lp_Blake3_Blake3_Rust_hasherFinalize___boxed(lean_object *hasher, + lean_object *length) { + size_t unboxed_length = lean_unbox_usize(length); + lean_dec(length); + return rs_blake3_hasher_finalize(hasher, unboxed_length); +} + +/* + * Ix.Unsigned normally receives these symbols from ix-ffi when a final Lean + * executable is linked. Library elaboration has no such executable, so + * native_decide needs an equivalent implementation in this loaded adapter. + * Keep the byte order explicit so this remains host-endianness independent. + */ +static lean_object *ix_alloc_le_bytes(uint64_t value, size_t width) { + lean_object *bytes = lean_alloc_sarray(1, width, width); + uint8_t *data = lean_sarray_cptr(bytes); + for (size_t index = 0; index < width; ++index) { + data[index] = (uint8_t)(value >> (8 * index)); + } + return bytes; +} + +LEAN_EXPORT lean_object *c_u16_to_le_bytes(uint16_t value) { + return ix_alloc_le_bytes((uint64_t)value, sizeof(uint16_t)); +} + +LEAN_EXPORT lean_object *c_u32_to_le_bytes(uint32_t value) { + return ix_alloc_le_bytes((uint64_t)value, sizeof(uint32_t)); +} + +LEAN_EXPORT lean_object *c_u64_to_le_bytes(uint64_t value) { + return ix_alloc_le_bytes(value, sizeof(uint64_t)); +} + +LEAN_EXPORT lean_object *c_usize_to_le_bytes(size_t value) { + return ix_alloc_le_bytes((uint64_t)value, sizeof(size_t)); +} + +LEAN_EXPORT lean_object * +lp_ix_UInt16_toLEBytes___boxed(lean_object *value) { + return c_u16_to_le_bytes((uint16_t)lean_unbox(value)); +} + +LEAN_EXPORT lean_object * +lp_ix_UInt32_toLEBytes___boxed(lean_object *value) { + uint32_t unboxed = lean_unbox_uint32(value); + lean_dec(value); + return c_u32_to_le_bytes(unboxed); +} + +LEAN_EXPORT lean_object * +lp_ix_UInt64_toLEBytes___boxed(lean_object *value) { + uint64_t unboxed = lean_unbox_uint64(value); + lean_dec_ref(value); + return c_u64_to_le_bytes(unboxed); +} + +LEAN_EXPORT lean_object * +lp_ix_USize_toLEBytes___boxed(lean_object *value) { + size_t unboxed = lean_unbox_usize(value); + lean_dec(value); + return c_usize_to_le_bytes(unboxed); +} diff --git a/crates/kernel/src/check.rs b/crates/kernel/src/check.rs index b10c0a34d..dd84baa88 100644 --- a/crates/kernel/src/check.rs +++ b/crates/kernel/src/check.rs @@ -5,7 +5,7 @@ use std::time::{Duration, Instant}; use rustc_hash::FxHashSet; use ix_common::address::Address; -use ix_common::env::{DefinitionSafety, QuotKind}; +use ix_common::env::{BinderInfo, DefinitionSafety, Name, QuotKind}; use ixon::constant::DefKind; use super::constant::KConst; @@ -13,10 +13,9 @@ use super::env::Addr; use super::error::{TcError, u64_to_usize}; use super::expr::{ExprData, KExpr}; use super::id::KId; -use super::lctx::LocalDecl; use super::level::{KUniv, UnivData, univ_eq}; use super::mode::{CheckDupLevelParams, KernelMode}; -use super::subst::instantiate_rev; +use super::primitive::Primitives; use super::tc::TypeChecker; /// Emit `[decl diff]` when a `Defn`'s value fails the `is_def_eq(val_ty, @@ -55,6 +54,205 @@ enum CheckBlockKind { Recursor, } +fn canonical_var(idx: u64) -> KExpr { + KExpr::var(idx, M::meta_field(Name::anon())) +} + +fn canonical_all( + bi: BinderInfo, + dom: KExpr, + body: KExpr, +) -> KExpr { + KExpr::all(M::meta_field(Name::anon()), M::meta_field(bi), dom, body) +} + +fn canonical_arrow(dom: KExpr, body: KExpr) -> KExpr { + canonical_all(BinderInfo::Default, dom, body) +} + +fn canonical_apps( + mut head: KExpr, + args: &[KExpr], +) -> KExpr { + for arg in args { + head = KExpr::app(head, arg.clone()); + } + head +} + +fn canonical_const(id: &KId, us: &[KUniv]) -> KExpr { + KExpr::cnst(id.clone(), us.iter().cloned().collect()) +} + +/// `α → α → Prop` at a point where `α` is `Var(0)`. +fn canonical_quot_relation() -> KExpr { + canonical_arrow( + canonical_var(0), + canonical_arrow(canonical_var(1), KExpr::sort(KUniv::zero())), + ) +} + +/// Exact semantic type required of the `Eq` prerequisite used by +/// `Environment.addQuot`. +fn canonical_eq_type() -> KExpr { + let u = KUniv::param(0, M::meta_field(Name::anon())); + canonical_all( + BinderInfo::Implicit, + KExpr::sort(u), + canonical_all( + BinderInfo::Default, + canonical_var(0), + canonical_all( + BinderInfo::Default, + canonical_var(1), + KExpr::sort(KUniv::zero()), + ), + ), + ) +} + +/// Exact semantic type required of the `Eq.refl` prerequisite used by +/// `Environment.addQuot`. +fn canonical_eq_refl_type(prims: &Primitives) -> KExpr { + let u = KUniv::param(0, M::meta_field(Name::anon())); + let result = canonical_apps( + canonical_const(&prims.eq, std::slice::from_ref(&u)), + &[canonical_var(1), canonical_var(0), canonical_var(0)], + ); + canonical_all( + BinderInfo::Implicit, + KExpr::sort(u), + canonical_all(BinderInfo::Default, canonical_var(0), result), + ) +} + +/// Canonical type installed by Lean's `Environment.addQuot` for each +/// reserved quotient primitive. Binder names/info are metadata in `KExpr`; +/// the returned de Bruijn structure, universes, primitive heads, and domains +/// are the semantic contract. +fn canonical_quot_type( + prims: &Primitives, + kind: QuotKind, +) -> KExpr { + let u = KUniv::param(0, M::meta_field(Name::anon())); + let v = KUniv::param(1, M::meta_field(Name::anon())); + let sort_u = KExpr::sort(u.clone()); + let prop = KExpr::sort(KUniv::zero()); + + match kind { + // Quot.{u} {α : Sort u} (r : α → α → Prop) : Sort u + QuotKind::Type => canonical_all( + BinderInfo::Implicit, + sort_u.clone(), + canonical_all(BinderInfo::Default, canonical_quot_relation(), sort_u), + ), + + // Quot.mk.{u} {α : Sort u} (r : α → α → Prop) (a : α) : Quot α r + QuotKind::Ctor => { + let result = canonical_apps( + canonical_const(&prims.quot_type, std::slice::from_ref(&u)), + &[canonical_var(2), canonical_var(1)], + ); + canonical_all( + BinderInfo::Implicit, + sort_u, + canonical_all( + BinderInfo::Default, + canonical_quot_relation(), + canonical_all(BinderInfo::Default, canonical_var(1), result), + ), + ) + }, + + // Quot.lift.{u,v} {α} {r} {β} (f) (h) (q) : β + QuotKind::Lift => { + let f_ty = canonical_arrow(canonical_var(2), canonical_var(1)); + let rab = + canonical_apps(canonical_var(4), &[canonical_var(1), canonical_var(0)]); + let fa = KExpr::app(canonical_var(3), canonical_var(2)); + let fb = KExpr::app(canonical_var(3), canonical_var(1)); + let fa_eq_fb = canonical_apps( + canonical_const(&prims.eq, std::slice::from_ref(&v)), + &[canonical_var(4), fa, fb], + ); + let h_ty = canonical_all( + BinderInfo::Default, + canonical_var(3), + canonical_all( + BinderInfo::Default, + canonical_var(4), + canonical_arrow(rab, fa_eq_fb), + ), + ); + let quot_r = canonical_apps( + canonical_const(&prims.quot_type, std::slice::from_ref(&u)), + &[canonical_var(4), canonical_var(3)], + ); + canonical_all( + BinderInfo::Implicit, + sort_u, + canonical_all( + BinderInfo::Implicit, + canonical_quot_relation(), + canonical_all( + BinderInfo::Implicit, + KExpr::sort(v), + canonical_all( + BinderInfo::Default, + f_ty, + canonical_all( + BinderInfo::Default, + h_ty, + canonical_arrow(quot_r, canonical_var(3)), + ), + ), + ), + ), + ) + }, + + // Quot.ind.{u} {α} {r} {β : Quot α r → Prop} (mk) {q} : β q + QuotKind::Ind => { + let quot_r_d2 = canonical_apps( + canonical_const(&prims.quot_type, std::slice::from_ref(&u)), + &[canonical_var(1), canonical_var(0)], + ); + let beta_ty = canonical_arrow(quot_r_d2, prop); + let quot_mk_a = canonical_apps( + canonical_const(&prims.quot_ctor, std::slice::from_ref(&u)), + &[canonical_var(3), canonical_var(2), canonical_var(0)], + ); + let mk_minor = canonical_all( + BinderInfo::Default, + canonical_var(2), + KExpr::app(canonical_var(1), quot_mk_a), + ); + let quot_r_d4 = canonical_apps( + canonical_const(&prims.quot_type, std::slice::from_ref(&u)), + &[canonical_var(3), canonical_var(2)], + ); + let result = KExpr::app(canonical_var(2), canonical_var(0)); + canonical_all( + BinderInfo::Implicit, + sort_u, + canonical_all( + BinderInfo::Implicit, + canonical_quot_relation(), + canonical_all( + BinderInfo::Implicit, + beta_ty, + canonical_all( + BinderInfo::Default, + mk_minor, + canonical_all(BinderInfo::Implicit, quot_r_d4, result), + ), + ), + ), + ) + }, + } +} + impl TypeChecker<'_, M> { /// Return the whole-block check key for a constant when its block has a /// supported homogeneous shape. This is used by batch schedulers to avoid @@ -72,7 +270,7 @@ impl TypeChecker<'_, M> { /// Type-check a single constant. Clears per-constant caches first. pub fn check_const(&mut self, id: &KId) -> Result<(), TcError> where - M::MField>: CheckDupLevelParams, + M::MField>: CheckDupLevelParams, { let c = self.get_const(id)?; if let Some(block) = self.coordinated_block_for(&c)? { @@ -89,7 +287,7 @@ impl TypeChecker<'_, M> { fn check_const_member_fresh(&mut self, id: &KId) -> Result<(), TcError> where - M::MField>: CheckDupLevelParams, + M::MField>: CheckDupLevelParams, { self.reset(); self.begin_const(id); @@ -104,7 +302,7 @@ impl TypeChecker<'_, M> { c: &KConst, ) -> Result<(), TcError> where - M::MField>: CheckDupLevelParams, + M::MField>: CheckDupLevelParams, { let phase_timing = *IX_PHASE_TIMING; let overall = if phase_timing { Some(Instant::now()) } else { None }; @@ -214,9 +412,11 @@ impl TypeChecker<'_, M> { }, KConst::Quot { ty, kind, lvls, .. } => { + // Reject a forged reserved primitive before invoking inference or + // reduction on attacker-controlled syntax. + self.check_quot(id, *kind, *lvls, ty)?; let t = self.infer(ty)?; self.ensure_sort(&t)?; - self.check_quot(id, *kind, *lvls, ty)?; Ok(()) }, @@ -340,7 +540,7 @@ impl TypeChecker<'_, M> { requested: &KId, ) -> Result<(), TcError> where - M::MField>: CheckDupLevelParams, + M::MField>: CheckDupLevelParams, { let phase_timing = *IX_PHASE_TIMING; let overall = if phase_timing { Some(Instant::now()) } else { None }; @@ -608,7 +808,8 @@ impl TypeChecker<'_, M> { /// Checks: /// - Correct address matches the expected QuotKind /// - Correct universe parameter count per variant - /// - Eq type exists with correct shape (1 universe param, 1 ctor Eq.refl) + /// - The complete type is the canonical type installed by `addQuot` + /// - Eq and Eq.refl have exact canonical metadata/types for Quot.lift fn check_quot( &mut self, id: &KId, @@ -652,35 +853,25 @@ impl TypeChecker<'_, M> { ))); } + let expected_ty = canonical_quot_type(&self.prims, kind); + if ty != &expected_ty { + return Err(TcError::Other(format!( + "check_quot: {:?} type is not canonical", + kind + ))); + } + // For Quot.lift (the main eliminator), verify Eq is properly formed. // This is a prerequisite for the quot reduction rule to be sound. if kind == QuotKind::Lift { self.check_eq_type()?; } - // Validate the type has the correct number of forall binders. - // Quot: 2 (α, r) - // Quot.mk: 3 (α, r, a) - // Quot.lift: 6 (α, r, β, f, h, q) - // Quot.ind: 5 (α, r, β, h, q) - let expected_foralls = match kind { - QuotKind::Type => 2, - QuotKind::Ctor => 3, - QuotKind::Lift => 6, - QuotKind::Ind => 5, - }; - let n_foralls = self.count_foralls(ty)?; - if n_foralls < expected_foralls { - return Err(TcError::Other(format!( - "check_quot: {:?} expects at least {} foralls, got {}", - kind, expected_foralls, n_foralls - ))); - } - Ok(()) } - /// Verify Eq type has the expected shape: 1 universe param, 1 constructor (Eq.refl). + /// Verify the exact Eq/Eq.refl prerequisite checked by Lean before it + /// installs the quotient primitives. fn check_eq_type(&self) -> Result<(), TcError> { // Find Eq inductive in the environment by address. // Search all constants for one matching the Eq address. @@ -693,7 +884,7 @@ impl TypeChecker<'_, M> { TcError::Other("check_eq_type: Eq not found in environment".into()) })?; match &eq_c { - KConst::Indc { lvls, ctors, params, .. } => { + KConst::Indc { lvls, params, indices, is_unsafe, ty, ctors, .. } => { if *lvls != 1 { return Err(TcError::Other(format!( "check_eq_type: Eq expects 1 universe param, got {}", @@ -708,6 +899,15 @@ impl TypeChecker<'_, M> { params ))); } + if *indices != 1 { + return Err(TcError::Other(format!( + "check_eq_type: Eq expects 1 index, got {}", + indices + ))); + } + if *is_unsafe { + return Err(TcError::Other("check_eq_type: Eq must be safe".into())); + } if ctors.len() != 1 { return Err(TcError::Other(format!( "check_eq_type: Eq expects 1 constructor, got {}", @@ -720,42 +920,62 @@ impl TypeChecker<'_, M> { "check_eq_type: Eq's constructor is not Eq.refl".into(), )); } - Ok(()) + if ty != &canonical_eq_type() { + return Err(TcError::Other( + "check_eq_type: Eq type is not canonical".into(), + )); + } + }, + _ => { + return Err(TcError::Other( + "check_eq_type: Eq not found or not inductive".into(), + )); }, - _ => Err(TcError::Other( - "check_eq_type: Eq not found or not inductive".into(), - )), } - } - /// Count the number of leading foralls in a type. - fn count_foralls(&mut self, ty: &KExpr) -> Result> { - let saved = self.lctx.len(); - let mut n = 0; - let mut cur = ty.clone(); - loop { - let w = self.whnf(&cur)?; - match w.data() { - ExprData::All(name, bi, dom, body, _) => { - n += 1; - 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: dom.clone(), - }, - ); - cur = instantiate_rev(&mut self.env.intern, body, &[fv]); - }, - _ => { - self.lctx.truncate(saved); - return Ok(n); - }, - } + let refl_c = self + .env + .iter() + .find(|(id, _)| id.addr == self.prims.eq_refl.addr) + .map(|(_, c)| c.clone()) + .ok_or_else(|| { + TcError::Other("check_eq_type: Eq.refl not found".into()) + })?; + match refl_c { + KConst::Ctor { + is_unsafe, + lvls, + induct, + cidx, + params, + fields, + ty, + .. + } => { + if is_unsafe + || lvls != 1 + || induct.addr != self.prims.eq.addr + || cidx != 0 + || params != 2 + || fields != 0 + { + return Err(TcError::Other( + "check_eq_type: Eq.refl metadata is not canonical".into(), + )); + } + if ty != canonical_eq_refl_type(&self.prims) { + return Err(TcError::Other( + "check_eq_type: Eq.refl type is not canonical".into(), + )); + } + }, + _ => { + return Err(TcError::Other( + "check_eq_type: Eq.refl not found or not a constructor".into(), + )); + }, } + Ok(()) } // ----------------------------------------------------------------------- @@ -871,9 +1091,10 @@ mod tests { use super::super::id::KId; use super::super::level::KUniv; use super::super::mode::Anon; + use super::super::primitive::Primitives; use super::super::tc::TypeChecker; use ix_common::address::Address; - use ix_common::env::{DefinitionSafety, ReducibilityHints}; + use ix_common::env::{DefinitionSafety, QuotKind, ReducibilityHints}; use ixon::constant::DefKind; #[test] @@ -943,6 +1164,271 @@ mod tests { AE::sort(AU::succ(AU::zero())) } + fn canonical_quot_env() -> (KEnv, Primitives) { + let mut env = KEnv::::new(); + let prims = Primitives::from_env(&env); + + env.insert( + prims.eq.clone(), + KConst::Indc { + name: (), + level_params: (), + lvls: 1, + params: 2, + indices: 1, + is_unsafe: false, + block: prims.eq.clone(), + member_idx: 0, + ty: super::canonical_eq_type(), + ctors: vec![prims.eq_refl.clone()], + lean_all: (), + }, + ); + env.insert( + prims.eq_refl.clone(), + KConst::Ctor { + name: (), + level_params: (), + is_unsafe: false, + lvls: 1, + induct: prims.eq.clone(), + cidx: 0, + params: 2, + fields: 0, + ty: super::canonical_eq_refl_type(&prims), + }, + ); + + for (id, kind, lvls) in [ + (prims.quot_type.clone(), QuotKind::Type, 1), + (prims.quot_ctor.clone(), QuotKind::Ctor, 1), + (prims.quot_lift.clone(), QuotKind::Lift, 2), + (prims.quot_ind.clone(), QuotKind::Ind, 1), + ] { + env.insert( + id, + KConst::Quot { + name: (), + level_params: (), + kind, + lvls, + ty: super::canonical_quot_type(&prims, kind), + }, + ); + } + (env, prims) + } + + fn replace_quot_type(env: &mut KEnv, id: &KId, ty: AE) { + let KConst::Quot { kind, lvls, .. } = env.get(id).expect("quot fixture") + else { + panic!("expected quotient fixture") + }; + env.insert( + id.clone(), + KConst::Quot { name: (), level_params: (), kind, lvls, ty }, + ); + } + + fn replace_quot_metadata( + env: &mut KEnv, + id: &KId, + kind: QuotKind, + lvls: u64, + ) { + let KConst::Quot { ty, .. } = env.get(id).expect("quot fixture") else { + panic!("expected quotient fixture") + }; + env.insert( + id.clone(), + KConst::Quot { name: (), level_params: (), kind, lvls, ty }, + ); + } + + fn replace_eq_type(env: &mut KEnv, prims: &Primitives, ty: AE) { + env.insert( + prims.eq.clone(), + KConst::Indc { + name: (), + level_params: (), + lvls: 1, + params: 2, + indices: 1, + is_unsafe: false, + block: prims.eq.clone(), + member_idx: 0, + ty, + ctors: vec![prims.eq_refl.clone()], + lean_all: (), + }, + ); + } + + fn replace_eq_refl_type( + env: &mut KEnv, + prims: &Primitives, + ty: AE, + ) { + env.insert( + prims.eq_refl.clone(), + KConst::Ctor { + name: (), + level_params: (), + is_unsafe: false, + lvls: 1, + induct: prims.eq.clone(), + cidx: 0, + params: 2, + fields: 0, + ty, + }, + ); + } + + /// A well-typed type with the old minimum number of leading foralls but no + /// quotient semantics. Every variant below was accepted by the former + /// arity-only gate when installed directly at a reserved primitive KId. + fn forged_forall_type(n: usize) -> AE { + (0..n).fold(sort0(), |body, _| AE::all((), (), sort0(), body)) + } + + fn forged_eq_type() -> AE { + let u = AU::param(0, ()); + AE::all( + (), + (), + AE::sort(u), + AE::all((), (), AE::var(0, ()), AE::all((), (), AE::var(1, ()), sort1())), + ) + } + + fn assert_not_canonical(err: TcError, label: &str) { + match err { + TcError::Other(s) => assert!( + s.contains("not canonical"), + "expected canonicality error for {label}, got {s}" + ), + other => panic!("expected canonicality error for {label}, got {other:?}"), + } + } + + #[test] + fn canonical_quotient_bundle_is_accepted() { + let (mut env, prims) = canonical_quot_env(); + for id in + [prims.quot_type, prims.quot_ctor, prims.quot_lift, prims.quot_ind] + { + TypeChecker::new(&mut env).check_const(&id).unwrap(); + } + } + + #[test] + fn reject_quot_kind_address_mismatch() { + let (mut env, prims) = canonical_quot_env(); + replace_quot_metadata(&mut env, &prims.quot_type, QuotKind::Ctor, 1); + let err = + TypeChecker::new(&mut env).check_const(&prims.quot_type).unwrap_err(); + match err { + TcError::Other(s) => assert!(s.contains("kind mismatch"), "got {s}"), + other => panic!("expected kind mismatch, got {other:?}"), + } + } + + #[test] + fn reject_quot_universe_count_mismatch() { + let (mut env, prims) = canonical_quot_env(); + replace_quot_metadata(&mut env, &prims.quot_lift, QuotKind::Lift, 3); + let err = + TypeChecker::new(&mut env).check_const(&prims.quot_lift).unwrap_err(); + match err { + TcError::Other(s) => { + assert!(s.contains("expects 2 universe params"), "got {s}") + }, + other => panic!("expected universe-count mismatch, got {other:?}"), + } + } + + #[test] + fn reject_forged_quot_type_with_two_foralls() { + let (mut env, prims) = canonical_quot_env(); + replace_quot_type(&mut env, &prims.quot_type, forged_forall_type(2)); + let err = + TypeChecker::new(&mut env).check_const(&prims.quot_type).unwrap_err(); + assert_not_canonical(err, "Quot"); + } + + #[test] + fn reject_forged_quot_mk_type_with_three_foralls() { + let (mut env, prims) = canonical_quot_env(); + replace_quot_type(&mut env, &prims.quot_ctor, forged_forall_type(3)); + let err = + TypeChecker::new(&mut env).check_const(&prims.quot_ctor).unwrap_err(); + assert_not_canonical(err, "Quot.mk"); + } + + #[test] + fn reject_forged_quot_lift_type_with_six_foralls() { + let (mut env, prims) = canonical_quot_env(); + replace_quot_type(&mut env, &prims.quot_lift, forged_forall_type(6)); + let err = + TypeChecker::new(&mut env).check_const(&prims.quot_lift).unwrap_err(); + assert_not_canonical(err, "Quot.lift"); + } + + #[test] + fn reject_forged_quot_ind_type_with_five_foralls() { + let (mut env, prims) = canonical_quot_env(); + replace_quot_type(&mut env, &prims.quot_ind, forged_forall_type(5)); + let err = + TypeChecker::new(&mut env).check_const(&prims.quot_ind).unwrap_err(); + assert_not_canonical(err, "Quot.ind"); + } + + #[test] + fn reject_quot_lift_when_eq_type_is_not_canonical() { + let (mut env, prims) = canonical_quot_env(); + replace_eq_type(&mut env, &prims, forged_eq_type()); + let err = + TypeChecker::new(&mut env).check_const(&prims.quot_lift).unwrap_err(); + assert_not_canonical(err, "Eq"); + } + + #[test] + fn reject_quot_lift_when_eq_refl_type_is_not_canonical() { + let (mut env, prims) = canonical_quot_env(); + replace_eq_refl_type(&mut env, &prims, forged_forall_type(2)); + let err = + TypeChecker::new(&mut env).check_const(&prims.quot_lift).unwrap_err(); + assert_not_canonical(err, "Eq.refl"); + } + + #[test] + fn reject_quot_lift_when_eq_refl_metadata_is_not_canonical() { + let (mut env, prims) = canonical_quot_env(); + env.insert( + prims.eq_refl.clone(), + KConst::Ctor { + name: (), + level_params: (), + is_unsafe: false, + lvls: 1, + induct: prims.eq.clone(), + cidx: 0, + params: 2, + fields: 1, + ty: super::canonical_eq_refl_type(&prims), + }, + ); + let err = + TypeChecker::new(&mut env).check_const(&prims.quot_lift).unwrap_err(); + match err { + TcError::Other(s) => { + assert!(s.contains("Eq.refl metadata is not canonical"), "got {s}") + }, + other => panic!("expected Eq.refl metadata mismatch, got {other:?}"), + } + } + fn test_env() -> KEnv { let mut env = KEnv::new(); // Axiom: Nat : Sort 1 diff --git a/crates/kernel/src/constant.rs b/crates/kernel/src/constant.rs index 54a2d3b37..5247954fd 100644 --- a/crates/kernel/src/constant.rs +++ b/crates/kernel/src/constant.rs @@ -26,6 +26,11 @@ pub struct RecRule { } /// A loaded constant. +/// +/// `member_idx` is representation metadata, not a reduction index. Inductive +/// ingress derives it from physical block traversal, anonymous recursor ingress +/// intentionally records zero, and kernel checking/WHNF do not branch on the +/// stored value. Constructor dispatch instead uses the validated `cidx`. #[derive(Clone, Debug)] pub enum KConst { Defn { diff --git a/crates/kernel/src/env.rs b/crates/kernel/src/env.rs index fb5729a5a..66800451b 100644 --- a/crates/kernel/src/env.rs +++ b/crates/kernel/src/env.rs @@ -331,6 +331,14 @@ impl InternTable { #[derive(Clone, Debug)] pub struct GeneratedRecursor { pub ind_addr: Address, + /// Canonical recursor arities. These are derived from the validated flat + /// inductive block, never from the stored `Recr` metadata. + pub lvls: u64, + pub params: u64, + pub motives: u64, + pub minors: u64, + pub indices: u64, + pub is_unsafe: bool, pub ty: KExpr, pub rules: Vec>, } diff --git a/crates/kernel/src/inductive.rs b/crates/kernel/src/inductive.rs index 1fa69f648..a67a4bd0c 100644 --- a/crates/kernel/src/inductive.rs +++ b/crates/kernel/src/inductive.rs @@ -31,6 +31,40 @@ static IX_RECURSOR_DUMP: crate::EnvString = crate::EnvString::new(|| { crate::env_var("IX_RECURSOR_DUMP").ok().filter(|s| !s.is_empty()) }); +/// Sum attacker-controlled declaration arities without permitting `u64` +/// wraparound. Several reducer and recursor-generation paths use the combined +/// value as a binder or major-premise index; accepting a wrapped total would +/// make those consumers observe a different declaration layout than the +/// individual metadata fields describe. +fn checked_metadata_sum( + label: &str, + parts: &[u64], +) -> Result> { + parts.iter().try_fold(0u64, |sum, part| { + sum + .checked_add(*part) + .ok_or_else(|| TcError::Other(format!("{label} metadata sum overflow"))) + }) +} + +fn checked_binder_sum( + label: &str, + left: usize, + right: usize, +) -> Result> { + left + .checked_add(right) + .ok_or_else(|| TcError::Other(format!("{label} binder sum overflow"))) +} + +fn checked_usize_to_u64( + label: &str, + value: usize, +) -> Result> { + u64::try_from(value) + .map_err(|_| TcError::Other(format!("{label} does not fit in u64"))) +} + /// A member of the "flat" mutual block used for recursor generation. /// For non-nested inductives, this is just the original inductive. /// For nested occurrences (e.g., `Array Syntax` in Syntax's ctor fields), @@ -64,6 +98,44 @@ pub struct FlatBlockMember { pub occurrence_us: Box<[KUniv]>, } +/// One mutually-recursive family whose applications may occur positively in +/// the constructor field currently being checked. The root declaration uses +/// symbolic universe parameters (`concrete_univs = None`); a nested external +/// family records the concrete universe and parameter specialization at which +/// it was encountered. +#[derive(Clone)] +struct PositivityGroup { + addrs: Vec
, + params: Vec>, + concrete_univs: Option]>>, +} + +/// Exact identity shared by flat-block auxiliary deduplication and the +/// positivity recursion stack. Definitional equality is deliberately too +/// broad here: two syntactically distinct specializations receive distinct +/// generated auxiliaries even when their parameters happen to reduce to the +/// same term. +fn same_nested_specialization( + left_family: &Address, + left_universes: &[KUniv], + left_parameters: &[KExpr], + right_family: &Address, + right_universes: &[KUniv], + right_parameters: &[KExpr], +) -> bool { + left_family == right_family + && left_universes.len() == right_universes.len() + && left_universes + .iter() + .zip(right_universes) + .all(|(left, right)| left == right) + && left_parameters.len() == right_parameters.len() + && left_parameters + .iter() + .zip(right_parameters) + .all(|(left, right)| left == right) +} + impl TypeChecker<'_, M> { /// Validate an inductive block. Pure inductive blocks are coordinated /// through `KEnv`; legacy mixed source blocks fall back to the member check @@ -103,6 +175,12 @@ impl TypeChecker<'_, M> { let mut ind_ids = Vec::new(); let mut ctor_ids = Vec::new(); + // SECURITY INVARIANT (Lean #14576): infer each original stored member + // type, including every constructor type, before building or consulting + // any flattened/nested-inductive representation. A lossy nested rewrite + // can erase phantom parameter arguments; checking only that rewritten + // form would let an ill-typed argument disappear. Keep this pass in full + // inference mode and over the untouched `ty` values. for member in members { self.reset(); self.begin_const(member); @@ -144,6 +222,84 @@ impl TypeChecker<'_, M> { Ok(()) } + /// Validate the constructor header fields that Lean derives from its parent + /// inductive declaration. These fields are operational metadata in Ix: + /// `cidx` selects an iota rule, `params`/`fields` drive eta and projection + /// logic, `lvls` fixes constant-application arity, and `is_unsafe` feeds the + /// definition-safety lattice. They therefore cannot be accepted merely + /// because the stored constructor type is well-typed. + fn check_ctor_metadata_against_parent( + &mut self, + ctor_id: &KId, + induct_id: &KId, + expected_cidx: usize, + ind_params: usize, + ind_lvls: u64, + ind_is_unsafe: bool, + ) -> Result<(KExpr, usize), TcError> { + let ( + ctor_ty, + ctor_induct, + ctor_cidx, + ctor_params, + ctor_fields, + ctor_lvls, + ctor_is_unsafe, + ) = match self.get_const(ctor_id)? { + KConst::Ctor { + ty, + induct, + cidx, + params, + fields, + lvls, + is_unsafe, + .. + } => ( + ty.clone(), + induct, + u64_to_usize(cidx)?, + u64_to_usize(params)?, + u64_to_usize(fields)?, + lvls, + is_unsafe, + ), + _ => { + return Err(TcError::Other( + "check_inductive: constructor not found".into(), + )); + }, + }; + + if ctor_induct != *induct_id { + return Err(TcError::Other( + "check_inductive: ctor parent mismatch".into(), + )); + } + if ctor_lvls != ind_lvls { + return Err(TcError::Other(format!( + "check_inductive: ctor universe arity mismatch: expected {ind_lvls}, got {ctor_lvls}" + ))); + } + if ctor_is_unsafe != ind_is_unsafe { + return Err(TcError::Other(format!( + "check_inductive: ctor safety mismatch: expected {ind_is_unsafe}, got {ctor_is_unsafe}" + ))); + } + if ctor_params != ind_params { + return Err(TcError::Other(format!( + "check_inductive: ctor params mismatch: expected {ind_params}, got {ctor_params}" + ))); + } + if ctor_cidx != expected_cidx { + return Err(TcError::Other(format!( + "check_inductive: ctor cidx mismatch: expected {expected_cidx}, got {ctor_cidx}" + ))); + } + + Ok((ctor_ty, ctor_fields)) + } + /// Validate an inductive type and its constructors. pub fn check_inductive_member( &mut self, @@ -174,6 +330,10 @@ impl TypeChecker<'_, M> { return Err(TcError::Other("check_inductive: not an inductive".into())); }, }; + let ind_arity = checked_metadata_sum::( + "inductive params + indices", + &[params, indices], + )?; // Discover all inductives in the mutual block let block_inds = self.discover_block_inductives(&block)?; @@ -183,7 +343,7 @@ impl TypeChecker<'_, M> { // Inductive type must reduce to a Sort after peeling params+indices. // This must be checked even for inductives with no constructors. let ind_level = - self.get_result_sort_level(&ty, u64_to_usize(params + indices)?)?; + self.get_result_sort_level(&ty, u64_to_usize(ind_arity)?)?; // S3 + S3b: Peer-agreement invariants for mutual inductives. // @@ -214,23 +374,40 @@ impl TypeChecker<'_, M> { if peer_id.addr == id.addr { continue; } - let (peer_params, peer_indices, peer_ty) = + let (peer_params, peer_indices, peer_lvls, peer_is_unsafe, peer_ty) = match self.get_const(peer_id)? { - KConst::Indc { params: pp, indices: pi, ty: pty, .. } => { - (pp, pi, pty.clone()) - }, + KConst::Indc { + params: pp, + indices: pi, + lvls: pl, + is_unsafe: pu, + ty: pty, + .. + } => (pp, pi, pl, pu, pty.clone()), _ => continue, }; // S3: universe agreement. - let peer_level = self.get_result_sort_level( - &peer_ty, - u64_to_usize(peer_params + peer_indices)?, + let peer_arity = checked_metadata_sum::( + "inductive params + indices", + &[peer_params, peer_indices], )?; + let peer_level = + self.get_result_sort_level(&peer_ty, u64_to_usize(peer_arity)?)?; if !univ_eq(&ind_level, &peer_level) { return Err(TcError::Other( "mutually inductive types must live in the same universe".into(), )); } + if peer_lvls != lvls { + return Err(TcError::Other(format!( + "mutual peers must declare the same universe arity: self={lvls}, peer={peer_lvls}" + ))); + } + if peer_is_unsafe != is_unsafe { + return Err(TcError::Other( + "mutual inductives must share the same safety flag".into(), + )); + } // S3b: parameter-count agreement. if peer_params != params { return Err(TcError::Other(format!( @@ -247,33 +424,15 @@ impl TypeChecker<'_, M> { // Validate each constructor for (expected_cidx, ctor_id) in ctors.iter().enumerate() { - let (ctor_params, ctor_fields, ctor_cidx, ctor_ty) = - match self.get_const(ctor_id)? { - KConst::Ctor { params, fields, cidx, ty, .. } => ( - u64_to_usize(params)?, - u64_to_usize(fields)?, - u64_to_usize(cidx)?, - ty.clone(), - ), - _ => { - return Err(TcError::Other( - "check_inductive: constructor not found".into(), - )); - }, - }; let ind_params = u64_to_usize(params)?; - if ctor_params != ind_params { - return Err(TcError::Other(format!( - "check_inductive: ctor params mismatch: expected {ind_params}, got {ctor_params}" - ))); - } - - // Validate constructor ordering: cidx must match position in ctors list - if ctor_cidx != expected_cidx { - return Err(TcError::Other(format!( - "check_inductive: ctor cidx mismatch: expected {expected_cidx}, got {ctor_cidx}" - ))); - } + let (ctor_ty, ctor_fields) = self.check_ctor_metadata_against_parent( + ctor_id, + id, + expected_cidx, + ind_params, + lvls, + is_unsafe, + )?; // A1: Parameter domain agreement self.check_param_agreement(&ty, &ctor_ty, ind_params)?; @@ -346,57 +505,93 @@ impl TypeChecker<'_, M> { ctor_id: &KId, induct_id: &KId, ) -> Result<(), TcError> { - let (ctor_ty, _ctor_params, ctor_fields) = match self.get_const(ctor_id)? { - KConst::Ctor { ty, params, fields, .. } => { - (ty.clone(), u64_to_usize(params)?, u64_to_usize(fields)?) + let ( + ind_params, + ind_indices, + ind_lvls, + ind_block, + ind_is_unsafe, + ind_ty, + ind_ctors, + ) = match self.get_const(induct_id)? { + KConst::Indc { + params, + indices, + lvls, + block, + is_unsafe, + ty, + ctors, + .. + } => ( + params, + indices, + lvls, + block.clone(), + is_unsafe, + ty.clone(), + ctors.clone(), + ), + _ => { + return Err(TcError::Other( + "check_ctor: parent inductive not found".into(), + )); }, - _ => return Err(TcError::Other("check_ctor: not a constructor".into())), }; - let (ind_params, ind_indices, ind_lvls, ind_block, ind_is_unsafe, ind_ty) = - match self.get_const(induct_id)? { - KConst::Indc { - params, indices, lvls, block, is_unsafe, ty, .. - } => (params, indices, lvls, block.clone(), is_unsafe, ty.clone()), - _ => { + let mut expected_cidx = None; + for (idx, listed_id) in ind_ctors.iter().enumerate() { + if listed_id == ctor_id { + if expected_cidx.is_some() { return Err(TcError::Other( - "check_ctor: parent inductive not found".into(), + "check_inductive: ctor listed more than once by parent".into(), )); - }, - }; + } + expected_cidx = Some(idx); + } + } + let Some(expected_cidx) = expected_cidx else { + return Err(TcError::Other( + "check_inductive: ctor not listed by parent".into(), + )); + }; + + let ind_params_usize = u64_to_usize(ind_params)?; + let (ctor_ty, ctor_fields) = self.check_ctor_metadata_against_parent( + ctor_id, + induct_id, + expected_cidx, + ind_params_usize, + ind_lvls, + ind_is_unsafe, + )?; let block_inds = self.discover_block_inductives(&ind_block)?; let block_addrs: Vec
= block_inds.iter().map(|id| id.addr.clone()).collect(); - let ind_level = self.get_result_sort_level( - &ind_ty, - u64_to_usize(ind_params + ind_indices)?, + let ind_arity = checked_metadata_sum::( + "inductive params + indices", + &[ind_params, ind_indices], )?; + let ind_level = + self.get_result_sort_level(&ind_ty, u64_to_usize(ind_arity)?)?; // A1: Parameter domain agreement - self.check_param_agreement(&ind_ty, &ctor_ty, u64_to_usize(ind_params)?)?; + self.check_param_agreement(&ind_ty, &ctor_ty, ind_params_usize)?; // A3: Strict positivity. Match Lean: unsafe inductives bypass this check. if !ind_is_unsafe { - self.check_positivity( - &ctor_ty, - u64_to_usize(ind_params)?, - &block_addrs, - )?; + self.check_positivity(&ctor_ty, ind_params_usize, &block_addrs)?; } // A4: Universe constraints - self.check_field_universes( - &ctor_ty, - u64_to_usize(ind_params)?, - &ind_level, - )?; + self.check_field_universes(&ctor_ty, ind_params_usize, &ind_level)?; // A2: Constructor return type self.check_ctor_return_type( &ctor_ty, - u64_to_usize(ind_params)?, + ind_params_usize, u64_to_usize(ind_indices)?, ctor_fields, &induct_id.addr, @@ -529,9 +724,12 @@ impl TypeChecker<'_, M> { block_inds.iter().map(|id| id.addr.clone()).collect(); let mut flat: Vec> = Vec::new(); - // (ext_ind_addr, spec_params content hashes) for dedup. - // Uses [u8; 32] blake3 digest for structural equality. - let mut aux_seen: Vec<(Address, Vec>)> = Vec::new(); + // Complete nested-application identity for dedup. Universe arguments are + // load-bearing: Lean emits distinct auxiliaries when an otherwise + // phantom universe parameter differs between two occurrences with the + // same external family and term parameters. + let mut aux_seen: Vec<(Address, Box<[KUniv]>, Vec>)> = + Vec::new(); // Seed with original block inductives. for ind_id in block_inds { @@ -541,7 +739,7 @@ impl TypeChecker<'_, M> { }, _ => continue, }; - let ind_us = self.mk_ind_univs(lvls, univ_offset); + let ind_us = self.mk_ind_univs(lvls, univ_offset)?; let spec_params: Vec> = (0..n_rec_params) .map(|j| KExpr::var(n_rec_params - 1 - j, anon())) .collect(); @@ -652,7 +850,7 @@ impl TypeChecker<'_, M> { dom: &KExpr, block_addrs: &[Address], flat: &mut Vec>, - aux_seen: &mut Vec<(Address, Vec>)>, + aux_seen: &mut Vec<(Address, Box<[KUniv]>, Vec>)>, univ_offset: u64, param_depth: usize, // depth at the param context (before field locals) n_rec_params: u64, // number of inductive parameters (valid Var refs in spec_params) @@ -695,9 +893,7 @@ impl TypeChecker<'_, M> { _ => return Ok(()), }; - #[allow(clippy::cast_possible_truncation)] - // ext_params is a small structural count - let ext_n_params = ext_params as usize; + let ext_n_params = u64_to_usize::(ext_params)?; if args.len() < ext_n_params { return Ok(()); } @@ -733,35 +929,49 @@ impl TypeChecker<'_, M> { // depends on a constructor field, so it is not a valid nested inductive // parameter. Allow Var(0)..Var(n_rec_params-1) as shared parameter refs. // (lean4lean: isNestedInductiveApp? checks looseBVars on param args.) + let param_depth = + checked_usize_to_u64::("nested parameter depth", param_depth)?; + let param_bound = checked_metadata_sum::( + "nested parameter scope", + &[param_depth, n_rec_params], + )?; for sp in spec_params.iter() { if sp.has_fvars() { return Ok(()); } - if sp.lbr() > param_depth as u64 + n_rec_params { + if sp.lbr() > param_bound { return Ok(()); // param arg depends on field-local variables — not a valid nesting } } - // Dedup: check if we've already seen this (ext_ind, spec_params) pair. - // Structural comparison (uid fast path + recursive fallback) so - // equal-but-separately-built spec params still collapse. + // Retain the concrete universe spine before deduplication. It is part + // of Lean's nested application identity independently of the term + // parameter spine. + let occurrence_us: Box<[KUniv]> = match head.data() { + ExprData::Const(_, us, _) => us.clone(), + _ => Box::new([]), + }; + + // Dedup the exact (external family, universes, parameters) + // specialization. Structural comparison uses the uid fast path plus + // recursive fallback, so separately-built equal inputs still collapse. let spec_hashes: Vec> = spec_params.clone(); - if aux_seen.iter().any(|(a, s)| { - *a == head_id.addr - && s.len() == spec_hashes.len() - && s.iter().zip(spec_hashes.iter()).all(|(a, b)| a == b) + if aux_seen.iter().any(|(a, seen_us, s)| { + same_nested_specialization( + a, + seen_us, + s, + &head_id.addr, + &occurrence_us, + &spec_hashes, + ) }) { return Ok(()); } - aux_seen.push((head_id.addr.clone(), spec_hashes)); + aux_seen.push((head_id.addr.clone(), occurrence_us.clone(), spec_hashes)); // Abstract shifted universe params for internal processing (dedup, ctor walking). - let aux_us = self.mk_ind_univs(ext_lvls, univ_offset); - // Concrete universe args from the actual occurrence (for output types). - let occurrence_us: Box<[KUniv]> = match head.data() { - ExprData::Const(_, us, _) => us.clone(), - _ => Box::new([]), - }; + let aux_us = self.mk_ind_univs(ext_lvls, univ_offset)?; flat.push(FlatBlockMember { id: head_id, @@ -952,11 +1162,13 @@ impl TypeChecker<'_, M> { aux_ids[idx].clone(), block_us.to_vec().into_boxed_slice(), )); + let param_base = checked_metadata_sum::( + "auxiliary parameter index", + &[local_depth, n_block_params], + )?; for pi in 0..n_block_params { - let p = self.env.intern.intern_expr(KExpr::var( - local_depth + n_block_params - 1 - pi, - anon(), - )); + let p = + self.env.intern.intern_expr(KExpr::var(param_base - 1 - pi, anon())); result = self.env.intern.intern_expr(KExpr::app(result, p)); } for idx_arg in args.iter().skip(own) { @@ -1615,26 +1827,36 @@ peers={} flat={} rec_ids={} failed_gi={failed_gi}", for gi in 0..n { let gen_rec = &generated_snapshot[gi]; let target_addr = &gen_rec.ind_addr; - let gen_major = self - .recursor_major_domain_for_addr( - &gen_rec.ty, - prefix_base + flat[gi].n_indices, - target_addr, - ) - .unwrap_or(None); + let gen_skip = checked_metadata_sum::( + "generated recursor major index", + &[prefix_base, flat[gi].n_indices], + ) + .ok(); + let gen_major = gen_skip.and_then(|skip| { + self + .recursor_major_domain_for_addr(&gen_rec.ty, skip, target_addr) + .unwrap_or(None) + }); let rid = &rec_ids[gi]; let (stored_skip, stored_ty) = match self.try_get_const(rid).ok().flatten() { Some(KConst::Recr { params, motives, minors, indices, ty, .. - }) => (params + motives + minors + indices, Some(ty.clone())), - _ => (0, None), + }) => ( + checked_metadata_sum::( + "recursor major index", + &[params, motives, minors, indices], + ) + .ok(), + Some(ty.clone()), + ), + _ => (None, None), }; - let stored_major = match stored_ty { - Some(ty) => self - .recursor_major_domain_for_addr(&ty, stored_skip, target_addr) + let stored_major = match (stored_skip, stored_ty) { + (Some(skip), Some(ty)) => self + .recursor_major_domain_for_addr(&ty, skip, target_addr) .unwrap_or(None), - None => None, + _ => None, }; let mark = if gi == failed_gi { "!!" } else { " " }; log::info!( @@ -1772,30 +1994,174 @@ peers={} flat={} rec_ids={} failed_gi={failed_gi}", n_params: usize, block_addrs: &[Address], ) -> Result<(), TcError> { - // Skip params - let mut ty = ctor_ty.clone(); - for _ in 0..n_params { - let w = self.whnf(&ty)?; - match w.data() { - ExprData::All(_, _, _, body, _) => ty = body.clone(), - _ => return Ok(()), // not enough foralls — ok + let saved = self.lctx.len(); + let result = (|| -> Result<(), TcError> { + // Open rather than merely dropping the shared parameter binders. This + // gives every recursive occurrence a stable set of fvars against which + // uniformity can be checked, including under dependent field binders. + let mut ty = ctor_ty.clone(); + let mut param_fvars = Vec::with_capacity(n_params); + for _ in 0..n_params { + let w = self.whnf(&ty)?; + match w.data() { + ExprData::All(_, _, dom, body, _) => { + let (open, fv, _) = + self.open_binder_anon_with_fv(dom.clone(), body); + param_fvars.push(fv); + ty = open; + }, + _ => return Ok(()), // A1/A2 report malformed telescopes precisely. + } } + + let groups = vec![PositivityGroup { + addrs: block_addrs.to_vec(), + params: param_fvars, + concrete_univs: None, + }]; + + // Check each field domain while retaining earlier field binders. + loop { + let w = self.whnf(&ty)?; + match w.data() { + ExprData::All(_, _, dom, body, _) => { + self.check_positivity_domain(dom, &groups, block_addrs)?; + let (open, _) = self.open_binder_anon(dom.clone(), body); + ty = open; + }, + _ => break, + } + } + Ok(()) + })(); + self.lctx.truncate(saved); + result + } + + /// Validate a direct application of an active recursive family. This is the + /// field-occurrence analogue of `check_ctor_return_type`: arity, universe + /// specialization, uniform parameters, and index independence are all + /// checked before the occurrence is admitted as positive. + fn check_positive_recursive_application( + &mut self, + id: &KId, + us: &[KUniv], + args: &[KExpr], + groups: &[PositivityGroup], + root_addrs: &[Address], + ) -> Result<(), TcError> { + let group = groups + .iter() + .find(|group| group.addrs.contains(&id.addr)) + .cloned() + .ok_or_else(|| { + TcError::Other("positivity: missing recursive-family context".into()) + })?; + let (n_params, n_indices, lvls) = match self.get_const(id)? { + KConst::Indc { params, indices, lvls, .. } => { + (u64_to_usize(params)?, u64_to_usize(indices)?, u64_to_usize(lvls)?) + }, + _ => { + return Err(TcError::Other( + "positivity: recursive head is not an inductive".into(), + )); + }, + }; + + let app_arity = checked_binder_sum::( + "positivity recursive application", + n_params, + n_indices, + )?; + if args.len() != app_arity { + return Err(TcError::Other(format!( + "positivity: recursive occurrence has wrong argument count: expected {}, got {}", + app_arity, + args.len() + ))); + } + if us.len() != lvls { + return Err(TcError::Other(format!( + "positivity: recursive occurrence has wrong universe count: expected {lvls}, got {}", + us.len() + ))); + } + match group.concrete_univs.as_deref() { + Some(expected) => { + if expected.len() != us.len() + || !expected.iter().zip(us).all(|(a, b)| univ_eq(a, b)) + { + return Err(TcError::Other( + "positivity: recursive occurrence has non-uniform universe arguments" + .into(), + )); + } + }, + None => { + for (i, u) in us.iter().enumerate() { + let expected = + KUniv::param(i as u64, M::meta_field(ix_common::env::Name::anon())); + if !univ_eq(u, &expected) { + return Err(TcError::Other( + "positivity: recursive occurrence has non-uniform universe arguments" + .into(), + )); + } + } + }, } - // Check each field domain - loop { - let w = self.whnf(&ty)?; - match w.data() { - ExprData::All(_, _, dom, body, _) => { - self.check_positivity_domain(dom, block_addrs)?; - ty = body.clone(); - }, - _ => break, + if group.params.len() != n_params { + return Err(TcError::Other( + "positivity: recursive occurrence parameter arity disagrees with its family" + .into(), + )); + } + for (i, (actual, expected)) in + args[..n_params].iter().zip(&group.params).enumerate() + { + if !self.is_def_eq(actual, expected)? { + return Err(TcError::Other(format!( + "positivity: recursive occurrence {id} has non-uniform parameter {i}: expected {expected}, got {actual}" + ))); + } + } + for index in &args[n_params..] { + if expr_mentions_any_addr(index, root_addrs) { + return Err(TcError::Other( + "positivity: recursive occurrence index mentions an active inductive" + .into(), + )); } } Ok(()) } + /// Whether an application has the exact universe/parameter specialization + /// represented by one nested-family group. Multiple groups may share an + /// inductive address: nested flattening keys auxiliaries by + /// `(inductive, specialization)`, not by inductive address alone. + fn positivity_group_matches( + &mut self, + group: &PositivityGroup, + family: &Address, + us: &[KUniv], + args: &[KExpr], + n_params: usize, + ) -> Result> { + let Some(expected_universes) = group.concrete_univs.as_deref() else { + return Ok(false); + }; + Ok(same_nested_specialization( + family, + expected_universes, + &group.params, + family, + us, + &args[..n_params], + )) + } + /// Check that a field domain doesn't have block inductives in negative position. /// Follows lean4lean's `checkPositivity`: recurse through foralls, reject if /// inductive in domain (negative), accept if result is a valid inductive app @@ -1808,9 +2174,19 @@ peers={} flat={} rec_ids={} failed_gi={failed_gi}", fn check_positivity_domain( &mut self, dom: &KExpr, - block_addrs: &[Address], + groups: &[PositivityGroup], + active_addrs: &[Address], ) -> Result<(), TcError> { - if !expr_mentions_any_addr(dom, block_addrs) { + // Only occurrences containing the original block are relevant to this + // positivity traversal. Helper families may recur elsewhere at unrelated + // specializations (for example `Option Syntax` while traversing + // `Option (SnapshotTask TacticParsedSnapshot)`); their head address alone + // does not make that occurrence recursive for the root declaration. + let root_addrs = + groups.first().map(|group| group.addrs.as_slice()).ok_or_else(|| { + TcError::Other("positivity: missing root-family context".into()) + })?; + if !expr_mentions_any_addr(dom, root_addrs) { return Ok(()); // no inductive mention at all — fine } @@ -1818,7 +2194,7 @@ peers={} flat={} rec_ids={} failed_gi={failed_gi}", match w.data() { ExprData::All(_, _, inner_dom, inner_body, _) => { // Inductive in domain of a Pi = negative position → reject - if expr_mentions_any_addr(inner_dom, block_addrs) { + if expr_mentions_any_addr(inner_dom, root_addrs) { return Err(TcError::Other("strict positivity violation".into())); } // H4: Open binder with fvar so WHNF works correctly on dependent @@ -1826,7 +2202,8 @@ peers={} flat={} rec_ids={} failed_gi={failed_gi}", let saved = self.lctx.len(); let (inner_open, _) = self.open_binder_anon(inner_dom.clone(), inner_body); - let result = self.check_positivity_domain(&inner_open, block_addrs); + let result = + self.check_positivity_domain(&inner_open, groups, active_addrs); self.lctx.truncate(saved); result }, @@ -1837,14 +2214,23 @@ peers={} flat={} rec_ids={} failed_gi={failed_gi}", // declared inductive and Ds contain block inductives let (head, args) = collect_app_spine(&w); match head.data() { - ExprData::Const(id, _, _) if block_addrs.contains(&id.addr) => Ok(()), + ExprData::Const(id, us, _) if root_addrs.contains(&id.addr) => self + .check_positive_recursive_application( + id, us, &args, groups, root_addrs, + ), ExprData::Const(id, us, _) => { // Check if this is a nested inductive: head is an inductive type // (not in our block) and its params contain block inductives. - let (n_params, block, ctors) = match self.get_const(id)? { - KConst::Indc { params, block, ctors, .. } => { - (u64_to_usize(params)?, block.clone(), ctors.clone()) - }, + let (n_params, n_indices, lvls, block, ctors) = match self + .get_const(id)? + { + KConst::Indc { params, indices, lvls, block, ctors, .. } => ( + u64_to_usize(params)?, + u64_to_usize(indices)?, + u64_to_usize(lvls)?, + block.clone(), + ctors.clone(), + ), _ => { return Err(TcError::Other( "positivity: not a valid inductive app".into(), @@ -1852,11 +2238,48 @@ peers={} flat={} rec_ids={} failed_gi={failed_gi}", }, }; - // Verify params contain block inductive refs (that's what makes it nested) + let app_arity = checked_binder_sum::( + "positivity nested application", + n_params, + n_indices, + )?; + if args.len() != app_arity || us.len() != lvls { + return Err(TcError::Other( + "positivity: malformed nested inductive application".into(), + )); + } + + // An exact repeated specialization is the recursive edge of an + // already-validated synthetic auxiliary. A different + // specialization of the same external family is a distinct + // auxiliary (for example both `Array (ListItem (Block i b))` + // and `Array (Block i b)` in `Lean.Doc.Block`). + let existing_groups: Vec> = groups + .iter() + .filter(|group| group.addrs.contains(&id.addr)) + .cloned() + .collect(); + for group in &existing_groups { + if self.positivity_group_matches( + group, &id.addr, us, &args, n_params, + )? { + for index in args.iter().skip(n_params) { + if expr_mentions_any_addr(index, root_addrs) { + return Err(TcError::Other( + "positivity: recursive occurrence index mentions an active inductive" + .into(), + )); + } + } + return Ok(()); + } + } + + // Verify params contain active inductive refs (that's what makes it nested) let has_nested_ref = args .iter() .take(n_params) - .any(|a| expr_mentions_any_addr(a, block_addrs)); + .any(|a| expr_mentions_any_addr(a, root_addrs)); if !has_nested_ref { return Err(TcError::Other( "positivity: not a valid inductive app".into(), @@ -1865,20 +2288,20 @@ peers={} flat={} rec_ids={} failed_gi={failed_gi}", // Index args (after params) must not mention block inductives for arg in args.iter().skip(n_params) { - if expr_mentions_any_addr(arg, block_addrs) { + if expr_mentions_any_addr(arg, root_addrs) { return Err(TcError::Other( "positivity: index mentions block inductive".into(), )); } } - // Build augmented address set: original block + external inductive's block - let mut augmented: Vec
= block_addrs.to_vec(); + // Add the external mutual family at this concrete specialization. + let mut augmented_addrs: Vec
= active_addrs.to_vec(); let ext_block_inductives = self.discover_block_inductives(&block)?; for ext_id in &ext_block_inductives { - if !augmented.contains(&ext_id.addr) { - augmented.push(ext_id.addr.clone()); + if !augmented_addrs.contains(&ext_id.addr) { + augmented_addrs.push(ext_id.addr.clone()); } } @@ -1886,6 +2309,15 @@ peers={} flat={} rec_ids={} failed_gi={failed_gi}", let param_args: Vec> = args.iter().take(n_params).cloned().collect(); let us = us.clone(); + let mut augmented_groups = groups.to_vec(); + augmented_groups.push(PositivityGroup { + addrs: ext_block_inductives + .iter() + .map(|ext_id| ext_id.addr.clone()) + .collect(), + params: param_args.clone(), + concrete_univs: Some(us.clone()), + }); // For each constructor, strip params, substitute actual param args, // and recursively check positivity of each field domain @@ -1903,7 +2335,8 @@ peers={} flat={} rec_ids={} failed_gi={failed_gi}", n_params, ¶m_args, &us, - &augmented, + &augmented_groups, + &augmented_addrs, )?; } @@ -1928,7 +2361,8 @@ peers={} flat={} rec_ids={} failed_gi={failed_gi}", n_params: usize, param_args: &[KExpr], us: &[KUniv], - augmented_addrs: &[Address], + groups: &[PositivityGroup], + active_addrs: &[Address], ) -> Result<(), TcError> { // Instantiate universe params let mut ty = self.instantiate_univ_params(ctor_ty, us)?; @@ -1956,7 +2390,7 @@ peers={} flat={} rec_ids={} failed_gi={failed_gi}", ty = simul_subst(&mut self.env.intern, &ty, &reversed_params, 0); // Now check each remaining field domain - self.check_nested_ctor_fields_loop(&ty, augmented_addrs) + self.check_nested_ctor_fields_loop(&ty, groups, active_addrs) } /// Walk the remaining forall binders of a nested constructor type and check @@ -1964,15 +2398,17 @@ peers={} flat={} rec_ids={} failed_gi={failed_gi}", fn check_nested_ctor_fields_loop( &mut self, ty: &KExpr, - augmented_addrs: &[Address], + groups: &[PositivityGroup], + active_addrs: &[Address], ) -> Result<(), TcError> { let w = self.whnf(ty)?; match w.data() { ExprData::All(_, _, dom, body, _) => { - self.check_positivity_domain(dom, augmented_addrs)?; + self.check_positivity_domain(dom, groups, active_addrs)?; let saved = self.lctx.len(); let (open, _) = self.open_binder_anon(dom.clone(), body); - let result = self.check_nested_ctor_fields_loop(&open, augmented_addrs); + let result = + self.check_nested_ctor_fields_loop(&open, groups, active_addrs); self.lctx.truncate(saved); result }, @@ -2049,7 +2485,16 @@ peers={} flat={} rec_ids={} failed_gi={failed_gi}", // return type's first n_params args are exactly the param fvars by // FVar identity (replaces the legacy de Bruijn `Var(expected_idx)` // match after the fvar transition). - let total_binders = n_params + n_fields; + let total_binders = checked_binder_sum::( + "constructor params + fields", + n_params, + n_fields, + )?; + let result_arity = checked_binder_sum::( + "constructor params + indices", + n_params, + n_indices, + )?; let mut param_fvars: Vec> = Vec::with_capacity(n_params); for i in 0..total_binders { let w = self.whnf(&ty)?; @@ -2110,11 +2555,11 @@ peers={} flat={} rec_ids={} failed_gi={failed_gi}", } // S2: Total args must equal n_params + n_indices exactly. - if args.len() != n_params + n_indices { + if args.len() != result_arity { self.lctx.truncate(saved); return Err(TcError::Other(format!( "ctor return type: expected {} args (params={} + indices={}), got {}", - n_params + n_indices, + result_arity, n_params, n_indices, args.len() @@ -2232,7 +2677,12 @@ peers={} flat={} rec_ids={} failed_gi={failed_gi}", let mut ty = ctor_ty; let mut non_trivial: Vec = Vec::new(); // field index (0-based among fields) let mut field_fvars: Vec> = Vec::with_capacity(ctor_fields); - for i in 0..(n_params + ctor_fields) { + let ctor_arity = checked_binder_sum::( + "constructor params + fields", + n_params, + ctor_fields, + )?; + for i in 0..ctor_arity { let w = self.whnf(&ty)?; match w.data() { ExprData::All(_, _, dom, body, _) => { @@ -2291,11 +2741,25 @@ peers={} flat={} rec_ids={} failed_gi={failed_gi}", let mut ind_infos: Vec<(KId, u64, u64, Vec>, KExpr)> = Vec::new(); let mut n_params: u64 = 0; + let mut block_lvls: u64 = 0; + let mut block_is_unsafe: Option = None; for (i, ind_id) in block_inds.iter().enumerate() { match self.get_const(ind_id)? { - KConst::Indc { params, indices, ctors, ty, .. } => { + KConst::Indc { + params, indices, ctors, lvls, is_unsafe, ty, .. + } => { if i == 0 { n_params = params; + block_lvls = lvls; + } + match block_is_unsafe { + Some(expected) if expected != is_unsafe => { + return Err(TcError::Other( + "mutual inductives must share the same safety flag".into(), + )); + }, + None => block_is_unsafe = Some(is_unsafe), + _ => {}, } ind_infos.push(( ind_id.clone(), @@ -2314,12 +2778,19 @@ peers={} flat={} rec_ids={} failed_gi={failed_gi}", } // Compute elimination level. - let result_level = self.get_result_sort_level( - &ind_infos[0].4, - u64_to_usize(ind_infos[0].1 + ind_infos[0].2)?, + let first_ind_arity = checked_metadata_sum::( + "inductive params + indices", + &[ind_infos[0].1, ind_infos[0].2], )?; + let result_level = self + .get_result_sort_level(&ind_infos[0].4, u64_to_usize(first_ind_arity)?)?; let is_large = self.is_large_eliminator(&result_level, &ind_infos)?; let univ_offset: u64 = if is_large { 1 } else { 0 }; + let rec_lvls = checked_metadata_sum::( + "generated recursor universe arity", + &[block_lvls, univ_offset], + )?; + let rec_is_unsafe = block_is_unsafe.unwrap_or(false); let elim_level = if is_large { KUniv::param(0, M::meta_field(ix_common::env::Name::anon())) } else { @@ -2404,7 +2875,15 @@ peers={} flat={} rec_ids={} failed_gi={failed_gi}", motive_types.push(motive_ty); } - // Generate recursor type for each ORIGINAL inductive (not auxiliaries). + let n_motives = flat.len() as u64; + let n_minors = flat.iter().try_fold(0u64, |sum, member| { + checked_metadata_sum::( + "generated recursor minors", + &[sum, member.ctors.len() as u64], + ) + })?; + + // Generate recursor type for each ORIGINAL inductive (not auxiliaries). // The recursor type spans all flat block members (motives, minors). let mut generated = Vec::new(); for di in 0..n_originals { @@ -2419,6 +2898,12 @@ peers={} flat={} rec_ids={} failed_gi={failed_gi}", )?; generated.push(GeneratedRecursor { ind_addr: flat[di].id.addr.clone(), + lvls: rec_lvls, + params: n_params, + motives: n_motives, + minors: n_minors, + indices: flat[di].n_indices, + is_unsafe: rec_is_unsafe, ty: rec_type, // Rules are populated later from the recursor block by // `populate_recursor_rules_from_block`. @@ -2439,6 +2924,12 @@ peers={} flat={} rec_ids={} failed_gi={failed_gi}", )?; generated.push(GeneratedRecursor { ind_addr: flat[di].id.addr.clone(), + lvls: rec_lvls, + params: n_params, + motives: n_motives, + minors: n_minors, + indices: flat[di].n_indices, + is_unsafe: rec_is_unsafe, ty: rec_type, // Rules are populated later from the recursor block by // `populate_recursor_rules_from_block`. @@ -2447,9 +2938,10 @@ peers={} flat={} rec_ids={} failed_gi={failed_gi}", } if self.recursor_dump_matches_block(block_id, &flat) { - let n_motives = flat.len() as u64; - let n_minors: u64 = flat.iter().map(|m| m.ctors.len() as u64).sum(); - let prefix_skip = n_params + n_motives + n_minors; + let prefix_skip = checked_metadata_sum::( + "generated recursor params + motives + minors", + &[n_params, n_motives, n_minors], + )?; log::info!( "[recursor.dump] generated recursors for {block_id}: count={} prefix_skip={prefix_skip}", generated.len() @@ -2591,14 +3083,25 @@ peers={} flat={} rec_ids={} failed_gi={failed_gi}", // the binder type of the major-Pi inside the index-Pi chain). let mut major_ty = self.intern(KExpr::cnst(member.id.clone(), member.occurrence_us.clone())); - let depth = n_idx as u64; + let depth = + checked_usize_to_u64::("generated motive index depth", n_idx)?; if !member.is_aux { // Original: params are loose Var refs that will be bound by the // recursor's outer param-Pi chain (added by the caller). They sit // (depth) binders below the major scope. + let n_rec_params_u64 = checked_usize_to_u64::( + "generated motive parameter count", + n_rec_params, + )?; + let param_base = checked_metadata_sum::( + "generated motive parameter depth", + &[n_rec_params_u64, depth], + )?; for i in 0..n_rec_params { let v = self.intern(KExpr::var( - (n_rec_params as u64 - 1 - i as u64) + depth, + param_base + - 1 + - checked_usize_to_u64::("generated motive parameter index", i)?, anon(), )); major_ty = self.intern(KExpr::app(major_ty, v)); @@ -2771,7 +3274,11 @@ peers={} flat={} rec_ids={} failed_gi={failed_gi}", let _ = self.push_fvar_decl_anon(ih_ty); } let n_ihs = ih_domains.len(); - let n_binders = n_fields + n_ihs; + let n_binders = checked_binder_sum::( + "generated minor fields + induction hypotheses", + n_fields, + n_ihs, + )?; // `ty` is the return type: I params indices // The constructor always returns its own inductive, so ret_ind_idx = ind_idx. @@ -2890,7 +3397,16 @@ peers={} flat={} rec_ids={} failed_gi={failed_gi}", // Lift the field domain from its original depth (minor_saved + field_idx) // to the current depth (minor_saved + n_fields + k). let dom = &field_domains[field_idx]; - let shift = (n_fields + k - field_idx) as u64; + let fields_and_ihs = checked_binder_sum::( + "generated minor field + induction-hypothesis depth", + n_fields, + k, + )?; + let shift = fields_and_ihs.checked_sub(field_idx).ok_or_else(|| { + TcError::Other("generated minor field depth underflow".into()) + })?; + let shift = + checked_usize_to_u64::("generated minor field depth", shift)?; let dom_lifted = lift(&mut self.env.intern, dom, shift, 0); let wdom = self.whnf(&dom_lifted)?; @@ -3109,7 +3625,7 @@ peers={} flat={} rec_ids={} failed_gi={failed_gi}", Some(KConst::Indc { lvls, .. }) => lvls, _ => 0, }; - let first_ind_univs = self.mk_ind_univs(first_ind_lvls, univ_offset); + let first_ind_univs = self.mk_ind_univs(first_ind_lvls, univ_offset)?; let pty_inst = self.instantiate_univ_params(&ind_infos[0].4, &first_ind_univs)?; let mut pty = pty_inst; @@ -3159,7 +3675,12 @@ peers={} flat={} rec_ids={} failed_gi={failed_gi}", let _ = self.push_fvar_decl_anon(minor_ty); } } - let _n_minors = domains.len().checked_sub(n_params + n_motives) + let params_and_motives = checked_binder_sum::( + "generated recursor params + motives", + n_params, + n_motives, + )?; + let _n_minors = domains.len().checked_sub(params_and_motives) .ok_or_else(|| TcError::Other(format!( "build_rec_type: not enough binders: domains={}, params={n_params}, motives={n_motives}", domains.len() @@ -3264,15 +3785,25 @@ peers={} flat={} rec_ids={} failed_gi={failed_gi}", /// Create shifted universe param args for an inductive in a recursor context. /// For large eliminators (offset=1): [Param(1), ..., Param(n)]. /// For small eliminators (offset=0): [Param(0), ..., Param(n-1)]. - fn mk_ind_univs(&mut self, ind_lvls: u64, offset: u64) -> Box<[KUniv]> { - (0..ind_lvls) - .map(|i| { - KUniv::param(i + offset, M::meta_field(ix_common::env::Name::anon())) - }) - .collect::>() - .into_iter() - .map(|u| self.intern_univ(u)) - .collect() + fn mk_ind_univs( + &mut self, + ind_lvls: u64, + offset: u64, + ) -> Result]>, TcError> { + checked_metadata_sum::( + "generated recursor universe arity", + &[ind_lvls, offset], + )?; + Ok( + (0..ind_lvls) + .map(|i| { + KUniv::param(i + offset, M::meta_field(ix_common::env::Name::anon())) + }) + .collect::>() + .into_iter() + .map(|u| self.intern_univ(u)) + .collect(), + ) } /// Find peer recursor KIds for each flat block member. @@ -3319,7 +3850,10 @@ peers={} flat={} rec_ids={} failed_gi={failed_gi}", }) => (params, motives, minors, indices, ty.clone()), _ => return Ok(None), }; - let skip = params + motives + minors + indices; + let skip = checked_metadata_sum::( + "recursor major index", + &[params, motives, minors, indices], + )?; let major_id = match self.get_major_inductive_id(&ty, skip) { Ok(id) => id, Err(TcError::UnknownConst(addr)) => { @@ -3489,8 +4023,16 @@ peers={} flat={} rec_ids={} failed_gi={failed_gi}", } let n_motives = flat.len() as u64; - let n_minors: u64 = flat.iter().map(|m| m.ctors.len() as u64).sum(); - let prefix_base = n_params_u64 + n_motives + n_minors; + let n_minors = flat.iter().try_fold(0u64, |sum, member| { + checked_metadata_sum::( + "generated recursor minors", + &[sum, member.ctors.len() as u64], + ) + })?; + let prefix_base = checked_metadata_sum::( + "generated recursor params + motives + minors", + &[n_params_u64, n_motives, n_minors], + )?; // Position-by-position alignment. // @@ -3528,12 +4070,19 @@ peers={} flat={} rec_ids={} failed_gi={failed_gi}", ))); }, }; + let gen_skip = checked_metadata_sum::( + "generated recursor major index", + &[prefix_base, flat[gi].n_indices], + )?; let gen_major = self.recursor_major_domain_for_addr( &gen_rec.ty, - prefix_base + flat[gi].n_indices, + gen_skip, target_addr, )?; - let stored_skip = params + motives + minors + indices; + let stored_skip = checked_metadata_sum::( + "recursor major index", + &[params, motives, minors, indices], + )?; let stored_major = self.recursor_major_domain_for_addr(&ty, stored_skip, target_addr)?; let signatures_match = match (&gen_major, &stored_major) { @@ -3650,8 +4199,19 @@ re-run with `IX_RECURSOR_DUMP={}` for the full breakdown.", let saved = self.lctx.len(); let n_motives = flat.len(); - let n_minors: usize = flat.iter().map(|m| m.ctors.len()).sum(); - let pmm = n_rec_params + n_motives + n_minors; + let n_minors = flat.iter().try_fold(0usize, |sum, m| { + checked_binder_sum::("generated recursor minors", sum, m.ctors.len()) + })?; + let params_and_motives = checked_binder_sum::( + "generated recursor params + motives", + n_rec_params, + n_motives, + )?; + let pmm = checked_binder_sum::( + "generated recursor params + motives + minors", + params_and_motives, + n_minors, + )?; // --- Pass 1: count fields --- // Walk ctor type past own_params WITHOUT substituting (field count is structural), @@ -3672,14 +4232,24 @@ re-run with `IX_RECURSOR_DUMP={}` for the full breakdown.", let w = self.whnf(&tmp)?; match w.data() { ExprData::All(_, _, _, body, _) => { - n_fields += 1; + n_fields = checked_metadata_sum::( + "generated recursor fields", + &[n_fields, 1], + )?; tmp = body.clone(); }, _ => break, } } - let total_lams = pmm as u64 + n_fields; + let pmm_u64 = checked_usize_to_u64::( + "generated recursor params + motives + minors", + pmm, + )?; + let total_lams = checked_metadata_sum::( + "generated recursor rule lambdas", + &[pmm_u64, n_fields], + )?; // --- Pass 2: build body --- // Structure: λ (p0..pk) (m0..ml) (min0..minr) (f0..fn), body @@ -3694,10 +4264,35 @@ re-run with `IX_RECURSOR_DUMP={}` for the full breakdown.", // Var(0) = last field (fn-1) // Global minor index for this ctor - let global_minor_idx: usize = - flat.iter().take(member_idx).map(|m| m.ctors.len()).sum::() - + ctor_local_idx; - let minor_var_idx = n_fields + (n_minors - 1 - global_minor_idx) as u64; + let earlier_minors = + flat.iter().take(member_idx).try_fold(0usize, |sum, m| { + checked_binder_sum::( + "generated recursor preceding minors", + sum, + m.ctors.len(), + ) + })?; + let global_minor_idx = checked_binder_sum::( + "generated recursor global minor index", + earlier_minors, + ctor_local_idx, + )?; + let trailing_minors = n_minors + .checked_sub(global_minor_idx) + .and_then(|n| n.checked_sub(1)) + .ok_or_else(|| { + TcError::Other( + "generated recursor global minor index out of range".into(), + ) + })?; + let trailing_minors = checked_usize_to_u64::( + "generated recursor trailing minors", + trailing_minors, + )?; + let minor_var_idx = checked_metadata_sum::( + "generated recursor minor variable index", + &[n_fields, trailing_minors], + )?; let mut body = self.intern(KExpr::var(minor_var_idx, anon())); // Apply fields: Var(n_fields - 1) down to Var(0) @@ -3717,7 +4312,14 @@ re-run with `IX_RECURSOR_DUMP={}` for the full breakdown.", // push them one past the param slots and out of the body's scope. // Originals substitute directly to `Var(total_lams - 1 - j)`, // matching the same positions. - let aux_sp_lift = total_lams.saturating_sub(n_rec_params as u64); + let n_rec_params_u64 = checked_usize_to_u64::( + "generated recursor parameter count", + n_rec_params, + )?; + let aux_sp_lift = + total_lams.checked_sub(n_rec_params_u64).ok_or_else(|| { + TcError::Other("generated recursor parameter depth underflow".into()) + })?; let mut ty2 = ctor_ty_inst; for j in 0..member.own_params { let w = self.whnf(&ty2)?; @@ -3748,7 +4350,12 @@ re-run with `IX_RECURSOR_DUMP={}` for the full breakdown.", // Without this, Var-containing spec_params (e.g. `α` in // `Entry α β (Node α β)`) would mis-match and their IHs would be // silently dropped. - let rec_field_lift = total_lams.saturating_sub(n_rec_params as u64); + let rec_field_lift = + total_lams.checked_sub(n_rec_params_u64).ok_or_else(|| { + TcError::Other( + "generated recursor recursive-field depth underflow".into(), + ) + })?; let mut field_idx = 0u64; loop { let w = self.whnf(&ty2)?; @@ -3795,7 +4402,16 @@ re-run with `IX_RECURSOR_DUMP={}` for the full breakdown.", let minor_domain = { // Walk past params, motives, and earlier minors to reach this ctor's minor let mut cur = rec_ty_for_member.clone(); - let skip_to_minor = n_rec_params + n_motives + global_minor_idx; + let params_and_motives = checked_binder_sum::( + "generated recursor params + motives", + n_rec_params, + n_motives, + )?; + let skip_to_minor = checked_binder_sum::( + "generated recursor minor position", + params_and_motives, + global_minor_idx, + )?; for _ in 0..skip_to_minor { let w = self.whnf(&cur)?; match w.data() { @@ -3816,7 +4432,14 @@ re-run with `IX_RECURSOR_DUMP={}` for the full breakdown.", // We lift each domain by the difference to adjust free Var references. // Cutoff = fi because domain fi is inside fi nested foralls in the minor's // type, so Var(0)..Var(fi-1) are bound refs to earlier fields, not free. - let field_dom_lift = (n_minors - global_minor_idx) as u64; + let field_dom_lift = checked_usize_to_u64::( + "generated recursor field-domain lift", + n_minors.checked_sub(global_minor_idx).ok_or_else(|| { + TcError::Other( + "generated recursor global minor index out of range".into(), + ) + })?, + )?; let mut field_domains: Vec> = Vec::with_capacity(u64_to_usize::(n_fields)?); let mut minor_cur = minor_domain; @@ -3920,7 +4543,10 @@ re-run with `IX_RECURSOR_DUMP={}` for the full breakdown.", Some(KConst::Recr { lvls, .. }) => lvls, _ => { if is_large { - flat[target_bi].lvls + 1 + checked_metadata_sum::( + "generated recursor universe arity", + &[flat[target_bi].lvls, 1], + )? } else { flat[target_bi].lvls } @@ -3948,7 +4574,10 @@ re-run with `IX_RECURSOR_DUMP={}` for the full breakdown.", forall_doms.push(fd.clone()); inner = fb.clone(); } - let n_xs = forall_doms.len() as u64; + let n_xs = checked_usize_to_u64::( + "generated recursor wrapped-field binder count", + forall_doms.len(), + )?; // Extract index args from the inner application: `I_target params idx_args` let inner_w = self.whnf(&inner)?; @@ -3958,26 +4587,38 @@ re-run with `IX_RECURSOR_DUMP={}` for the full breakdown.", // Build the IH core: rec[target] params motives minors indices field // All Var references are relative to total_lams (+ n_xs for forall-wrapped case). - let depth = total_lams + n_xs; + let depth = checked_metadata_sum::( + "generated recursor induction-hypothesis depth", + &[total_lams, n_xs], + )?; + let n_rec_params_u64 = checked_usize_to_u64::( + "generated recursor parameter count", + n_rec_params, + )?; + let n_motives_u64 = + checked_usize_to_u64::("generated recursor motive count", n_motives)?; let mut ih = self.intern(KExpr::cnst(peer_rec.clone(), rec_lvls)); // Apply params for pi in 0..n_rec_params { - let pvar = self.intern(KExpr::var(depth - 1 - pi as u64, anon())); + let pi = + checked_usize_to_u64::("generated recursor parameter index", pi)?; + let pvar = self.intern(KExpr::var(depth - 1 - pi, anon())); ih = self.intern(KExpr::app(ih, pvar)); } // Apply motives for mi in 0..n_motives { - let mvar = self.intern(KExpr::var( - depth - 1 - n_rec_params as u64 - mi as u64, - anon(), - )); + let mi = + checked_usize_to_u64::("generated recursor motive index", mi)?; + let mvar = + self.intern(KExpr::var(depth - 1 - n_rec_params_u64 - mi, anon())); ih = self.intern(KExpr::app(ih, mvar)); } // Apply minors for mi in 0..n_minors { + let mi = checked_usize_to_u64::("generated recursor minor index", mi)?; let mvar = self.intern(KExpr::var( - depth - 1 - n_rec_params as u64 - n_motives as u64 - mi as u64, + depth - 1 - n_rec_params_u64 - n_motives_u64 - mi, anon(), )); ih = self.intern(KExpr::app(ih, mvar)); @@ -3991,7 +4632,16 @@ re-run with `IX_RECURSOR_DUMP={}` for the full breakdown.", // Apply the field variable (+ xs for forall-wrapped case) // Field is at Var(n_fields - 1 - field_idx) relative to total_lams, // shifted by n_xs under the forall binders. - let field_base = n_fields - 1 - field_idx + n_xs; + let field_offset = n_fields + .checked_sub(field_idx) + .and_then(|n| n.checked_sub(1)) + .ok_or_else(|| { + TcError::Other("generated recursor field index out of range".into()) + })?; + let field_base = checked_metadata_sum::( + "generated recursor wrapped-field index", + &[field_offset, n_xs], + )?; let mut field_app = self.intern(KExpr::var(field_base, anon())); // Apply forall-bound variables: xs are Var(n_xs-1)..Var(0) under the lambdas for xi in 0..n_xs { @@ -4013,59 +4663,6 @@ re-run with `IX_RECURSOR_DUMP={}` for the full breakdown.", Ok(ih) } - /// Kernel-driven recursor coherence check (no syntactic compare). - /// - /// Catches the structural failure modes that `infer(rec.ty)` alone - /// misses: - /// - The major inductive is itself ill-formed (e.g. strict-positivity - /// violation, bad ctor return shape, field universe too high). - /// `check_inductive` runs A1–A4 and will reject the recursor-by- - /// extension if those fail. - /// - The declared `k` flag disagrees with what the kernel computes - /// from the inductive's shape. K-reduction is only sound for a very - /// narrow class of inductives; a mismatch here is a soundness bug. - /// - /// Deliberately does **not** regenerate canonical recursors and - /// compare them syntactically against the stored form: that approach - /// produces false-positive mismatches on nested inductives and is - /// redundant once infer + the coherence gate agree. - pub fn check_recursor_coherence( - &mut self, - id: &KId, - ) -> Result<(), TcError> { - let (ty, declared_k, params, motives, minors, indices) = - match self.get_const(id)? { - KConst::Recr { ty, k, params, motives, minors, indices, .. } => { - (ty.clone(), k, params, motives, minors, indices) - }, - _ => { - return Err(TcError::Other( - "check_recursor_coherence: not a recursor".into(), - )); - }, - }; - let skip = params + motives + minors + indices; - let ind_id = self.get_major_inductive_id(&ty, skip)?; - - // Coherence gate: the major inductive itself must pass A1–A4. - // Cycle invariant: `check_inductive` never calls back into - // `check_recursor_coherence` — it only drives its own structural - // checks. Keep it that way. - if matches!(self.try_get_const(&ind_id)?, Some(KConst::Indc { .. })) { - self.check_inductive(&ind_id)?; - } - - // K-target flag must match the kernel's constructive computation. - let computed_k = self.compute_k_target(&ind_id)?; - if declared_k != computed_k { - return Err(TcError::Other(format!( - "check_recursor_coherence: K-target mismatch: declared k={declared_k}, computed k={computed_k}" - ))); - } - - Ok(()) - } - /// Validate a recursor block. A pure recursor block is checked once and the /// result is shared by all sibling recursors. pub fn check_recursor(&mut self, id: &KId) -> Result<(), TcError> { @@ -4127,17 +4724,48 @@ re-run with `IX_RECURSOR_DUMP={}` for the full breakdown.", &mut self, id: &KId, ) -> Result<(), TcError> { - let (rec_block, ty, declared_k, params, motives, minors, indices) = - match self.get_const(id)? { - KConst::Recr { - block, ty, k, params, motives, minors, indices, .. - } => (block.clone(), ty.clone(), k, params, motives, minors, indices), - _ => { - return Err(TcError::Other("check_recursor: not a recursor".into())); - }, - }; + let ( + rec_block, + ty, + declared_k, + declared_lvls, + declared_is_unsafe, + params, + motives, + minors, + indices, + ) = match self.get_const(id)? { + KConst::Recr { + block, + ty, + k, + lvls, + is_unsafe, + params, + motives, + minors, + indices, + .. + } => ( + block.clone(), + ty.clone(), + k, + lvls, + is_unsafe, + params, + motives, + minors, + indices, + ), + _ => { + return Err(TcError::Other("check_recursor: not a recursor".into())); + }, + }; // Find the major inductive from this recursor's type. - let skip = params + motives + minors + indices; + let skip = checked_metadata_sum::( + "recursor major index", + &[params, motives, minors, indices], + )?; let ind_id = self.get_major_inductive_id(&ty, skip)?; // Coherence gate: the major inductive itself must pass A1–A4. Without @@ -4247,7 +4875,10 @@ re-run with `IX_RECURSOR_DUMP={}` for the full breakdown.", .blocks .get(&rec_block) .and_then(|members| members.iter().position(|m| m == id)); - let prefix_skip = params + motives + minors; + let prefix_skip = checked_metadata_sum::( + "recursor params + motives + minors", + &[params, motives, minors], + )?; let stored_major = self.recursor_major_domain_for_addr(&ty, prefix_skip, &ind_id.addr)?; let mut signature_matches: Vec = Vec::new(); @@ -4303,16 +4934,29 @@ re-run with `IX_RECURSOR_DUMP={}` for the full breakdown.", let gen_rec = selected_idx.map(|i| &generated[i]); match gen_rec { Some(g) => { + if declared_lvls != g.lvls { + return Err(TcError::Other(format!( + "check_recursor: universe arity mismatch: stored={declared_lvls}, generated={}", + g.lvls + ))); + } + if declared_is_unsafe != g.is_unsafe { + return Err(TcError::Other(format!( + "check_recursor: safety mismatch: stored={declared_is_unsafe}, generated={}", + g.is_unsafe + ))); + } + if (params, motives, minors, indices) + != (g.params, g.motives, g.minors, g.indices) + { + return Err(TcError::Other(format!( + "check_recursor: arity metadata mismatch: \ + stored=(params={params}, motives={motives}, minors={minors}, indices={indices}), \ + generated=(params={}, motives={}, minors={}, indices={})", + g.params, g.motives, g.minors, g.indices + ))); + } if !self.is_def_eq(&g.ty, &ty)? { - let selected_by_signature = - selected_idx.is_some_and(|idx| signature_matches.contains(&idx)); - if self.env.recursor_aux_order == RecursorAuxOrder::Canonical - && motives > 1 - && selected_by_signature - { - return self.check_recursor_coherence(id); - } - // When `IX_TYPE_DIFF` is set, walk the binder chain to find the // first divergent binder and print a readable gen/sto diff. Off // by default: in alpha-collapse regimes or for mutual blocks @@ -4490,7 +5134,8 @@ re-run with `IX_RECURSOR_DUMP={}` for the full breakdown.", }, _ => continue, }; - let skip = p + mo + mi + ix; + let skip = + checked_metadata_sum::("recursor major index", &[p, mo, mi, ix])?; match self.get_major_inductive_id(&peer_ty, skip) { Ok(major_id) => { majors.insert(major_id); @@ -4534,8 +5179,12 @@ re-run with `IX_RECURSOR_DUMP={}` for the full breakdown.", // 2. Result level must be Prop (semantically zero). // Use univ_eq instead of is_zero() to handle levels like max(0,0) or imax(0,u) // that are semantically zero but not syntactically UnivData::Zero. - let result_level = self - .get_result_sort_level(&ty, u64_to_usize(ind_params + ind_indices)?)?; + let ind_arity = checked_metadata_sum::( + "inductive params + indices", + &[ind_params, ind_indices], + )?; + let result_level = + self.get_result_sort_level(&ty, u64_to_usize(ind_arity)?)?; if !univ_eq(&result_level, &KUniv::zero()) { return Ok(false); } @@ -4559,7 +5208,7 @@ mod tests { use super::super::error::TcError; use super::super::expr::{ExprData, KExpr}; use super::super::id::KId; - use super::super::level::KUniv; + use super::super::level::{KUniv, univ_eq}; use super::super::mode::Anon; use super::super::tc::TypeChecker; use ix_common::address::Address; @@ -4760,40 +5409,133 @@ mod tests { } } + fn replace_bool_true( + env: &mut KEnv, + is_unsafe: bool, + lvls: u64, + induct: KId, + cidx: u64, + params: u64, + fields: u64, + ) { + env.insert( + mk_id("Bool.true"), + KConst::Ctor { + name: (), + level_params: (), + is_unsafe, + lvls, + induct, + cidx, + params, + fields, + ty: cnst("Bool", &[]), + }, + ); + } + + fn replace_bool_rec_header( + env: &mut KEnv, + is_unsafe: bool, + lvls: u64, + params: u64, + motives: u64, + minors: u64, + indices: u64, + ) { + let rec_id = mk_id("Bool.rec"); + let KConst::Recr { + name, + level_params, + k, + block, + member_idx, + ty, + rules, + lean_all, + .. + } = env.get(&rec_id).expect("Bool.rec fixture") + else { + panic!("Bool.rec fixture is not a recursor"); + }; + env.insert( + rec_id, + KConst::Recr { + name, + level_params, + k, + is_unsafe, + lvls, + params, + indices, + motives, + minors, + block, + member_idx, + ty, + rules, + lean_all, + }, + ); + } + + /// Adversarial metadata regression: when block coordination is unavailable, + /// the standalone constructor path must still enforce the parent's parameter + /// count. `check_param_agreement` alone cannot see this redundant field. #[test] - fn check_bool_constructor_uses_parent_block() { + fn reject_standalone_ctor_param_count_mismatch() { let mut env = bool_env(); + env.blocks.remove(&mk_id("Bool")); + replace_bool_true(&mut env, false, 0, mk_id("Bool"), 0, 1, 0); + let mut tc = TypeChecker::new(&mut env); - tc.check_const(&mk_id("Bool.true")).unwrap(); - assert!( - env.block_check_results.get(&mk_id("Bool")).is_some_and(|r| r.is_ok()) - ); + match tc.check_const(&mk_id("Bool.true")) { + Err(TcError::Other(s)) => assert!(s.contains("ctor params mismatch")), + other => panic!("expected ctor params mismatch, got {other:?}"), + } } + /// `cidx` selects the recursor rule during iota reduction, so a constructor + /// checked outside its coordinated block must be tied to its exact position + /// in the parent's constructor array. #[test] - fn check_bool_rec() { + fn reject_standalone_ctor_cidx_mismatch() { let mut env = bool_env(); + env.blocks.remove(&mk_id("Bool")); + replace_bool_true(&mut env, false, 0, mk_id("Bool"), 1, 0, 0); + let mut tc = TypeChecker::new(&mut env); - // Must check inductive first to trigger recursor generation - tc.check_const(&mk_id("Bool")).unwrap(); - assert!(tc.check_const(&mk_id("Bool.rec")).is_ok(), "Bool.rec should pass"); + match tc.check_const(&mk_id("Bool.true")) { + Err(TcError::Other(s)) => assert!(s.contains("ctor cidx mismatch")), + other => panic!("expected ctor cidx mismatch, got {other:?}"), + } } - /// Build env with Nat (1 recursive ctor) and its recursor. - /// Nat : Sort 1 - /// Nat.zero : Nat - /// Nat.succ : Nat → Nat - /// Nat.rec : ∀ (motive : Nat → Sort u) (zero : motive Nat.zero) - /// (succ : ∀ (n : Nat), motive n → motive (Nat.succ n)) - /// (t : Nat), motive t - fn nat_env() -> KEnv { - let mut env = KEnv::new(); - let block = mk_id("Nat"); - let rec_block = mk_id("Nat.rec.block"); - let nat = || cnst("Nat", &[]); + /// Constructor universe parameters are inherited from the inductive in + /// Lean's declaration transaction; unused surplus parameters must not make + /// an otherwise malformed standalone constructor admissible. + #[test] + fn reject_standalone_ctor_universe_arity_mismatch() { + let mut env = bool_env(); + env.blocks.remove(&mk_id("Bool")); + replace_bool_true(&mut env, false, 1, mk_id("Bool"), 0, 0, 0); + + let mut tc = TypeChecker::new(&mut env); + match tc.check_const(&mk_id("Bool.true")) { + Err(TcError::Other(s)) => { + assert!(s.contains("ctor universe arity mismatch")); + }, + other => panic!("expected ctor universe arity mismatch, got {other:?}"), + } + } + /// A physical block must not smuggle in an unlisted constructor. Otherwise + /// its `cidx` is unconstrained by the parent's canonical constructor order. + #[test] + fn reject_unlisted_ctor_in_inductive_block() { + let mut env = bool_env(); env.insert( - mk_id("Nat"), + mk_id("Bool"), KConst::Indc { name: (), level_params: (), @@ -4801,63 +5543,282 @@ mod tests { params: 0, indices: 0, is_unsafe: false, - block: block.clone(), + block: mk_id("Bool"), member_idx: 0, ty: sort1(), - ctors: vec![mk_id("Nat.zero"), mk_id("Nat.succ")], + ctors: vec![], lean_all: (), }, ); + + let mut tc = TypeChecker::new(&mut env); + match tc.check_const(&mk_id("Bool")) { + Err(TcError::Other(s)) => assert!(s.contains("not listed by parent")), + other => panic!("expected unlisted constructor rejection, got {other:?}"), + } + } + + /// Constructor safety is inherited from the inductive. Allowing a safe + /// constructor for an unsafe inductive would let the definition-safety walk + /// miss the unsafe family hidden behind that constructor reference. + #[test] + fn reject_ctor_safety_mismatch() { + let mut env = bool_env(); + replace_bool_true(&mut env, true, 0, mk_id("Bool"), 0, 0, 0); + + let mut tc = TypeChecker::new(&mut env); + match tc.check_const(&mk_id("Bool")) { + Err(TcError::Other(s)) => assert!(s.contains("ctor safety mismatch")), + other => panic!("expected ctor safety mismatch, got {other:?}"), + } + } + + /// Negative control for the numeric-field audit: `fields` was already + /// checked exactly by peeling `params + fields` binders before requiring the + /// manifest inductive return head. + #[test] + fn reject_ctor_field_count_mismatch() { + let mut env = nat_env(); + env.blocks.remove(&mk_id("Nat")); env.insert( - mk_id("Nat.zero"), + mk_id("Nat.succ"), KConst::Ctor { name: (), level_params: (), is_unsafe: false, lvls: 0, induct: mk_id("Nat"), - cidx: 0, + cidx: 1, params: 0, fields: 0, - ty: nat(), + ty: pi(cnst("Nat", &[]), cnst("Nat", &[])), }, ); + + let mut tc = TypeChecker::new(&mut env); + assert!( + tc.check_const(&mk_id("Nat.succ")).is_err(), + "constructor with a false field count must be rejected" + ); + } + + /// Inductive telescope metadata is summed before it is used as a binder + /// count. The sum must be mathematical, not wrapping `u64` arithmetic. + #[test] + fn reject_inductive_arity_sum_overflow() { + let mut env = KEnv::new(); + let id = mk_id("OverflowInd"); + let block = mk_id("OverflowInd.block"); env.insert( - mk_id("Nat.succ"), - KConst::Ctor { + id.clone(), + KConst::Indc { name: (), level_params: (), - is_unsafe: false, lvls: 0, - induct: mk_id("Nat"), - cidx: 1, - params: 0, - fields: 1, - ty: pi(nat(), nat()), + params: u64::MAX, + indices: 1, + is_unsafe: false, + block: block.clone(), + member_idx: 0, + ty: sort1(), + ctors: vec![], + lean_all: (), }, ); + env.blocks.insert(block, vec![id.clone()]); - // Nat.rec type - let motive_ty = pi(nat(), AE::sort(param(0))); - // minor_zero: motive Nat.zero (motive is Var(0) here) - let minor_zero = app(var(0), cnst("Nat.zero", &[])); - // minor_succ: ∀ (n : Nat) (ih : motive n), motive (Nat.succ n) - // motive is Var(2) inside the two binders - let minor_succ = pi( - nat(), - pi(app(var(2), var(0)), app(var(3), app(cnst("Nat.succ", &[]), var(1)))), - ); - let major = nat(); - let ret = app(var(3), var(0)); - let rec_ty = pi( - motive_ty.clone(), - pi(minor_zero.clone(), pi(minor_succ.clone(), pi(major, ret))), - ); + let mut tc = TypeChecker::new(&mut env); + match tc.check_const(&id) { + Err(TcError::Other(s)) => { + assert!(s.contains("inductive params + indices metadata sum overflow")); + }, + other => panic!("expected inductive arity overflow, got {other:?}"), + } + } - // Nat.rec rules — use actual domain types from recursor type - let motive_dom = motive_ty; - let h_zero_dom = minor_zero; - let h_succ_dom = minor_succ; + /// Large elimination adds one universe parameter to the inductive's own + /// level arity. That derived count is part of canonical recursor metadata + /// and must not wrap back to zero. + #[test] + fn reject_generated_recursor_universe_arity_overflow() { + let mut env = KEnv::new(); + let id = mk_id("OverflowRecLevels"); + env.insert( + id.clone(), + KConst::Indc { + name: (), + level_params: (), + lvls: u64::MAX, + params: 0, + indices: 0, + is_unsafe: false, + block: id.clone(), + member_idx: 0, + ty: sort1(), + ctors: vec![], + lean_all: (), + }, + ); + env.blocks.insert(id.clone(), vec![id.clone()]); + + let mut tc = TypeChecker::new(&mut env); + match tc.check_const(&id) { + Err(TcError::Other(s)) => { + assert!( + s.contains("generated recursor universe arity metadata sum overflow") + ); + }, + other => { + panic!("expected generated recursor level overflow, got {other:?}") + }, + } + } + + /// The recursor major index is the sum of four serialized arities. This + /// gate is the executable no-wrap fact consumed by ordinary iota proofs. + #[test] + fn reject_recursor_major_index_overflow() { + let mut env = bool_env(); + let rec_id = mk_id("Bool.rec"); + replace_bool_rec_header(&mut env, false, 1, u64::MAX, 1, 0, 0); + + let mut tc = TypeChecker::new(&mut env); + match tc.check_const(&rec_id) { + Err(TcError::Other(s)) => { + assert!(s.contains("recursor major index metadata sum overflow")); + }, + other => panic!("expected recursor major-index overflow, got {other:?}"), + } + } + + #[test] + fn reject_recursor_universe_arity_mismatch() { + let mut env = bool_env(); + replace_bool_rec_header(&mut env, false, 2, 0, 1, 2, 0); + + let mut tc = TypeChecker::new(&mut env); + match tc.check_const(&mk_id("Bool.rec")) { + Err(TcError::Other(s)) => { + assert!(s.contains("check_recursor: universe arity mismatch")); + }, + other => { + panic!("expected recursor universe arity mismatch, got {other:?}") + }, + } + } + + #[test] + fn reject_recursor_safety_mismatch() { + let mut env = bool_env(); + replace_bool_rec_header(&mut env, true, 1, 0, 1, 2, 0); + + let mut tc = TypeChecker::new(&mut env); + match tc.check_const(&mk_id("Bool.rec")) { + Err(TcError::Other(s)) => { + assert!(s.contains("check_recursor: safety mismatch")); + }, + other => panic!("expected recursor safety mismatch, got {other:?}"), + } + } + + #[test] + fn check_bool_constructor_uses_parent_block() { + let mut env = bool_env(); + let mut tc = TypeChecker::new(&mut env); + tc.check_const(&mk_id("Bool.true")).unwrap(); + assert!( + env.block_check_results.get(&mk_id("Bool")).is_some_and(|r| r.is_ok()) + ); + } + + #[test] + fn check_bool_rec() { + let mut env = bool_env(); + let mut tc = TypeChecker::new(&mut env); + // Must check inductive first to trigger recursor generation + tc.check_const(&mk_id("Bool")).unwrap(); + assert!(tc.check_const(&mk_id("Bool.rec")).is_ok(), "Bool.rec should pass"); + } + + /// Build env with Nat (1 recursive ctor) and its recursor. + /// Nat : Sort 1 + /// Nat.zero : Nat + /// Nat.succ : Nat → Nat + /// Nat.rec : ∀ (motive : Nat → Sort u) (zero : motive Nat.zero) + /// (succ : ∀ (n : Nat), motive n → motive (Nat.succ n)) + /// (t : Nat), motive t + fn nat_env() -> KEnv { + let mut env = KEnv::new(); + let block = mk_id("Nat"); + let rec_block = mk_id("Nat.rec.block"); + let nat = || cnst("Nat", &[]); + + env.insert( + mk_id("Nat"), + KConst::Indc { + name: (), + level_params: (), + lvls: 0, + params: 0, + indices: 0, + is_unsafe: false, + block: block.clone(), + member_idx: 0, + ty: sort1(), + ctors: vec![mk_id("Nat.zero"), mk_id("Nat.succ")], + lean_all: (), + }, + ); + env.insert( + mk_id("Nat.zero"), + KConst::Ctor { + name: (), + level_params: (), + is_unsafe: false, + lvls: 0, + induct: mk_id("Nat"), + cidx: 0, + params: 0, + fields: 0, + ty: nat(), + }, + ); + env.insert( + mk_id("Nat.succ"), + KConst::Ctor { + name: (), + level_params: (), + is_unsafe: false, + lvls: 0, + induct: mk_id("Nat"), + cidx: 1, + params: 0, + fields: 1, + ty: pi(nat(), nat()), + }, + ); + + // Nat.rec type + let motive_ty = pi(nat(), AE::sort(param(0))); + // minor_zero: motive Nat.zero (motive is Var(0) here) + let minor_zero = app(var(0), cnst("Nat.zero", &[])); + // minor_succ: ∀ (n : Nat) (ih : motive n), motive (Nat.succ n) + // motive is Var(2) inside the two binders + let minor_succ = pi( + nat(), + pi(app(var(2), var(0)), app(var(3), app(cnst("Nat.succ", &[]), var(1)))), + ); + let major = nat(); + let ret = app(var(3), var(0)); + let rec_ty = pi( + motive_ty.clone(), + pi(minor_zero.clone(), pi(minor_succ.clone(), pi(major, ret))), + ); + + // Nat.rec rules — use actual domain types from recursor type + let motive_dom = motive_ty; + let h_zero_dom = minor_zero; + let h_succ_dom = minor_succ; let rule_zero_rhs = lam( motive_dom.clone(), lam(h_zero_dom.clone(), lam(h_succ_dom.clone(), var(1))), @@ -5268,6 +6229,152 @@ mod tests { assert_eq!(generated[1].ind_addr, mk_addr("List")); } + /// Lean generates distinct nested auxiliaries when the external family and + /// term parameter agree but a phantom universe argument differs. This is + /// the direct metadata analogue of: + /// + /// `Phantom.{p,q} (A : Sort p) : Prop` + /// `UniverseNested.left : Phantom.{0,u} UniverseNested → UniverseNested` + /// `UniverseNested.right : Phantom.{0,v} UniverseNested → UniverseNested`. + fn universe_specialized_nested_env() -> KEnv { + let mut env = KEnv::new(); + let phantom = mk_id("Phantom"); + let root = mk_id("UniverseNested"); + let root_app = || cnst("UniverseNested", &[param(0), param(1)]); + + env.insert( + phantom.clone(), + KConst::Indc { + name: (), + level_params: (), + lvls: 2, + params: 1, + indices: 0, + is_unsafe: false, + block: phantom.clone(), + member_idx: 0, + ty: pi(AE::sort(param(0)), _sort0()), + ctors: vec![mk_id("Phantom.mk")], + lean_all: (), + }, + ); + env.insert( + mk_id("Phantom.mk"), + KConst::Ctor { + name: (), + level_params: (), + is_unsafe: false, + lvls: 2, + induct: phantom.clone(), + cidx: 0, + params: 1, + fields: 1, + ty: pi( + AE::sort(param(0)), + pi( + AE::sort(param(1)), + app(cnst("Phantom", &[param(0), param(1)]), var(1)), + ), + ), + }, + ); + env + .blocks + .insert(phantom.clone(), vec![phantom.clone(), mk_id("Phantom.mk")]); + + env.insert( + root.clone(), + KConst::Indc { + name: (), + level_params: (), + lvls: 2, + params: 0, + indices: 0, + is_unsafe: false, + block: root.clone(), + member_idx: 0, + ty: _sort0(), + ctors: vec![ + mk_id("UniverseNested.left"), + mk_id("UniverseNested.right"), + ], + lean_all: (), + }, + ); + for (name, phantom_level, cidx) in [ + ("UniverseNested.left", param(0), 0), + ("UniverseNested.right", param(1), 1), + ] { + let nested = + app(cnst("Phantom", &[AU::zero(), phantom_level]), root_app()); + env.insert( + mk_id(name), + KConst::Ctor { + name: (), + level_params: (), + is_unsafe: false, + lvls: 2, + induct: root.clone(), + cidx, + params: 0, + fields: 1, + ty: pi(nested, root_app()), + }, + ); + } + env.blocks.insert( + root.clone(), + vec![root, mk_id("UniverseNested.left"), mk_id("UniverseNested.right")], + ); + env + } + + #[test] + fn nested_aux_identity_includes_universe_specialization() { + let mut env = universe_specialized_nested_env(); + let mut tc = TypeChecker::new(&mut env); + tc.check_const(&mk_id("UniverseNested")).unwrap(); + + let generated = tc + .env + .recursor_cache + .get(&mk_id("UniverseNested")) + .expect("root recursor generation should be cached"); + assert_eq!( + generated.len(), + 3, + "root plus Phantom.{{0,u}} and Phantom.{{0,v}} must remain distinct" + ); + assert_eq!(generated[0].motives, 3); + assert_eq!(generated[1].ind_addr, mk_addr("Phantom")); + assert_eq!(generated[2].ind_addr, mk_addr("Phantom")); + } + + #[test] + fn semantic_universe_equality_does_not_collapse_nested_specialization() { + let family = mk_addr("CommutedUniverseFamily"); + let u = param(0); + let v = param(1); + let left = AU::max(u.clone(), v.clone()); + let right = AU::max(v, u); + + assert!( + univ_eq(&left, &right), + "commuted maxima should be semantically equal" + ); + assert!( + !super::same_nested_specialization::( + &family, + &[left], + &[], + &family, + &[right], + &[], + ), + "semantic universe equality must not merge exact flat-block keys" + ); + } + #[test] fn nested_tree_rec_type_matches() { // Verify that the generated Tree.rec type matches what lean4 would produce. @@ -6509,36 +7616,323 @@ mod tests { // Nested positivity tests // ----------------------------------------------------------------------- - /// Build an env with an external inductive `Wrap` that has its type param - /// in a **negative** position: `Wrap.mk : ∀ (α : Type), (α → Bool) → Wrap α`. - /// Then define `Evil : Type` with `Evil.mk : Wrap Evil → Evil`. - /// This must be REJECTED: `Evil` appears negatively inside `Wrap`'s constructor. - fn wrap_evil_env() -> KEnv { - let mut env = bool_env(); + #[test] + fn reject_fabricated_multi_motive_recursor() { + let mut env = nat_env(); + let rec_id = mk_id("Bad.rec"); + let rec_block = mk_id("Bad.rec.block"); - // Wrap : Type → Type (1 param, 0 indices) - let wrap_ty = pi(sort1(), sort1()); - let wrap_block = mk_id("Wrap"); + // (C : Nat -> Prop) -> (junk : Nat) -> (n : Nat) -> C n. + // With attacker-supplied `motives = 2`, the old canonical-order fallback + // accepted this type without comparing it or its empty rule list with + // generated Nat.rec. + let ty = pi( + pi(cnst("Nat", &[]), _sort0()), + pi(cnst("Nat", &[]), pi(cnst("Nat", &[]), app(var(2), var(0)))), + ); env.insert( - mk_id("Wrap"), - KConst::Indc { + rec_id.clone(), + KConst::Recr { name: (), level_params: (), - lvls: 0, - params: 1, - indices: 0, + k: false, is_unsafe: false, - block: wrap_block.clone(), + // Nat.rec has one recursor universe parameter. Keep the fabricated + // declaration canonical on metadata so this test reaches the intended + // multi-motive/type comparison rather than the earlier metadata gate. + lvls: 1, + params: 0, + indices: 0, + motives: 2, + minors: 0, + block: rec_block.clone(), member_idx: 0, - ty: wrap_ty, - ctors: vec![mk_id("Wrap.mk")], + ty, + rules: vec![], lean_all: (), }, ); + env.blocks.insert(rec_block, vec![rec_id.clone()]); - // Wrap.mk : ∀ (α : Type), (α → Bool) → Wrap α - // Under ∀(α : Type): Var(0) = α - let wrap_mk_ty = pi( + let mut tc = TypeChecker::new(&mut env); + let result = tc.check_const(&rec_id); + assert!( + matches!(result, Err(TcError::Other(ref msg)) + if msg.contains("arity metadata mismatch") || msg.contains("type mismatch")), + "fabricated multi-motive recursor must be rejected, got {result:?}" + ); + } + + #[test] + fn reject_nonuniform_recursive_field_parameter() { + let mut env = nat_env(); + let block = mk_id("I"); + let ind = mk_id("I"); + let ctor = mk_id("I.mk"); + env.insert( + ind.clone(), + KConst::Indc { + name: (), + level_params: (), + lvls: 0, + params: 1, + indices: 0, + is_unsafe: false, + block: block.clone(), + member_idx: 0, + ty: pi(sort1(), sort1()), + ctors: vec![ctor.clone()], + lean_all: (), + }, + ); + // I.mk : (A : Type) -> I Nat -> I A. + env.insert( + ctor.clone(), + KConst::Ctor { + name: (), + level_params: (), + lvls: 0, + cidx: 0, + params: 1, + fields: 1, + is_unsafe: false, + induct: ind.clone(), + ty: pi( + sort1(), + pi( + app(cnst("I", &[]), cnst("Nat", &[])), + app(cnst("I", &[]), var(1)), + ), + ), + }, + ); + env.blocks.insert(block, vec![ind.clone(), ctor]); + + let mut tc = TypeChecker::new(&mut env); + let result = tc.check_const(&ind); + assert!( + matches!(result, Err(TcError::Other(ref msg)) + if msg.contains("non-uniform parameter")), + "non-uniform recursive parameter must be rejected, got {result:?}" + ); + } + + #[test] + fn reject_nonuniform_recursive_field_universe() { + let mut env = nat_env(); + let block = mk_id("J"); + let ind = mk_id("J"); + let ctor = mk_id("J.mk"); + env.insert( + ind.clone(), + KConst::Indc { + name: (), + level_params: (), + lvls: 1, + params: 0, + indices: 0, + is_unsafe: false, + block: block.clone(), + member_idx: 0, + ty: sort1(), + ctors: vec![ctor.clone()], + lean_all: (), + }, + ); + // J.mk.{u} : J.{0} -> J.{u}. + env.insert( + ctor.clone(), + KConst::Ctor { + name: (), + level_params: (), + lvls: 1, + cidx: 0, + params: 0, + fields: 1, + is_unsafe: false, + induct: ind.clone(), + ty: pi(cnst("J", &[AU::zero()]), cnst("J", &[param(0)])), + }, + ); + env.blocks.insert(block, vec![ind.clone(), ctor]); + + let mut tc = TypeChecker::new(&mut env); + let result = tc.check_const(&ind); + assert!( + matches!(result, Err(TcError::Other(ref msg)) + if msg.contains("non-uniform universe arguments")), + "non-uniform recursive universes must be rejected, got {result:?}" + ); + } + + #[test] + fn reject_recursive_field_index_mention() { + let mut env = nat_env(); + let block = mk_id("K"); + let ind = mk_id("K"); + let ctor = mk_id("K.mk"); + env.insert( + ind.clone(), + KConst::Indc { + name: (), + level_params: (), + lvls: 0, + params: 0, + indices: 1, + is_unsafe: false, + block: block.clone(), + member_idx: 0, + ty: pi(sort1(), sort1()), + ctors: vec![ctor.clone()], + lean_all: (), + }, + ); + // K.mk : K (K Nat) -> K Nat. + env.insert( + ctor.clone(), + KConst::Ctor { + name: (), + level_params: (), + lvls: 0, + cidx: 0, + params: 0, + fields: 1, + is_unsafe: false, + induct: ind.clone(), + ty: pi( + app(cnst("K", &[]), app(cnst("K", &[]), cnst("Nat", &[]))), + app(cnst("K", &[]), cnst("Nat", &[])), + ), + }, + ); + env.blocks.insert(block, vec![ind.clone(), ctor]); + + let mut tc = TypeChecker::new(&mut env); + let result = tc.check_const(&ind); + assert!( + matches!(result, Err(TcError::Other(ref msg)) + if msg.contains("index mentions an active inductive")), + "recursive occurrence indices must not mention the active block, got {result:?}" + ); + } + + #[test] + fn reject_ill_typed_phantom_nested_argument_before_rewrite() { + let mut env = nat_env(); + + // Phantom : Type -> Type; Phantom.mk : (A : Type) -> Phantom A. + // Its parameter is absent from every constructor field, so a lossy + // nested-inductive rewrite could erase the argument entirely. + let phantom = mk_id("Phantom"); + let phantom_ctor = mk_id("Phantom.mk"); + env.insert( + phantom.clone(), + KConst::Indc { + name: (), + level_params: (), + lvls: 0, + params: 1, + indices: 0, + is_unsafe: false, + block: phantom.clone(), + member_idx: 0, + ty: pi(sort1(), sort1()), + ctors: vec![phantom_ctor.clone()], + lean_all: (), + }, + ); + env.insert( + phantom_ctor.clone(), + KConst::Ctor { + name: (), + level_params: (), + lvls: 0, + cidx: 0, + params: 1, + fields: 0, + is_unsafe: false, + induct: phantom.clone(), + ty: pi(sort1(), app(cnst("Phantom", &[]), var(0))), + }, + ); + env.blocks.insert(phantom.clone(), vec![phantom.clone(), phantom_ctor]); + + // Bad.mk : Phantom (Nat Nat) -> Bad. `Nat Nat` is ill-typed. The + // original stored constructor must be inferred before nested flattening, + // even though Phantom's parameter is phantom. + let bad = mk_id("BadPhantom"); + let bad_ctor = mk_id("BadPhantom.mk"); + env.insert( + bad.clone(), + KConst::Indc { + name: (), + level_params: (), + lvls: 0, + params: 0, + indices: 0, + is_unsafe: false, + block: bad.clone(), + member_idx: 0, + ty: sort1(), + ctors: vec![bad_ctor.clone()], + lean_all: (), + }, + ); + let invalid_arg = app(cnst("Nat", &[]), cnst("Nat", &[])); + env.insert( + bad_ctor.clone(), + KConst::Ctor { + name: (), + level_params: (), + lvls: 0, + cidx: 0, + params: 0, + fields: 1, + is_unsafe: false, + induct: bad.clone(), + ty: pi(app(cnst("Phantom", &[]), invalid_arg), cnst("BadPhantom", &[])), + }, + ); + env.blocks.insert(bad.clone(), vec![bad.clone(), bad_ctor]); + + let mut tc = TypeChecker::new(&mut env); + let result = tc.check_const(&bad); + assert!( + matches!(result, Err(TcError::FunExpected { .. })), + "ill-typed phantom nested argument must be rejected before rewriting, got {result:?}" + ); + } + + /// Build an env with an external inductive `Wrap` that has its type param + /// in a **negative** position: `Wrap.mk : ∀ (α : Type), (α → Bool) → Wrap α`. + /// Then define `Evil : Type` with `Evil.mk : Wrap Evil → Evil`. + /// This must be REJECTED: `Evil` appears negatively inside `Wrap`'s constructor. + fn wrap_evil_env() -> KEnv { + let mut env = bool_env(); + + // Wrap : Type → Type (1 param, 0 indices) + let wrap_ty = pi(sort1(), sort1()); + let wrap_block = mk_id("Wrap"); + env.insert( + mk_id("Wrap"), + KConst::Indc { + name: (), + level_params: (), + lvls: 0, + params: 1, + indices: 0, + is_unsafe: false, + block: wrap_block.clone(), + member_idx: 0, + ty: wrap_ty, + ctors: vec![mk_id("Wrap.mk")], + lean_all: (), + }, + ); + + // Wrap.mk : ∀ (α : Type), (α → Bool) → Wrap α + // Under ∀(α : Type): Var(0) = α + let wrap_mk_ty = pi( sort1(), // α : Type pi( pi(var(0), cnst("Bool", &[])), // (α → Bool) @@ -6740,6 +8134,158 @@ mod tests { ); } + /// A helper family that carries the root may itself use an already-active + /// helper at a specialization unrelated to the root. That unrelated use is + /// not a recursive occurrence. This is the small analogue of + /// `TacticParsedSnapshot`, where traversing + /// `Option (SnapshotTask TacticParsedSnapshot)` later encounters + /// `Option Syntax`. + #[test] + fn accept_distinct_specializations_of_active_nested_helper() { + let mut env = nat_env(); + + // Opt : Type -> Type. + let opt = mk_id("Opt"); + let opt_none = mk_id("Opt.none"); + let opt_some = mk_id("Opt.some"); + env.insert( + opt.clone(), + KConst::Indc { + name: (), + level_params: (), + lvls: 0, + params: 1, + indices: 0, + is_unsafe: false, + block: opt.clone(), + member_idx: 0, + ty: pi(sort1(), sort1()), + ctors: vec![opt_none.clone(), opt_some.clone()], + lean_all: (), + }, + ); + env.insert( + opt_none.clone(), + KConst::Ctor { + name: (), + level_params: (), + lvls: 0, + cidx: 0, + params: 1, + fields: 0, + is_unsafe: false, + induct: opt.clone(), + ty: pi(sort1(), app(cnst("Opt", &[]), var(0))), + }, + ); + env.insert( + opt_some.clone(), + KConst::Ctor { + name: (), + level_params: (), + lvls: 0, + cidx: 1, + params: 1, + fields: 1, + is_unsafe: false, + induct: opt.clone(), + ty: pi(sort1(), pi(var(0), app(cnst("Opt", &[]), var(1)))), + }, + ); + env.blocks.insert(opt.clone(), vec![opt.clone(), opt_none, opt_some]); + + // Helper A has an unrelated `Opt Nat`, a root-carrying `Opt A`, and a + // positive A field. + let helper = mk_id("Helper"); + let helper_mk = mk_id("Helper.mk"); + env.insert( + helper.clone(), + KConst::Indc { + name: (), + level_params: (), + lvls: 0, + params: 1, + indices: 0, + is_unsafe: false, + block: helper.clone(), + member_idx: 0, + ty: pi(sort1(), sort1()), + ctors: vec![helper_mk.clone()], + lean_all: (), + }, + ); + env.insert( + helper_mk.clone(), + KConst::Ctor { + name: (), + level_params: (), + lvls: 0, + cidx: 0, + params: 1, + fields: 3, + is_unsafe: false, + induct: helper.clone(), + ty: pi( + sort1(), + pi( + app(cnst("Opt", &[]), cnst("Nat", &[])), + pi( + app(cnst("Opt", &[]), var(1)), + pi(var(2), app(cnst("Helper", &[]), var(3))), + ), + ), + ), + }, + ); + env.blocks.insert(helper.clone(), vec![helper.clone(), helper_mk]); + + // Root.mk : Opt (Helper Root) -> Root. + let root = mk_id("NestedReuseRoot"); + let root_mk = mk_id("NestedReuseRoot.mk"); + env.insert( + root.clone(), + KConst::Indc { + name: (), + level_params: (), + lvls: 0, + params: 0, + indices: 0, + is_unsafe: false, + block: root.clone(), + member_idx: 0, + ty: sort1(), + ctors: vec![root_mk.clone()], + lean_all: (), + }, + ); + let nested = app( + cnst("Opt", &[]), + app(cnst("Helper", &[]), cnst("NestedReuseRoot", &[])), + ); + env.insert( + root_mk.clone(), + KConst::Ctor { + name: (), + level_params: (), + lvls: 0, + cidx: 0, + params: 0, + fields: 1, + is_unsafe: false, + induct: root.clone(), + ty: pi(nested, cnst("NestedReuseRoot", &[])), + }, + ); + env.blocks.insert(root.clone(), vec![root.clone(), root_mk]); + + let mut tc = TypeChecker::new(&mut env); + let result = tc.check_const(&root); + assert!( + result.is_ok(), + "distinct helper specializations must not be mistaken for recursive non-uniformity: {result:?}" + ); + } + // --------------------------------------------------------------------- // Regression tests for the P1 soundness gaps closed in the 2026-04 // hardening pass. @@ -6934,6 +8480,70 @@ mod tests { ); } + #[test] + fn reject_mutual_peers_with_mismatched_universe_arity() { + let mut env = KEnv::new(); + let block = mk_id("Mut"); + for (i, (name, lvls)) in [("M1", 0), ("M2", 1)].iter().enumerate() { + env.insert( + mk_id(name), + KConst::Indc { + name: (), + level_params: (), + lvls: *lvls, + params: 0, + indices: 0, + is_unsafe: false, + block: block.clone(), + member_idx: i as u64, + ty: sort1(), + ctors: vec![], + lean_all: (), + }, + ); + } + env.blocks.insert(block, vec![mk_id("M1"), mk_id("M2")]); + + let mut tc = TypeChecker::new(&mut env); + match tc.check_const(&mk_id("M1")) { + Err(TcError::Other(s)) => assert!(s.contains("same universe arity")), + other => panic!("expected mutual universe-arity mismatch, got {other:?}"), + } + } + + #[test] + fn reject_mutual_peers_with_mismatched_safety() { + let mut env = KEnv::new(); + let block = mk_id("Mut"); + for (i, (name, is_unsafe)) in + [("M1", false), ("M2", true)].iter().enumerate() + { + env.insert( + mk_id(name), + KConst::Indc { + name: (), + level_params: (), + lvls: 0, + params: 0, + indices: 0, + is_unsafe: *is_unsafe, + block: block.clone(), + member_idx: i as u64, + ty: sort1(), + ctors: vec![], + lean_all: (), + }, + ); + } + env.blocks.insert(block, vec![mk_id("M1"), mk_id("M2")]); + + let mut tc = TypeChecker::new(&mut env); + match tc.check_const(&mk_id("M1")) { + Err(TcError::Other(s)) => assert!(s.contains("same safety flag")), + other => panic!("expected mutual safety mismatch, got {other:?}"), + } + } + /// P1-2 regression: two mutual inductives with *different* parameter /// counts must also be rejected — at the explicit `peer_params != params` /// arm of S3b, prior to reaching domain comparison. diff --git a/crates/kernel/src/tc.rs b/crates/kernel/src/tc.rs index 81d95f464..252798cc4 100644 --- a/crates/kernel/src/tc.rs +++ b/crates/kernel/src/tc.rs @@ -70,8 +70,13 @@ pub fn max_rec_fuel() -> u64 { (*IX_MAX_REC_FUEL).unwrap_or(MAX_REC_FUEL) } -/// Temporary struct for recursor info during iota reduction, -/// avoiding borrow conflicts with `&self.env`. +/// Temporary struct for recursor info during iota reduction, avoiding borrow +/// conflicts with `&self.env`. +/// +/// The layout fields are added on the WHNF hot path. This is sound only for an +/// accepted environment: `check_recursor_member` first proves their complete +/// sum does not overflow and equals canonical recursor generation. Direct +/// callers that construct an unchecked `KEnv` do not inherit that precondition. pub struct IotaInfo { pub k: bool, pub params: usize, diff --git a/crates/kernel/src/whnf.rs b/crates/kernel/src/whnf.rs index e7b53ab0c..57f5cd9d8 100644 --- a/crates/kernel/src/whnf.rs +++ b/crates/kernel/src/whnf.rs @@ -5732,6 +5732,61 @@ mod tests { assert!(args[0].hash_eq(&a)); } + #[test] + fn whnf_quot_ind_reduces_and_preserves_suffix() { + // Quot.ind α r β f (Quot.mk α r a) extra → f a extra. + let mut env = quot_env(); + let mut tc = TypeChecker::new(&mut env); + + let alpha = AE::cnst(mk_id("α"), Box::new([])); + let r = AE::cnst(mk_id("r"), Box::new([])); + let beta = AE::cnst(mk_id("β"), Box::new([])); + let f = AE::cnst(mk_id("f"), Box::new([])); + let a = AE::cnst(mk_id("a"), Box::new([])); + let extra = AE::cnst(mk_id("extra"), Box::new([])); + let apps = |head: AE, args: &[AE]| args.iter().cloned().fold(head, AE::app); + + let mk = apps( + AE::cnst(tc.prims.quot_ctor.clone(), Box::new([])), + &[alpha.clone(), r.clone(), a.clone()], + ); + let ind = apps( + AE::cnst(tc.prims.quot_ind.clone(), Box::new([])), + &[alpha, r, beta, f.clone(), mk, extra.clone()], + ); + + let result = tc.whnf(&ind).unwrap(); + assert_eq!(result, AE::app(AE::app(f, a), extra)); + } + + #[test] + fn whnf_quot_stuck_on_overapplied_mk_major() { + // Lean recognizes `Quot.mk` at exact arity three. An extra argument on + // the major must not be mistaken for the represented quotient value. + let mut env = quot_env(); + let mut tc = TypeChecker::new(&mut env); + + let alpha = AE::cnst(mk_id("α"), Box::new([])); + let r = AE::cnst(mk_id("r"), Box::new([])); + let beta = AE::cnst(mk_id("β"), Box::new([])); + let f = AE::cnst(mk_id("f"), Box::new([])); + let h = AE::cnst(mk_id("h"), Box::new([])); + let a = AE::cnst(mk_id("a"), Box::new([])); + let extra = AE::cnst(mk_id("extra"), Box::new([])); + let apps = |head: AE, args: &[AE]| args.iter().cloned().fold(head, AE::app); + + let overapplied_mk = apps( + AE::cnst(tc.prims.quot_ctor.clone(), Box::new([])), + &[alpha.clone(), r.clone(), a, extra], + ); + let lift = apps( + AE::cnst(tc.prims.quot_lift.clone(), Box::new([])), + &[alpha, r, beta, f, h, overapplied_mk], + ); + + assert_eq!(tc.whnf(&lift).unwrap(), lift); + } + #[test] fn whnf_quot_lift_stuck_on_non_mk_major() { // Major is not Quot.mk → no reduction. diff --git a/lake-manifest.json b/lake-manifest.json index 33ee4a192..53d6469f5 100644 --- a/lake-manifest.json +++ b/lake-manifest.json @@ -1,14 +1,14 @@ {"version": "1.1.0", "packagesDir": ".lake/packages", "packages": - [{"url": "https://github.com/digama0/lean4lean", + [{"url": "https://github.com/argumentcomputer/lean4lean", "type": "git", "subDir": null, "scope": "", - "rev": "8865b155abbf68d3a827fb3568bf6839780163c2", + "rev": "5e5bb767b3491d21a71908d4c58bcbaa007283bb", "name": "lean4lean", "manifestFile": "lake-manifest.json", - "inputRev": "8865b155abbf68d3a827fb3568bf6839780163c2", + "inputRev": "5e5bb767b3491d21a71908d4c58bcbaa007283bb", "inherited": false, "configFile": "lakefile.toml"}, {"url": "https://github.com/leanprover-community/batteries", diff --git a/lakefile.lean b/lakefile.lean index aacb1f5ec..16d2690cb 100644 --- a/lakefile.lean +++ b/lakefile.lean @@ -16,12 +16,15 @@ require Cli from git require batteries from git "https://github.com/leanprover-community/batteries" @ "v4.29.0" -/- Test/bench-only dependency: the reference Lean4-in-Lean4 typechecker, -pinned to upstream master. Only `bench-lean4lean` and the ignored -`lean4lean` test runner import it, so `lake build ix` never builds it. -(Same toolchain and batteries pin as ix, so it resolves cleanly.) -/ +/- Reference Lean4-in-Lean4 theory and checker. `IxTcVerify` imports its +Theory/Verify specification surface, while `bench-lean4lean` and the ignored +`lean4lean` test runner exercise the implementation. The default `ix` target +still does not build this dependency. Pin the audited Argument fork exactly: +this revision replaces the inductive specification placeholders with the +staged checked/generation/certificate development integrated by Pin A in +`plans/tc-verify-execution-plan.md`. -/ require lean4lean from git - "https://github.com/digama0/lean4lean" @ "8865b155abbf68d3a827fb3568bf6839780163c2" + "https://github.com/argumentcomputer/lean4lean" @ "5e5bb767b3491d21a71908d4c58bcbaa007283bb" /-! ## FFI @@ -152,17 +155,54 @@ end Benchmarks section IxTcVerify +/-- Native-decide fixture proofs execute the same pinned Rust BLAKE3 backend +used by production address construction. Build a loadable form of that exact +backend for Lean's elaboration process. -/ +target blake3_rs_verify_cdylib : FilePath := do + let some blake3Pkg ← findPackageByName? `Blake3 + | error "Blake3 dependency package is unavailable" + proc { + cmd := "cargo" + args := #["rustc", "--release", "--", "--crate-type", "cdylib", + "-C", "extra-filename="] + cwd := blake3Pkg.dir / "rust" + } (quiet := true) + inputBinFile <| blake3Pkg.dir / "rust" / "target" / "release" / "deps" / + nameToSharedLib "blake3_rs" + +/-- Boxed-symbol adapter loaded by Lean while elaborating native-decide +proofs. Its dependency is the exact Rust cdylib above. -/ +target blake3_rs_verify_dynlib pkg : Dynlib := do + let source ← inputTextFile <| pkg.dir / "crates" / "ffi" / + "blake3_native_decide.c" + let leanIncludeDir ← getLeanIncludeDir + let object ← buildO + (pkg.buildDir / "blake3_native_decide.o") source + #["-fPIC", "-I", leanIncludeDir.toString] #[] "cc" getLeanTrace + let rustDynlib ← blake3_rs_verify_cdylib.fetch + -- Passing the cdylib as a link object records its concrete artifact path in + -- the adapter. Lean can therefore load it without relying on LD_LIBRARY_PATH. + buildSharedLib "blake3_native_decide_v4" + (pkg.buildDir / nameToSharedLib "blake3_native_decide_v4") + #[object, rustDynlib] #[] + /- Formal verification of `Ix.Tc` against the lean4lean `Theory` spec. Non-default: `lake build ix` never -touches it, and `build-all` (the lint driver) skips it by name while it -carries `sorry`s — `lake lint -- --wfail` would otherwise fail on the -WIP proof frontier. Required CI builds it separately without `--wfail`, +touches it, and `build-all` (the lint driver) skips it by name because its +pinned Lean4Lean dependencies still emit named `sorry` warnings — `lake lint +-- --wfail` would otherwise fail even though the Ix verification source has +no local `sorry` tokens. Required CI builds it separately without `--wfail`, audits the exact local sorry frontier, and checks exact per-root transitive axiom plus direct-`sorryAx`-origin manifests. Dev loop: `lake build IxTcVerify`; focused trust audit: `lake build Ix.Tc.Verify.Audit.Completed Ix.Tc.Verify.Audit.Statements`. -/ lean_lib IxTcVerify where globs := #[.submodules `Ix.Tc.Verify] + -- `supportInterpreter` is a `lean_exe` option and takes effect only when + -- that executable is linked, after its modules have been elaborated. + -- These native-decide proofs need the boxed FFI symbols while the library + -- modules are being elaborated, so they must be supplied as a dynlib. + dynlibs := #[blake3_rs_verify_dynlib] end IxTcVerify From e733ccbbcd0e43f9bbc4171f657fab61e58aaf15 Mon Sep 17 00:00:00 2001 From: "John C. Burnham" Date: Tue, 4 Aug 2026 09:13:38 -0400 Subject: [PATCH 2/2] kernel: fix Rust 1.92 clippy warnings --- crates/kernel/src/inductive.rs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/crates/kernel/src/inductive.rs b/crates/kernel/src/inductive.rs index a67a4bd0c..2d5e25fc9 100644 --- a/crates/kernel/src/inductive.rs +++ b/crates/kernel/src/inductive.rs @@ -61,8 +61,9 @@ fn checked_usize_to_u64( label: &str, value: usize, ) -> Result> { - u64::try_from(value) - .map_err(|_| TcError::Other(format!("{label} does not fit in u64"))) + u64::try_from(value).map_err(|error| { + TcError::Other(format!("{label} does not fit in u64: {error}")) + }) } /// A member of the "flat" mutual block used for recursor generation. @@ -2142,24 +2143,23 @@ peers={} flat={} rec_ids={} failed_gi={failed_gi}", /// inductive address: nested flattening keys auxiliaries by /// `(inductive, specialization)`, not by inductive address alone. fn positivity_group_matches( - &mut self, group: &PositivityGroup, family: &Address, us: &[KUniv], args: &[KExpr], n_params: usize, - ) -> Result> { + ) -> bool { let Some(expected_universes) = group.concrete_univs.as_deref() else { - return Ok(false); + return false; }; - Ok(same_nested_specialization( + same_nested_specialization( family, expected_universes, &group.params, family, us, &args[..n_params], - )) + ) } /// Check that a field domain doesn't have block inductives in negative position. @@ -2260,9 +2260,9 @@ peers={} flat={} rec_ids={} failed_gi={failed_gi}", .cloned() .collect(); for group in &existing_groups { - if self.positivity_group_matches( + if Self::positivity_group_matches( group, &id.addr, us, &args, n_params, - )? { + ) { for index in args.iter().skip(n_params) { if expr_mentions_any_addr(index, root_addrs) { return Err(TcError::Other(