From 0ccf535fff90bd4cce7b1b6b5535eb583caea725 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Mon, 19 Oct 2026 16:24:39 +0000 Subject: [PATCH 1/5] Import pointwise provable equality and failure of composition --- LeanPool/PointwiseComposition.lean | 51 + .../ArithmeticCode/Arithmetic.lean | 304 ++ .../ArithmeticCode/Basic.lean | 246 ++ .../ArithmeticCode/BetaCoding.lean | 554 ++++ .../ArithmeticCode/Conditional.lean | 77 + .../ArithmeticCode/EncodedList.lean | 136 + .../ArithmeticCode/EncodedListEvaluation.lean | 499 +++ .../ArithmeticCode/Evaluation.lean | 492 +++ .../ArithmeticCode/EvaluationCongruence.lean | 629 ++++ .../ArithmeticCode/FoundationCompat.lean | 116 + .../ArithmeticCode/Minimization.lean | 107 + .../ArithmeticCode/NumeralEvaluation.lean | 1170 +++++++ .../ArithmeticCode/Pairing.lean | 45 + .../ArithmeticCode/PartialRecursive.lean | 135 + .../PartialRecursiveEvaluation.lean | 135 + .../ArithmeticCode/Recursion.lean | 276 ++ .../ArithmeticCode/RecursionEvaluation.lean | 1974 ++++++++++++ .../Evaluator/Cell.lean | 118 + .../Evaluator/CellCongruence.lean | 607 ++++ .../Evaluator/CellEvaluation.lean | 508 +++ .../Evaluator/Certificate.lean | 383 +++ .../Evaluator/CompositionDispatch.lean | 632 ++++ .../Evaluator/CompositionPersistence.lean | 139 + .../Evaluator/History.lean | 98 + .../Evaluator/HistoryEvaluation.lean | 2860 +++++++++++++++++ .../Evaluator/PairPersistence.lean | 389 +++ .../Evaluator/PersistenceInduction.lean | 172 + .../PrimitiveRecursionPersistence.lean | 1026 ++++++ .../PrimitiveRecursionStructuralBridges.lean | 512 +++ .../Evaluator/TableLookup.lean | 67 + .../Evaluator/TableLookupEvaluation.lean | 128 + .../CanonicalComposition.lean | 227 ++ .../ArithmeticCodeCompiler.lean | 290 ++ .../ArithmeticFormulaAtoms.lean | 189 ++ .../ArithmeticProgramOperations.lean | 309 ++ .../AxiomEnumeration.lean | 62 + .../BoundedSemidecision.lean | 156 + .../CompositionClosure.lean | 111 + .../ComputationSearchIndices.lean | 138 + .../ConcreteAdequacy.lean | 248 ++ .../ConcreteConstructorGraphs.lean | 444 +++ .../ConcreteDiagonal.lean | 179 ++ .../ConcreteEmptyGraph.lean | 133 + .../ConcreteEvaluatorGraph.lean | 175 + .../ConcreteGeneratedCongruence.lean | 109 + .../FailureOfComposition/ConcreteGodel.lean | 106 + .../FailureOfComposition/ConcreteGodelRE.lean | 63 + .../ConcreteIndexObstruction.lean | 187 ++ .../ConcreteMinimizationGraph.lean | 318 ++ .../ConcretePersistence.lean | 86 + .../ConcretePiOneCharacterization.lean | 98 + .../ConcreteRecursionGraph.lean | 764 +++++ .../ConcreteWeakTotality.lean | 201 ++ .../ConcreteWitnessGraphs.lean | 277 ++ .../CraigPresentation.lean | 266 ++ .../GeneratedClassification.lean | 80 + .../GeneratedCollapse.lean | 164 + .../GeneratedExtensionality.lean | 98 + .../GeneratedGraphDefinitions.lean | 79 + .../GeneratedIndexClassification.lean | 106 + .../GeneratedIndexQuotient.lean | 171 + .../GeneratedIndexTransport.lean | 151 + .../GeneratedQuotient.lean | 108 + .../GeneratedSoundness.lean | 88 + .../GeneratedWitnessGraphs.lean | 323 ++ .../GeneratedWitnessPointwise.lean | 130 + .../FailureOfComposition/GodelGraph.lean | 75 + .../FailureOfComposition/GraphQuotient.lean | 128 + .../HistoryObstruction.lean | 162 + .../HistoryWitnesses.lean | 232 ++ .../KleeneNormalForm.lean | 142 + .../ManuscriptObstruction.lean | 343 ++ .../MinimizationPersistence.lean | 472 +++ .../PartialRecursiveQuotient.lean | 145 + .../PiOneCharacterization.lean | 97 + .../FailureOfComposition/PiOneCongruence.lean | 92 + .../PiOneDefinitions.lean | 62 + .../PiOneExtensionality.lean | 188 ++ .../PiOneIndexCharacterization.lean | 226 ++ .../FailureOfComposition/PiOneNecessity.lean | 75 + .../ProductiveDivergence.lean | 129 + .../FailureOfComposition/ProductiveGraph.lean | 99 + .../FailureOfComposition/Productiveness.lean | 70 + .../FailureOfComposition/ProgramGraph.lean | 111 + .../FailureOfComposition/ProgramIndices.lean | 218 ++ .../ProofSearchTemplate.lean | 302 ++ .../QuotientComposition.lean | 54 + .../QuotientObstruction.lean | 76 + .../FailureOfComposition/RangeAssignment.lean | 161 + .../FailureOfComposition/RangeGodel.lean | 156 + .../FailureOfComposition/RangeProductive.lean | 134 + .../FailureOfComposition/RangeWitness.lean | 182 ++ .../SigmaOneGraphWitness.lean | 91 + .../SigmaOneRealization.lean | 178 + .../FailureOfComposition/SigmaOneSearch.lean | 363 +++ .../SigmaOneSemidecisionCore.lean | 82 + .../TheoryEnumerability.lean | 226 ++ .../FirstOrder/Arithmetic/Basic.lean | 22 + .../Arithmetic/Basic/Hierarchy.lean | 615 ++++ .../FirstOrder/Arithmetic/Basic/Misc.lean | 275 ++ .../FirstOrder/Arithmetic/Basic/Model.lean | 165 + .../FirstOrder/Arithmetic/Basic/Monotone.lean | 51 + .../Arithmetic/Basic/StrictHierarchy.lean | 160 + .../DerivabilityCondition/D1.lean | 71 + .../DerivabilityCondition/D2.lean | 65 + .../DerivabilityCondition/D3.lean | 207 ++ .../EquationalTheory.lean | 583 ++++ .../DerivabilityCondition/PeanoMinus.lean | 327 ++ .../Arithmetic/Bootstrapping/FixedPoint.lean | 316 ++ .../Arithmetic/Bootstrapping/Syntax.lean | 31 + .../Bootstrapping/Syntax/CraigTrick.lean | 433 +++ .../Bootstrapping/Syntax/Formula/Basic.lean | 1906 +++++++++++ .../Bootstrapping/Syntax/Formula/Coding.lean | 524 +++ .../Syntax/Formula/Functions.lean | 1527 +++++++++ .../Syntax/Formula/Iteration.lean | 560 ++++ .../Bootstrapping/Syntax/Formula/Typed.lean | 706 ++++ .../Bootstrapping/Syntax/Language.lean | 323 ++ .../Bootstrapping/Syntax/Proof/Basic.lean | 1218 +++++++ .../Bootstrapping/Syntax/Proof/Coding.lean | 520 +++ .../Bootstrapping/Syntax/Proof/Typed.lean | 844 +++++ .../Bootstrapping/Syntax/Term/Basic.lean | 1236 +++++++ .../Bootstrapping/Syntax/Term/Coding.lean | 346 ++ .../Bootstrapping/Syntax/Term/Functions.lean | 1108 +++++++ .../Bootstrapping/Syntax/Term/Typed.lean | 565 ++++ .../Bootstrapping/Syntax/Theory.lean | 226 ++ .../Arithmetic/BoundedCollection.lean | 125 + .../FirstOrder/Arithmetic/Definability.lean | 21 + .../Arithmetic/Definability/Absoluteness.lean | 147 + .../Definability/BoundedDefinable.lean | 521 +++ .../Arithmetic/Definability/Definable.lean | 1144 +++++++ .../Arithmetic/Definability/Hierarchy.lean | 608 ++++ .../FirstOrder/Arithmetic/Exponential.lean | 22 + .../Arithmetic/Exponential/Bit.lean | 816 +++++ .../Arithmetic/Exponential/Exp.lean | 979 ++++++ .../Arithmetic/Exponential/Log.lean | 650 ++++ .../Arithmetic/Exponential/PPow2.lean | 406 +++ .../Arithmetic/Exponential/Pow2.lean | 510 +++ .../Foundation/FirstOrder/Arithmetic/HFS.lean | 23 + .../FirstOrder/Arithmetic/HFS/Basic.lean | 919 ++++++ .../FirstOrder/Arithmetic/HFS/Coding.lean | 68 + .../FirstOrder/Arithmetic/HFS/Fixpoint.lean | 360 +++ .../FirstOrder/Arithmetic/HFS/PRF.lean | 290 ++ .../FirstOrder/Arithmetic/HFS/Seq.lean | 556 ++++ .../FirstOrder/Arithmetic/HFS/Vec.lean | 1390 ++++++++ .../FirstOrder/Arithmetic/IOpen/Basic.lean | 1089 +++++++ .../FirstOrder/Arithmetic/ISigma1/Prenex.lean | 62 + .../FirstOrder/Arithmetic/Induction.lean | 326 ++ .../Foundation/FirstOrder/Arithmetic/LE.lean | 66 + .../Arithmetic/PeanoMinus/Basic.lean | 748 +++++ .../Arithmetic/PeanoMinus/Functions.lean | 356 ++ .../FirstOrder/Arithmetic/Prenex.lean | 802 +++++ .../FirstOrder/Arithmetic/Q/Basic.lean | 342 ++ .../FirstOrder/Arithmetic/R0/Basic.lean | 322 ++ .../Arithmetic/R0/Representation.lean | 623 ++++ .../FirstOrder/Arithmetic/Schemata.lean | 593 ++++ .../FirstOrder/Arithmetic/TA/Basic.lean | 53 + .../Incompleteness/Consistency.lean | 145 + .../Incompleteness/Definability.lean | 1343 ++++++++ .../FirstOrder/Incompleteness/First.lean | 100 + .../ProvabilityAbstraction/Basic.lean | 403 +++ .../Incompleteness/RosserProvability.lean | 212 ++ .../FirstOrder/Incompleteness/Second.lean | 66 + .../Incompleteness/StandardProvability.lean | 144 + .../Incompleteness/WitnessComparison.lean | 170 + .../Foundation/FirstOrder/LJ/Basic.lean | 548 ++++ .../FirstOrder/LJ/GoedelGentzen.lean | 264 ++ .../Foundation/FirstOrder/LJ/Head.lean | 83 + .../Foundation/FirstOrder/LK/Basic.lean | 651 ++++ .../FirstOrder/LK/Completeness.lean | 20 + .../LK/Completeness/CanonicalModel.lean | 261 ++ .../LK/Completeness/CountableSublanguage.lean | 323 ++ .../LK/Completeness/CounterModel.lean | 379 +++ .../Foundation/FirstOrder/LK/CutFree.lean | 183 ++ .../Foundation/FirstOrder/LK/Eq.lean | 121 + .../Foundation/FirstOrder/LK/Hauptsatz.lean | 561 ++++ .../Foundation/FirstOrder/LK/Simplified.lean | 258 ++ .../Foundation/FirstOrder/LK/Soundness.lean | 163 + .../Syntax/Classical/BinderNotation.lean | 1184 +++++++ .../Syntax/Classical/BinderSemantics.lean | 212 ++ .../FirstOrder/Syntax/Classical/Coding.lean | 279 ++ .../FirstOrder/Syntax/Classical/Eq.lean | 164 + .../FirstOrder/Syntax/Classical/Formula.lean | 861 +++++ .../FirstOrder/Syntax/Classical/Operator.lean | 743 +++++ .../FirstOrder/Syntax/Classical/Padding.lean | 101 + .../Syntax/Classical/PrimrecCoding.lean | 1081 +++++++ .../FirstOrder/Syntax/Classical/Rew.lean | 709 ++++ .../Syntax/Intuitionistic/Formula.lean | 421 +++ .../FirstOrder/Syntax/Intuitionistic/Rew.lean | 149 + .../FirstOrder/Tarski/AesopInit.lean | 21 + .../Foundation/FirstOrder/Tarski/Basic.lean | 871 +++++ .../FirstOrder/Tarski/Definability.lean | 670 ++++ .../FirstOrder/Tarski/Elementary.lean | 383 +++ .../Foundation/FirstOrder/Tarski/Eq.lean | 294 ++ .../Foundation/FirstOrder/Tarski/Model.lean | 271 ++ .../FirstOrder/Tarski/Operator.lean | 261 ++ .../FirstOrder/Tarski/Ultraproduct.lean | 229 ++ .../Foundation/Logic/Calculus.lean | 472 +++ .../Foundation/Logic/Entailment.lean | 785 +++++ .../Foundation/Logic/ForcingRelation.lean | 207 ++ .../Foundation/Logic/LogicSymbol.lean | 1122 +++++++ .../Foundation/Logic/Semantics.lean | 424 +++ .../Foundation/Meta/ClProver.lean | 509 +++ .../Foundation/Meta/ClProverTheorems.lean | 127 + .../Foundation/Meta/Lit.lean | 189 ++ .../Foundation/Meta/Qq.lean | 88 + .../Foundation/Meta/TwoSided.lean | 473 +++ .../Propositional/Entailment/Cl.lean | 433 +++ .../Propositional/Entailment/Int.lean | 510 +++ .../Propositional/Entailment/Minimal.lean | 2012 ++++++++++++ .../Foundation/Syntax/Predicate/Language.lean | 583 ++++ .../Syntax/Predicate/Quantifier.lean | 487 +++ .../Foundation/Syntax/Predicate/Rew.lean | 1445 +++++++++ .../Foundation/Syntax/Predicate/Term.lean | 345 ++ .../Foundation/Vorspiel/AdjunctiveSet.lean | 180 ++ .../Foundation/Vorspiel/Arithmetic.lean | 811 +++++ .../Foundation/Vorspiel/Computability.lean | 325 ++ .../Foundation/Vorspiel/Empty.lean | 31 + .../Foundation/Vorspiel/ExistsUnique.lean | 78 + .../Foundation/Vorspiel/Fin/Basic.lean | 141 + .../Foundation/Vorspiel/Fin/Matrix.lean | 66 + .../Foundation/Vorspiel/Finset/Basic.lean | 106 + .../Foundation/Vorspiel/Finset/Card.lean | 44 + .../Foundation/Vorspiel/Function.lean | 37 + .../Foundation/Vorspiel/Graph.lean | 75 + .../Foundation/Vorspiel/IsEmpty.lean | 34 + .../Foundation/Vorspiel/List/Basic.lean | 361 +++ .../Foundation/Vorspiel/Matrix.lean | 468 +++ .../Foundation/Vorspiel/Multiset.lean | 231 ++ .../Foundation/Vorspiel/Nat/Basic.lean | 96 + .../Foundation/Vorspiel/Nat/Matrix.lean | 113 + .../Foundation/Vorspiel/NotationClass.lean | 203 ++ .../Foundation/Vorspiel/Option.lean | 68 + .../Foundation/Vorspiel/Order/Dense.lean | 229 ++ .../Foundation/Vorspiel/Part.lean | 49 + .../Foundation/Vorspiel/Quotient.lean | 77 + .../Foundation/Vorspiel/String.lean | 27 + LeanPool/PointwiseComposition/Imports.lean | 244 ++ .../pointwise-provable-composition.yaml | 72 + 238 files changed, 85836 insertions(+) create mode 100644 LeanPool/PointwiseComposition.lean create mode 100644 LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/Arithmetic.lean create mode 100644 LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/Basic.lean create mode 100644 LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/BetaCoding.lean create mode 100644 LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/Conditional.lean create mode 100644 LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/EncodedList.lean create mode 100644 LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/EncodedListEvaluation.lean create mode 100644 LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/Evaluation.lean create mode 100644 LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/EvaluationCongruence.lean create mode 100644 LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/FoundationCompat.lean create mode 100644 LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/Minimization.lean create mode 100644 LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/NumeralEvaluation.lean create mode 100644 LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/Pairing.lean create mode 100644 LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/PartialRecursive.lean create mode 100644 LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/PartialRecursiveEvaluation.lean create mode 100644 LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/Recursion.lean create mode 100644 LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/RecursionEvaluation.lean create mode 100644 LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/Cell.lean create mode 100644 LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/CellCongruence.lean create mode 100644 LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/CellEvaluation.lean create mode 100644 LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/Certificate.lean create mode 100644 LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/CompositionDispatch.lean create mode 100644 LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/CompositionPersistence.lean create mode 100644 LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/History.lean create mode 100644 LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/HistoryEvaluation.lean create mode 100644 LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/PairPersistence.lean create mode 100644 LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/PersistenceInduction.lean create mode 100644 LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/PrimitiveRecursionPersistence.lean create mode 100644 LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/PrimitiveRecursionStructuralBridges.lean create mode 100644 LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/TableLookup.lean create mode 100644 LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/TableLookupEvaluation.lean create mode 100644 LeanPool/PointwiseComposition/CategoricalRiceShapiro/PartialRecursive/CanonicalComposition.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/ArithmeticCodeCompiler.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/ArithmeticFormulaAtoms.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/ArithmeticProgramOperations.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/AxiomEnumeration.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/BoundedSemidecision.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/CompositionClosure.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/ComputationSearchIndices.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/ConcreteAdequacy.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/ConcreteConstructorGraphs.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/ConcreteDiagonal.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/ConcreteEmptyGraph.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/ConcreteEvaluatorGraph.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/ConcreteGeneratedCongruence.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/ConcreteGodel.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/ConcreteGodelRE.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/ConcreteIndexObstruction.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/ConcreteMinimizationGraph.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/ConcretePersistence.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/ConcretePiOneCharacterization.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/ConcreteRecursionGraph.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/ConcreteWeakTotality.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/ConcreteWitnessGraphs.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/CraigPresentation.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/GeneratedClassification.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/GeneratedCollapse.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/GeneratedExtensionality.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/GeneratedGraphDefinitions.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/GeneratedIndexClassification.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/GeneratedIndexQuotient.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/GeneratedIndexTransport.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/GeneratedQuotient.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/GeneratedSoundness.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/GeneratedWitnessGraphs.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/GeneratedWitnessPointwise.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/GodelGraph.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/GraphQuotient.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/HistoryObstruction.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/HistoryWitnesses.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/KleeneNormalForm.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/ManuscriptObstruction.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/MinimizationPersistence.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/PartialRecursiveQuotient.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/PiOneCharacterization.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/PiOneCongruence.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/PiOneDefinitions.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/PiOneExtensionality.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/PiOneIndexCharacterization.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/PiOneNecessity.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/ProductiveDivergence.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/ProductiveGraph.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/Productiveness.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/ProgramGraph.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/ProgramIndices.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/ProofSearchTemplate.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/QuotientComposition.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/QuotientObstruction.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/RangeAssignment.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/RangeGodel.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/RangeProductive.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/RangeWitness.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/SigmaOneGraphWitness.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/SigmaOneRealization.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/SigmaOneSearch.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/SigmaOneSemidecisionCore.lean create mode 100644 LeanPool/PointwiseComposition/FailureOfComposition/TheoryEnumerability.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Basic.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Basic/Hierarchy.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Basic/Misc.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Basic/Model.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Basic/Monotone.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Basic/StrictHierarchy.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/DerivabilityCondition/D1.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/DerivabilityCondition/D2.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/DerivabilityCondition/D3.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/DerivabilityCondition/EquationalTheory.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/DerivabilityCondition/PeanoMinus.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/FixedPoint.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/CraigTrick.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Formula/Basic.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Formula/Coding.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Formula/Functions.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Formula/Iteration.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Formula/Typed.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Language.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Proof/Basic.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Proof/Coding.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Proof/Typed.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Term/Basic.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Term/Coding.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Term/Functions.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Term/Typed.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Theory.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/BoundedCollection.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Definability.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Definability/Absoluteness.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Definability/BoundedDefinable.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Definability/Definable.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Definability/Hierarchy.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Exponential.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Exponential/Bit.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Exponential/Exp.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Exponential/Log.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Exponential/PPow2.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Exponential/Pow2.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/HFS.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/HFS/Basic.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/HFS/Coding.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/HFS/Fixpoint.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/HFS/PRF.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/HFS/Seq.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/HFS/Vec.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/IOpen/Basic.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/ISigma1/Prenex.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Induction.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/LE.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/PeanoMinus/Basic.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/PeanoMinus/Functions.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Prenex.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Q/Basic.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/R0/Basic.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/R0/Representation.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Schemata.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/TA/Basic.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Incompleteness/Consistency.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Incompleteness/Definability.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Incompleteness/First.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Incompleteness/ProvabilityAbstraction/Basic.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Incompleteness/RosserProvability.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Incompleteness/Second.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Incompleteness/StandardProvability.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Incompleteness/WitnessComparison.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/LJ/Basic.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/LJ/GoedelGentzen.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/LJ/Head.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/Basic.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/Completeness.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/Completeness/CanonicalModel.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/Completeness/CountableSublanguage.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/Completeness/CounterModel.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/CutFree.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/Eq.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/Hauptsatz.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/Simplified.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/Soundness.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Classical/BinderNotation.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Classical/BinderSemantics.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Classical/Coding.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Classical/Eq.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Classical/Formula.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Classical/Operator.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Classical/Padding.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Classical/PrimrecCoding.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Classical/Rew.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Intuitionistic/Formula.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Intuitionistic/Rew.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Tarski/AesopInit.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Tarski/Basic.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Tarski/Definability.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Tarski/Elementary.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Tarski/Eq.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Tarski/Model.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Tarski/Operator.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/FirstOrder/Tarski/Ultraproduct.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/Logic/Calculus.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/Logic/Entailment.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/Logic/ForcingRelation.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/Logic/LogicSymbol.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/Logic/Semantics.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/Meta/ClProver.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/Meta/ClProverTheorems.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/Meta/Lit.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/Meta/Qq.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/Meta/TwoSided.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/Propositional/Entailment/Cl.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/Propositional/Entailment/Int.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/Propositional/Entailment/Minimal.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/Syntax/Predicate/Language.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/Syntax/Predicate/Quantifier.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/Syntax/Predicate/Rew.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/Syntax/Predicate/Term.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/Vorspiel/AdjunctiveSet.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/Vorspiel/Arithmetic.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/Vorspiel/Computability.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/Vorspiel/Empty.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/Vorspiel/ExistsUnique.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/Vorspiel/Fin/Basic.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/Vorspiel/Fin/Matrix.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/Vorspiel/Finset/Basic.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/Vorspiel/Finset/Card.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/Vorspiel/Function.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/Vorspiel/Graph.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/Vorspiel/IsEmpty.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/Vorspiel/List/Basic.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/Vorspiel/Matrix.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/Vorspiel/Multiset.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/Vorspiel/Nat/Basic.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/Vorspiel/Nat/Matrix.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/Vorspiel/NotationClass.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/Vorspiel/Option.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/Vorspiel/Order/Dense.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/Vorspiel/Part.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/Vorspiel/Quotient.lean create mode 100644 LeanPool/PointwiseComposition/Foundation/Vorspiel/String.lean create mode 100644 LeanPool/PointwiseComposition/Imports.lean create mode 100644 LeanPool/projects/pointwise-provable-composition.yaml diff --git a/LeanPool/PointwiseComposition.lean b/LeanPool/PointwiseComposition.lean new file mode 100644 index 000000000..0bba57727 --- /dev/null +++ b/LeanPool/PointwiseComposition.lean @@ -0,0 +1,51 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ + +module + +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteIndexObstruction +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteGodelRE +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcretePiOneCharacterization +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteGeneratedCongruence +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteWeakTotality +public import LeanPool.PointwiseComposition.FailureOfComposition.RangeGodel +public import LeanPool.PointwiseComposition.FailureOfComposition.RangeProductive +public import LeanPool.PointwiseComposition.FailureOfComposition.PartialRecursiveQuotient +public import LeanPool.PointwiseComposition.FailureOfComposition.ManuscriptObstruction + +/-! +# Pointwise provable equality and the failure of composition + +Source: arxiv:2609.25556, url:https://github.com/flengyel/FailureOfComposition +Authors: Florian Lengyel +Status: verified +Main declarations: `PointwiseComposition.no_quotient_of_enumerable_axioms` +Tags: computability, provability, first-order-arithmetic, quotient-congruences, mathematical-logic +MSC: 03D75, 03F40, 08A30, 18B10 +-/ + +/-! +# Pointwise provable equality and the failure of composition + +Ported from Florian Lengyel’s Apache-2.0 formalization at +`506d1f1494d6c05b0ba304edf5fe0bfa6c32864b`. The dependency closure includes the +Formalized Formal Logic Foundation arithmetic library at +`01f617fbe240a84aaf1c45b31b9d65e0a2e21c1d` (Apache-2.0), whose contributors +retain authorship of that infrastructure. The Foundation license notice is +"Copyright 2026 Formalized Formal Logic". Lean proofs in the main development +were produced by AI agents under Florian Lengyel’s direction. +-/ + +@[expose] public section + +namespace PointwiseComposition + +/-- No quotient operation respects program composition for a consistent extension of PA +whose axiom codes are recursively enumerable. -/ +alias no_quotient_of_enumerable_axioms := + FailureOfComposition.ConcreteIndices.no_index_quotient_of_re_axioms + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/Arithmetic.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/Arithmetic.lean new file mode 100644 index 000000000..bbaf23a18 --- /dev/null +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/Arithmetic.lean @@ -0,0 +1,304 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.Minimization +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.Conditional + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# Arithmetic operations obtained by minimization + +Truncated subtraction, integer square root, the two components of Cantor +unpairing, divisibility, remainder, and the Gödel beta function, each defined +by minimizing an arithmetic condition. + +Each construction is accompanied by the theorem that it realizes the intended +function over the natural numbers. Those `Computes` theorems are the input of +the standard-model bridge, which turns a computation over `ℕ` into evaluation at +standard numerals in an arbitrary model. +-/ + +@[expose] public section + +open _root_.Nat Nat Nat.ArithPart₁ + +namespace CategoricalRiceShapiro +namespace ArithmeticCode + +/-- Truncated subtraction `d₀ - d₁`: the least `x` with `x + d₁ = d₀`, or +`0` when `d₀ < d₁`. -/ +def codeSub {n : ℕ} (d₀ d₁ : Code n) : Code n := + codeRfindPos + (codeOr (codeEq (codeAdd codeHead (codeLift d₁)) (codeLift d₀)) + (codeAnd (codeLt (codeLift d₀) (codeLift d₁)) (codeEq codeHead (Code.zero _)))) + +/-- The integer square root of `d`: the least `x` with `x * x ≤ d < (x+1) * (x+1)`. -/ +def codeSqrt {n : ℕ} (d : Code n) : Code n := + codeRfindPos + (codeAnd + (codeOr (codeLt (codeMul codeHead codeHead) (codeLift d)) + (codeEq (codeMul codeHead codeHead) (codeLift d))) + (codeLt (codeLift d) (codeMul (codeSucc codeHead) (codeSucc codeHead)))) + +/-- The first component of Cantor unpairing. -/ +def codeUnpair₁ {n : ℕ} (d : Code n) : Code n := + codeIfPos (codeLt (codeSub d (codeMul (codeSqrt d) (codeSqrt d))) (codeSqrt d)) + (codeSub d (codeMul (codeSqrt d) (codeSqrt d))) (codeSqrt d) + +/-- The second component of Cantor unpairing. -/ +def codeUnpair₂ {n : ℕ} (d : Code n) : Code n := + codeIfPos (codeLt (codeSub d (codeMul (codeSqrt d) (codeSqrt d))) (codeSqrt d)) (codeSqrt d) + (codeSub (codeSub d (codeMul (codeSqrt d) (codeSqrt d))) (codeSqrt d)) + +/-- The characteristic value of `d₀ ∣ d₁`, decided by minimizing a quotient +bounded by `d₁`. -/ +def codeDvd {n : ℕ} (d₀ d₁ : Code n) : Code n := + codeBind + (codeRfindPos + (codeOr (codeEq (codeMul codeHead (codeLift d₀)) (codeLift d₁)) + (codeLt (codeLift d₁) codeHead))) + (codeLe codeHead (codeLift d₁)) + +/-- The remainder of `d₀` on division by `d₁`. -/ +def codeRem {n : ℕ} (d₀ d₁ : Code n) : Code n := + codeRfindPos (codeDvd (codeLift d₁) (codeSub (codeLift d₀) codeHead)) + +/-- The Gödel beta function: the `di`-th entry of the sequence coded by `dn`. -/ +def codeBeta {n : ℕ} (dn di : Code n) : Code n := + codeRem (codeUnpair₁ dn) (codeSucc (codeMul (codeSucc di) (codeUnpair₂ dn))) + +/-! +### Standard computations over the natural numbers -/ + +theorem computes_codeSub {n : ℕ} {d₀ d₁ : Code n} {g₀ g₁ : List.Vector ℕ n → ℕ} + (h₀ : Computes d₀ g₀) (h₁ : Computes d₁ g₁) : + Computes (codeSub d₀ d₁) (fun v => g₀ v - g₁ v) := + by + have hF : + Computes + (codeOr (codeEq (codeAdd codeHead (codeLift d₁)) (codeLift d₀)) + (codeAnd (codeLt (codeLift d₀) (codeLift d₁)) (codeEq codeHead (Code.zero _)))) + (fun w => + Nat.or (isEqNat (w.head + g₁ w.tail) (g₀ w.tail)) + (Nat.and (isLtNat (g₀ w.tail) (g₁ w.tail)) (isEqNat w.head 0))) := + computes_codeOr + (computes_codeEq (computes_codeAdd computes_codeHead (computes_codeLift h₁)) + (computes_codeLift h₀)) + (computes_codeAnd (computes_codeLt (computes_codeLift h₀) (computes_codeLift h₁)) + (computes_codeEq computes_codeHead computes_zero)) + have h := eval_codeRfindPos hF + refine eval_of_eq h ?_ + funext v + have key : + ∀ m : ℕ, + (0 < Nat.or (isEqNat (m + g₁ v) (g₀ v)) (Nat.and (isLtNat (g₀ v) (g₁ v)) (isEqNat m 0))) ↔ + (m + g₁ v = g₀ v ∨ (g₀ v < g₁ v ∧ m = 0)) := + by + intro m + simp [Nat.orNat_pos_iff, Nat.and_pos_iff, isEqNat_pos_iff, isLtNat_pos_iff] + simp only [List.Vector.head_cons, List.Vector.tail_cons, Part.coe_some] + rw [Part.eq_some_iff] + refine Nat.mem_rfind.mpr ?_ + constructor + · rw [Part.mem_some_iff, eq_comm, decide_eq_true_eq, key] + omega + · intro m hm + rw [Part.mem_some_iff, eq_comm, decide_eq_false_iff_not, key] + omega + +theorem computes_codeSqrt {n : ℕ} {d : Code n} {g : List.Vector ℕ n → ℕ} (hd : Computes d g) : + Computes (codeSqrt d) (fun v => Nat.sqrt (g v)) := + by + have hF : + Computes + (codeAnd + (codeOr (codeLt (codeMul codeHead codeHead) (codeLift d)) + (codeEq (codeMul codeHead codeHead) (codeLift d))) + (codeLt (codeLift d) (codeMul (codeSucc codeHead) (codeSucc codeHead)))) + (fun w => + Nat.and + (Nat.or (isLtNat (w.head * w.head) (g w.tail)) (isEqNat (w.head * w.head) (g w.tail))) + (isLtNat (g w.tail) ((w.head + 1) * (w.head + 1)))) := + computes_codeAnd + (computes_codeOr + (computes_codeLt (computes_codeMul computes_codeHead computes_codeHead) + (computes_codeLift hd)) + (computes_codeEq (computes_codeMul computes_codeHead computes_codeHead) + (computes_codeLift hd))) + (computes_codeLt (computes_codeLift hd) + (computes_codeMul (computes_codeSucc computes_codeHead) + (computes_codeSucc computes_codeHead))) + have h := eval_codeRfindPos hF + refine eval_of_eq h ?_ + funext v + have key : + ∀ m : ℕ, + (0 < + Nat.and (Nat.or (isLtNat (m * m) (g v)) (isEqNat (m * m) (g v))) + (isLtNat (g v) ((m + 1) * (m + 1)))) ↔ + (m * m ≤ g v ∧ g v < (m + 1) * (m + 1)) := + by + intro m + simp only [Nat.and_pos_iff, Nat.orNat_pos_iff, isLtNat_pos_iff, isEqNat_pos_iff] + omega + simp only [List.Vector.head_cons, List.Vector.tail_cons, Part.coe_some] + rw [Part.eq_some_iff] + refine Nat.mem_rfind.mpr ?_ + constructor + · rw [Part.mem_some_iff, eq_comm, decide_eq_true_eq, key] + refine ⟨?_, ?_⟩ + · simpa [pow_two] using Nat.sqrt_le' (g v) + · simpa [pow_two] using Nat.lt_succ_sqrt' (g v) + · intro m hm + rw [Part.mem_some_iff, eq_comm, decide_eq_false_iff_not, key] + rintro ⟨-, hlt⟩ + have : (m + 1) * (m + 1) ≤ g v := by simpa [pow_two] using Nat.le_sqrt'.mp hm + omega + +theorem computes_codeUnpair₁ {n : ℕ} {d : Code n} {g : List.Vector ℕ n → ℕ} + (hd : Computes d g) : Computes (codeUnpair₁ d) (fun v => (g v).unpair.1) := + by + have hs := computes_codeSqrt hd + refine + (computes_codeIfPos (computes_codeLt (computes_codeSub hd (computes_codeMul hs hs)) hs) + (computes_codeSub hd (computes_codeMul hs hs)) hs).of_eq + ?_ + intro v + by_cases hlt : g v - (g v).sqrt * (g v).sqrt < (g v).sqrt <;> simp [Nat.unpair, isLtNat, hlt] + +theorem computes_codeUnpair₂ {n : ℕ} {d : Code n} {g : List.Vector ℕ n → ℕ} + (hd : Computes d g) : Computes (codeUnpair₂ d) (fun v => (g v).unpair.2) := + by + have hs := computes_codeSqrt hd + refine + (computes_codeIfPos (computes_codeLt (computes_codeSub hd (computes_codeMul hs hs)) hs) hs + (computes_codeSub (computes_codeSub hd (computes_codeMul hs hs)) hs)).of_eq + ?_ + intro v + by_cases hlt : g v - (g v).sqrt * (g v).sqrt < (g v).sqrt <;> simp [Nat.unpair, isLtNat, hlt] + +theorem computes_codeDvd {n : ℕ} {d₀ d₁ : Code n} {g₀ g₁ : List.Vector ℕ n → ℕ} + (h₀ : Computes d₀ g₀) (h₁ : Computes d₁ g₁) : + Computes (codeDvd d₀ d₁) (fun v => isDvdNat (g₀ v) (g₁ v)) := + by + have hF : + Computes + (codeOr (codeEq (codeMul codeHead (codeLift d₀)) (codeLift d₁)) + (codeLt (codeLift d₁) codeHead)) + (fun w => + Nat.or (isEqNat (w.head * g₀ w.tail) (g₁ w.tail)) (isLtNat (g₁ w.tail) w.head)) := + computes_codeOr + (computes_codeEq (computes_codeMul computes_codeHead (computes_codeLift h₀)) + (computes_codeLift h₁)) + (computes_codeLt (computes_codeLift h₁) computes_codeHead) + have hb := + eval_codeBind (eval_codeRfindPos hF) + (computes_codeLe computes_codeHead (computes_codeLift h₁)) + refine eval_of_eq hb ?_ + funext v + have key : + ∀ m : ℕ, + (0 < Nat.or (isEqNat (m * g₀ v) (g₁ v)) (isLtNat (g₁ v) m)) ↔ + (m * g₀ v = g₁ v ∨ g₁ v < m) := + by intro m; simp only [Nat.orNat_pos_iff, isEqNat_pos_iff, isLtNat_pos_iff] + simp only [List.Vector.head_cons, List.Vector.tail_cons, Part.coe_some] + rw [Part.eq_some_iff, Part.mem_bind_iff] + by_cases hv : g₀ v ∣ g₁ v + · obtain ⟨k, hk, hkm⟩ : ∃ k, k * g₀ v = g₁ v ∧ ∀ m, m < k → m * g₀ v ≠ g₁ v := + by + obtain ⟨c, hc⟩ := hv + have hex : ∃ k, k * g₀ v = g₁ v := ⟨c, by rw [hc, Nat.mul_comm]⟩ + exact ⟨Nat.find hex, Nat.find_spec hex, fun m hm => Nat.find_min hex hm⟩ + have hkle : k ≤ g₁ v := by + rcases Nat.eq_zero_or_pos k with hz | hp + · simp [hz] + · rcases Nat.eq_zero_or_pos (g₀ v) with h0 | h0 + · exfalso + have : g₁ v = 0 := by rw [← hk, h0, Nat.mul_zero] + exact hkm 0 hp (by simp [this]) + · calc + k = k * 1 := (Nat.mul_one k).symm + _ ≤ k * g₀ v := (Nat.mul_le_mul_left k h0) + _ = g₁ v := hk + refine ⟨k, ?_, ?_⟩ + · refine Nat.mem_rfind.mpr ?_ + refine ⟨?_, ?_⟩ + · rw [Part.mem_some_iff, eq_comm, decide_eq_true_eq, key]; exact Or.inl hk + · intro m hm + rw [Part.mem_some_iff, eq_comm, decide_eq_false_iff_not, key] + rintro (he | hlt) + · exact hkm m hm he + · omega + · simp [isDvdNat, hv, isLeNat, hkle] + · refine ⟨g₁ v + 1, ?_, ?_⟩ + · refine Nat.mem_rfind.mpr ?_ + refine ⟨?_, ?_⟩ + · rw [Part.mem_some_iff, eq_comm, decide_eq_true_eq, key]; exact Or.inr (by omega) + · intro m hm + rw [Part.mem_some_iff, eq_comm, decide_eq_false_iff_not, key] + rintro (he | hlt) + · exact hv ⟨m, by rw [← he, Nat.mul_comm]⟩ + · omega + · simp [isDvdNat, hv, isLeNat] + +theorem computes_codeRem {n : ℕ} {d₀ d₁ : Code n} {g₀ g₁ : List.Vector ℕ n → ℕ} + (h₀ : Computes d₀ g₀) (h₁ : Computes d₁ g₁) : + Computes (codeRem d₀ d₁) (fun v => g₀ v % g₁ v) := + by + have hF : + Computes (codeDvd (codeLift d₁) (codeSub (codeLift d₀) codeHead)) + (fun w => isDvdNat (g₁ w.tail) (g₀ w.tail - w.head)) := + computes_codeDvd (computes_codeLift h₁) + (computes_codeSub (computes_codeLift h₀) computes_codeHead) + have h := eval_codeRfindPos hF + refine eval_of_eq h ?_ + funext v + simp only [List.Vector.head_cons, List.Vector.tail_cons, Part.coe_some] + rw [Part.eq_some_iff] + refine Nat.mem_rfind.mpr ?_ + constructor + · rw [Part.mem_some_iff, eq_comm, decide_eq_true_eq, isDvdNat_pos_iff] + exact Nat.dvd_sub_mod (g₀ v) + · intro m hm + rw [Part.mem_some_iff, eq_comm, decide_eq_false_iff_not, isDvdNat_pos_iff] + intro hdvd + have hmlt : m < g₀ v % g₁ v := hm + have hmod_le : g₀ v % g₁ v ≤ g₀ v := Nat.mod_le _ _ + rcases Nat.eq_zero_or_pos (g₁ v) with hz | hjpos + · rw [hz] at hdvd + rw [hz, Nat.mod_zero] at hmlt + rw [Nat.zero_dvd] at hdvd + omega + · have hsub : g₁ v ∣ g₀ v % g₁ v - m := + by + have heq : g₀ v - m - (g₀ v - g₀ v % g₁ v) = g₀ v % g₁ v - m := by omega + rw [← heq] + exact Nat.dvd_sub hdvd (Nat.dvd_sub_mod (g₀ v)) + have hpos : 0 < g₀ v % g₁ v - m := by omega + have hmodlt : g₀ v % g₁ v < g₁ v := Nat.mod_lt _ hjpos + exact absurd (Nat.le_of_dvd hpos hsub) (by omega) + +theorem eval_codeBeta {n : ℕ} {dn di : Code n} {gn gi : List.Vector ℕ n → ℕ} + (hn : Computes dn gn) (hi : Computes di gi) : + Computes (codeBeta dn di) (fun v => Nat.beta (gn v) (gi v)) := + (computes_codeRem (computes_codeUnpair₁ hn) + (computes_codeSucc + (computes_codeMul (computes_codeSucc hi) (computes_codeUnpair₂ hn)))).of_eq + (fun v => by simp [Nat.beta]) + +end ArithmeticCode +end CategoricalRiceShapiro + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/Basic.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/Basic.lean new file mode 100644 index 000000000..6e2d90e26 --- /dev/null +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/Basic.lean @@ -0,0 +1,246 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Arithmetic + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# Total arithmetic codes and their standard computations + +`Computes c f` says that the partial-recursive code `c` realizes the total +function `f` over the natural numbers. This module collects the constructors +used throughout the development -- projection, zero, one, addition, +multiplication, equality, strict order and composition -- together with the +derived total constructors built from them, and records the standard +computation theorem for each. + +These are statements about the natural numbers. Arbitrary-model evaluation is +the subject of `CategoricalRiceShapiro.ArithmeticCode.Evaluation`. +-/ + +@[expose] public section + +open _root_.Nat Nat Nat.ArithPart₁ + +namespace CategoricalRiceShapiro +namespace ArithmeticCode + +/-- `c` realizes the total function `f`. -/ +def Computes {n : ℕ} (c : Code n) (f : List.Vector ℕ n → ℕ) : Prop := + Code.eval c (fun v => (f v : Part ℕ)) + +theorem eval_of_eq {n : ℕ} {c : Code n} {f g : List.Vector ℕ n →. ℕ} (h : Code.eval c f) + (e : f = g) : Code.eval c g := + e ▸ h + +theorem Computes.of_eq {n : ℕ} {c : Code n} {f g : List.Vector ℕ n → ℕ} (h : Computes c f) + (e : ∀ v, f v = g v) : Computes c g := + by + refine eval_of_eq h ?_ + funext v + rw [e v] + +theorem computes_zero {n : ℕ} : Computes (Code.zero n) (fun _ => 0) := + Code.eval.zero + +theorem computes_one {n : ℕ} : Computes (Code.one n) (fun _ => 1) := + Code.eval.one + +theorem computes_add {n : ℕ} (i j : Fin n) : + Computes (Code.add i j) (fun v => v.get i + v.get j) := + Code.eval.add i j + +theorem computes_mul {n : ℕ} (i j : Fin n) : + Computes (Code.mul i j) (fun v => v.get i * v.get j) := + Code.eval.mul i j + +theorem computes_proj {n : ℕ} (i : Fin n) : Computes (Code.proj i) (fun v => v.get i) := + Code.eval.proj i + +theorem computes_equal {n : ℕ} (i j : Fin n) : + Computes (Code.equal i j) (fun v => isEqNat (v.get i) (v.get j)) := + Code.eval.equal i j + +theorem computes_lt {n : ℕ} (i j : Fin n) : + Computes (Code.lt i j) (fun v => isLtNat (v.get i) (v.get j)) := + Code.eval.lt i j + +/-- Generic composition at the total-function layer. -/ +theorem computes_comp {m k : ℕ} {c : Code k} {d : Fin k → Code m} {f : List.Vector ℕ k → ℕ} + {g : Fin k → List.Vector ℕ m → ℕ} (hc : Computes c f) (hd : ∀ i, Computes (d i) (g i)) : + Computes (c.comp d) (fun v => f (List.Vector.ofFn fun i => g i v)) := + by + have h := + Code.eval.comp c d (fun v => (f v : Part ℕ)) (fun i v => ((g i v : ℕ) : Part ℕ)) hc hd + refine eval_of_eq h ?_ + funext v + simp + +/-! +### Arity-specific composition -/ + +theorem computes_comp₁ {n : ℕ} {c : Code 1} {d : Code n} {f : ℕ → ℕ} {g : List.Vector ℕ n → ℕ} + (hc : Computes c (fun w => f (w.get 0))) (hd : Computes d g) : + Computes (c.comp ![d]) (fun v => f (g v)) := + by + refine (computes_comp (g := ![g]) hc ?_).of_eq ?_ + · intro i; + match i with + | ⟨0, _⟩ => exact hd + · intro v; simp + +theorem computes_comp₂ {n : ℕ} {c : Code 2} {d₀ d₁ : Code n} {f : ℕ → ℕ → ℕ} + {g₀ g₁ : List.Vector ℕ n → ℕ} (hc : Computes c (fun w => f (w.get 0) (w.get 1))) + (h₀ : Computes d₀ g₀) (h₁ : Computes d₁ g₁) : + Computes (c.comp ![d₀, d₁]) (fun v => f (g₀ v) (g₁ v)) := + by + refine (computes_comp (g := ![g₀, g₁]) hc ?_).of_eq ?_ + · intro i + match i with + | ⟨0, _⟩ => exact h₀ + | ⟨1, _⟩ => exact h₁ + · intro v; simp [List.Vector.get_one] + +/-! +### Derived total functions -/ + +/-- The code Succ construction in `CategoricalRiceShapiro.ArithmeticCode`. -/ +def codeSucc {n : ℕ} (d : Code n) : Code n := + (Code.add (0 : Fin 2) (1 : Fin 2)).comp ![d, Code.one n] + +theorem computes_codeSucc {n : ℕ} {d : Code n} {g : List.Vector ℕ n → ℕ} (hd : Computes d g) : + Computes (codeSucc d) (fun v => g v + 1) := + computes_comp₂ (f := fun a b => a + b) (computes_add 0 1) hd computes_one + +/-- The code Const construction in `CategoricalRiceShapiro.ArithmeticCode`. -/ +def codeConst {n : ℕ} : ℕ → Code n + | 0 => Code.zero n + | m + 1 => codeSucc (codeConst m) + +theorem computes_codeConst {n : ℕ} : ∀ m : ℕ, Computes (codeConst (n := n) m) (fun _ => m) + | 0 => computes_zero + | m + 1 => (computes_codeSucc (computes_codeConst m)).of_eq (fun _ => rfl) + +/-- The code Inv construction in `CategoricalRiceShapiro.ArithmeticCode`. -/ +def codeInv {n : ℕ} (d : Code n) : Code n := + (Code.equal (0 : Fin 2) (1 : Fin 2)).comp ![d, Code.zero n] + +theorem computes_codeInv {n : ℕ} {d : Code n} {g : List.Vector ℕ n → ℕ} (hd : Computes d g) : + Computes (codeInv d) (fun v => Nat.inv (g v)) := + (computes_comp₂ (f := fun a b => isEqNat a b) (computes_equal 0 1) hd computes_zero).of_eq + (fun v => by simp [Nat.inv, isEqNat]) + +/-- The code Pos construction in `CategoricalRiceShapiro.ArithmeticCode`. -/ +def codePos {n : ℕ} (d : Code n) : Code n := + (Code.lt (0 : Fin 2) (1 : Fin 2)).comp ![Code.zero n, d] + +theorem computes_codePos {n : ℕ} {d : Code n} {g : List.Vector ℕ n → ℕ} (hd : Computes d g) : + Computes (codePos d) (fun v => Nat.pos (g v)) := + (computes_comp₂ (f := fun a b => isLtNat a b) (computes_lt 0 1) computes_zero hd).of_eq + (fun v => by simp [Nat.pos, isLtNat]) + +/-! +### Boolean combinators -/ + +/-- The code And construction in `CategoricalRiceShapiro.ArithmeticCode`. -/ +def codeAnd {n : ℕ} (d₀ d₁ : Code n) : Code n := + (Code.lt (0 : Fin 2) (1 : Fin 2)).comp + ![Code.zero n, (Code.mul (0 : Fin 2) (1 : Fin 2)).comp ![d₀, d₁]] + +theorem computes_codeAnd {n : ℕ} {d₀ d₁ : Code n} {g₀ g₁ : List.Vector ℕ n → ℕ} + (h₀ : Computes d₀ g₀) (h₁ : Computes d₁ g₁) : + Computes (codeAnd d₀ d₁) (fun v => Nat.and (g₀ v) (g₁ v)) := + (computes_comp₂ (f := fun a b => isLtNat a b) (computes_lt 0 1) computes_zero + (computes_comp₂ (f := fun a b => a * b) (computes_mul 0 1) h₀ h₁)).of_eq + (fun v => by simp [Nat.and, isLtNat]) + +/-- The code Or construction in `CategoricalRiceShapiro.ArithmeticCode`. -/ +def codeOr {n : ℕ} (d₀ d₁ : Code n) : Code n := + (Code.lt (0 : Fin 2) (1 : Fin 2)).comp + ![Code.zero n, (Code.add (0 : Fin 2) (1 : Fin 2)).comp ![d₀, d₁]] + +theorem computes_codeOr {n : ℕ} {d₀ d₁ : Code n} {g₀ g₁ : List.Vector ℕ n → ℕ} + (h₀ : Computes d₀ g₀) (h₁ : Computes d₁ g₁) : + Computes (codeOr d₀ d₁) (fun v => Nat.or (g₀ v) (g₁ v)) := + (computes_comp₂ (f := fun a b => isLtNat a b) (computes_lt 0 1) computes_zero + (computes_comp₂ (f := fun a b => a + b) (computes_add 0 1) h₀ h₁)).of_eq + (fun v => by simp [Nat.or, isLtNat]) + +/-- The code Eq construction in `CategoricalRiceShapiro.ArithmeticCode`. -/ +def codeEq {n : ℕ} (d₀ d₁ : Code n) : Code n := + (Code.equal (0 : Fin 2) (1 : Fin 2)).comp ![d₀, d₁] + +theorem computes_codeEq {n : ℕ} {d₀ d₁ : Code n} {g₀ g₁ : List.Vector ℕ n → ℕ} + (h₀ : Computes d₀ g₀) (h₁ : Computes d₁ g₁) : + Computes (codeEq d₀ d₁) (fun v => isEqNat (g₀ v) (g₁ v)) := + computes_comp₂ (f := fun a b => isEqNat a b) (computes_equal 0 1) h₀ h₁ + +/-- The code Lt construction in `CategoricalRiceShapiro.ArithmeticCode`. -/ +def codeLt {n : ℕ} (d₀ d₁ : Code n) : Code n := + (Code.lt (0 : Fin 2) (1 : Fin 2)).comp ![d₀, d₁] + +theorem computes_codeLt {n : ℕ} {d₀ d₁ : Code n} {g₀ g₁ : List.Vector ℕ n → ℕ} + (h₀ : Computes d₀ g₀) (h₁ : Computes d₁ g₁) : + Computes (codeLt d₀ d₁) (fun v => isLtNat (g₀ v) (g₁ v)) := + computes_comp₂ (f := fun a b => isLtNat a b) (computes_lt 0 1) h₀ h₁ + +/-- The code Add construction in `CategoricalRiceShapiro.ArithmeticCode`. -/ +def codeAdd {n : ℕ} (d₀ d₁ : Code n) : Code n := + (Code.add (0 : Fin 2) (1 : Fin 2)).comp ![d₀, d₁] + +theorem computes_codeAdd {n : ℕ} {d₀ d₁ : Code n} {g₀ g₁ : List.Vector ℕ n → ℕ} + (h₀ : Computes d₀ g₀) (h₁ : Computes d₁ g₁) : + Computes (codeAdd d₀ d₁) (fun v => g₀ v + g₁ v) := + computes_comp₂ (f := fun a b => a + b) (computes_add 0 1) h₀ h₁ + +/-- The code Mul construction in `CategoricalRiceShapiro.ArithmeticCode`. -/ +def codeMul {n : ℕ} (d₀ d₁ : Code n) : Code n := + (Code.mul (0 : Fin 2) (1 : Fin 2)).comp ![d₀, d₁] + +theorem computes_codeMul {n : ℕ} {d₀ d₁ : Code n} {g₀ g₁ : List.Vector ℕ n → ℕ} + (h₀ : Computes d₀ g₀) (h₁ : Computes d₁ g₁) : + Computes (codeMul d₀ d₁) (fun v => g₀ v * g₁ v) := + computes_comp₂ (f := fun a b => a * b) (computes_mul 0 1) h₀ h₁ + +/-! +### Lifting a code under an extra search variable -/ + +/-- The code Lift construction in `CategoricalRiceShapiro.ArithmeticCode`. -/ +def codeLift {n : ℕ} (d : Code n) : Code (n + 1) := + d.comp (fun i => Code.proj i.succ) + +theorem computes_codeLift {n : ℕ} {d : Code n} {g : List.Vector ℕ n → ℕ} (hd : Computes d g) : + Computes (codeLift d) (fun w => g w.tail) := + by + refine + (computes_comp (g := fun i w => w.get i.succ) hd (fun i => computes_proj i.succ)).of_eq ?_ + intro w + congr 1 + refine List.Vector.ext ?_ + intro i + simp only [List.Vector.get_ofFn] + exact (List.Vector.get_tail_succ w i).symm + +/-- The code Head construction in `CategoricalRiceShapiro.ArithmeticCode`. -/ +def codeHead {n : ℕ} : Code (n + 1) := + Code.proj 0 + +theorem computes_codeHead {n : ℕ} : Computes (codeHead (n := n)) (fun w => w.head) := + (computes_proj (0 : Fin (n + 1))).of_eq (fun w => by simp) + +end ArithmeticCode +end CategoricalRiceShapiro + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/BetaCoding.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/BetaCoding.lean new file mode 100644 index 000000000..4ab1dbe80 --- /dev/null +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/BetaCoding.lean @@ -0,0 +1,554 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.NumeralEvaluation +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Induction + +/-! Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# Extending a Gödel beta code inside a model of Peano arithmetic + +`eval_codeBeta_of_values` computes `codeBeta` at arbitrary elements of a model of +`𝐈𝐎𝐩𝐞𝐧`, but it says nothing about which value assignments are realized by some +code. This file proves the one existence statement the recursion development +needs: in a model of `𝐏𝐀`, every beta code `n` and every index `l` admit a code +`n'` that agrees with `n` at every index below `l` and takes a prescribed value +at `l`. + +The statement is given as a graph evaluation of +`codeBeta (Code.proj 0) (Code.proj 1)` rather than as an equation between +remainders. A value-level statement would mention `%`, `π₁` and `π₂`, whose +elaboration demands an `𝐈𝐎𝐩𝐞𝐧` instance that `𝐏𝐀` does not supply while the +statement is being elaborated. + +Pinned Foundation supplies internal finite sequences of nonstandard length, but +no arbitrary-model Chinese remainder theorem and no beta encoder, so the +supporting development is built here and kept private: + +* a Bézout inverse, `exists_mul_mod_eq_one`, obtained from the least positive + residue of a multiple of the argument; +* the internal factorial and the internal product of beta moduli, each defined + by Foundation's `𝐈Σ₁` primitive recursion; +* coprimality of two beta moduli whose index difference divides the multiplier; +* simultaneous solution of the beta congruences prescribed by an internal + sequence. + +Nothing here uses `Nat.beta`, `Computes` or evaluation over standard `ℕ`. +-/ + +@[expose] public section + +open _root_.Nat Nat Nat.ArithPart₁ +open Encodable FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic +open scoped FFL.FirstOrder.Arithmetic + +namespace CategoricalRiceShapiro +namespace ArithmeticCode + +section Internal + +variable {V : Type*} [ORingStructure V] + +section IOpen + +variable [V↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + +private lemma dvd_sub_of {d x y : V} (hx : d ∣ x) (hy : d ∣ y) : d ∣ x - y := + by + rcases eq_or_ne d 0 with rfl | hd + · rw [zero_dvd_iff] at hx hy + simp [hx, hy] + · rcases lt_or_ge x y with h | h + · simp [FFL.FirstOrder.Arithmetic.sub_spec_of_lt h] + · obtain ⟨p, rfl⟩ := hx + obtain ⟨q, rfl⟩ := hy + have hdp : 0 < d := pos_iff_ne_zero.mpr hd + have hqp : q ≤ p := le_of_mul_le_mul_left h hdp + exact ⟨p - q, (FFL.FirstOrder.Arithmetic.mul_sub hqp).symm⟩ + +private lemma mod_add_congr {m x₁ x₂ y₁ y₂ : V} (hm : 0 < m) (h₁ : x₁ % m = y₁ % m) + (h₂ : x₂ % m = y₂ % m) : (x₁ + x₂) % m = (y₁ + y₂) % m := by + rw [mod_add hm, h₁, h₂, ← mod_add hm] + +private lemma mod_mul_congr {m x₁ x₂ y₁ y₂ : V} (hm : 0 < m) (h₁ : x₁ % m = y₁ % m) + (h₂ : x₂ % m = y₂ % m) : (x₁ * x₂) % m = (y₁ * y₂) % m := by + rw [mod_mul hm, h₁, h₂, ← mod_mul hm] + +private lemma mod_mod_self {x m : V} (hm : 0 < m) : (x % m) % m = x % m := + mod_eq_self_of_lt (mod_lt x hm) + +end IOpen + +section ISigmaOne + +variable [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +/-- A number coprime to a modulus above one has a multiplicative inverse there. -/ +private theorem exists_mul_mod_eq_one {A m : V} (hm : 1 < m) + (hco : ∀ d : V, d ∣ A → d ∣ m → d = 1) : ∃ u : V, (A * u) % m = 1 := by + have hm0 : 0 < m := lt_trans _root_.zero_lt_one hm + have hdef : Σ₀-Predicate (fun r : V => 0 < r ∧ ∃ u < m, (A * u) % m = r) := by + definability + have hAm : 0 < A % m := by + rcases eq_or_ne (A % m) 0 with h | h + · exact absurd (hco m (mod_eq_zero_iff_dvd.mp h) dvd_rfl) (ne_of_gt hm) + · exact pos_iff_ne_zero.mpr h + have hstart : (0 : V) < A % m ∧ ∃ u < m, (A * u) % m = A % m := ⟨hAm, 1, hm, by simp⟩ + obtain ⟨g, ⟨hgpos, u₀, -, hu₀⟩, hmin⟩ := ISigma0.least_number hdef hstart + have hgm : g < m := lt_of_le_of_lt (not_lt.mp fun hc => hmin _ hc hstart) (mod_lt A hm0) + have hgself : g % m = g := mod_eq_self_of_lt hgm + -- no residue of a multiple of `A` lies strictly below the least positive one + have hnew : ∀ s w : V, (A * w) % m = s → s < g → s = 0 := by + intro s w hw hs + by_contra h0 + exact hmin s hs ⟨pos_iff_ne_zero.mpr h0, w % m, mod_lt _ hm0, + by rw [mod_mul_congr hm0 rfl (mod_mod_self hm0)]; exact hw⟩ + -- hence the least positive residue divides every residue + have hstep : ∀ w z : V, (A * w) % m = z → g ∣ z := by + intro w z hz + have hzm : z < m := hz ▸ mod_lt _ hm0 + have hzk : g * (z / g) + z % g = z := div_add_mod z g + have hr : z % g < g := mod_lt z hgpos + have hKk : (m * (z / g + 1) - z / g) + z / g = m * (z / g + 1) := + sub_add_self_of_le (le_of_lt + (lt_of_lt_of_le (lt_add_one _) (le_mul_self_of_pos_left hm0))) + have harith : z + (m * (z / g + 1) - z / g) * g + = z % g + m * ((z / g + 1) * g) := by + calc z + (m * (z / g + 1) - z / g) * g + = (g * (z / g) + z % g) + (m * (z / g + 1) - z / g) * g := by rw [hzk] + _ = z % g + ((m * (z / g + 1) - z / g) + z / g) * g := by simp [mul_add, mul_comm, add_comm, + add_assoc] + _ = z % g + (m * (z / g + 1)) * g := by rw [hKk] + _ = z % g + m * ((z / g + 1) * g) := by simp [mul_add, mul_comm, mul_left_comm, add_comm] + have key : (A * (w + (m * (z / g + 1) - z / g) * u₀)) % m = z % g := by + calc (A * (w + (m * (z / g + 1) - z / g) * u₀)) % m + = (A * w + (m * (z / g + 1) - z / g) * (A * u₀)) % m := by + congr 1 + simp [mul_add, mul_comm, mul_assoc, add_comm] + _ = (z + (m * (z / g + 1) - z / g) * g) % m := + mod_add_congr hm0 (by rw [hz, mod_eq_self_of_lt hzm]) + (mod_mul_congr hm0 rfl (by rw [hu₀, hgself])) + _ = (z % g + m * ((z / g + 1) * g)) % m := by rw [harith] + _ = z % g := by + rw [mod_add_mul' _ _ hm0, mod_eq_self_of_lt (lt_trans hr hgm)] + exact mod_eq_zero_iff_dvd.mp (hnew _ _ key hr) + -- and in particular divides the modulus + have hgdvdm : g ∣ m := by + have hr : m % g < g := mod_lt m hgpos + have hrg : m % g ≤ g := le_of_lt hr + have hmq : g * (m / g) + m % g = m := div_add_mod m g + rcases eq_or_ne (m % g) 0 with h0 | h0 + · exact mod_eq_zero_iff_dvd.mp h0 + · exfalso + have harith : (m / g + 1) * g = m + (g - m % g) := by + calc (m / g + 1) * g = g * (m / g) + g := by simp [mul_add, mul_comm, add_comm] + _ = g * (m / g) + ((g - m % g) + m % g) := by rw [sub_add_self_of_le hrg] + _ = (g * (m / g) + m % g) + (g - m % g) := by simp [ + add_comm, add_left_comm, add_assoc] + _ = m + (g - m % g) := by rw [hmq] + have key : (A * ((m / g + 1) * u₀)) % m = g - m % g := by + calc (A * ((m / g + 1) * u₀)) % m + = ((m / g + 1) * (A * u₀)) % m := by congr 1; simp [mul_add, mul_comm, mul_left_comm, + add_comm] + _ = ((m / g + 1) * g) % m := mod_mul_congr hm0 rfl (by rw [hu₀, hgself]) + _ = (m + (g - m % g)) % m := by rw [harith] + _ = g - m % g := by + rw [mod_add_remove_left hm0, mod_eq_self_of_lt + (lt_of_le_of_lt (FFL.FirstOrder.Arithmetic.sub_le_self _ _) hgm)] + have hsub_lt : g - m % g < g := by + have h : g - m % g < g - m % g + m % g := + lt_add_of_pos_right _ (pos_iff_ne_zero.mpr h0) + rwa [sub_add_self_of_le hrg] at h + exact absurd hr (not_lt.mpr (sub_eq_zero_iff_le.mp (hnew _ _ key hsub_lt))) + have hgdvdA : g ∣ A := by + have h₁ : g ∣ A % m := hstep 1 _ (by simp) + have h₂ : m * (A / m) + A % m = A := div_add_mod A m + exact h₂ ▸ Dvd.dvd.add (Dvd.dvd.mul_right hgdvdm _) h₁ + exact ⟨u₀, by rw [hu₀, hco g hgdvdA hgdvdm]⟩ + +namespace InternalFactorial +private def blueprint : PR.Blueprint 0 where + zero := .mkSigma “y. y = 1” + succ := .mkSigma “y ih k. y = (k + 1) * ih” + +private noncomputable def construction : PR.Construction V blueprint + where + zero _ := 1 + succ _ k ih := (k + 1) * ih + zero_defined := .mk fun v ↦ by simp [blueprint] + succ_defined := .mk fun v ↦ by simp [blueprint] +end InternalFactorial + +/-- The internal factorial. -/ +private noncomputable def internalFactorial (k : V) : V := + InternalFactorial.construction.result ![] k + +@[simp] +private lemma internalFactorial_zero : internalFactorial (0 : V) = 1 := by + simp [internalFactorial, InternalFactorial.construction] + +@[simp] +private lemma internalFactorial_succ (k : V) : + internalFactorial (k + 1) = (k + 1) * internalFactorial k := by + simp [internalFactorial, InternalFactorial.construction] + +private noncomputable def internalFactorialGraph : Σ₁.Semisentence 2 := + InternalFactorial.blueprint.resultDef + +private instance internalFactorial_defined : + Σ₁-Function₁[V] internalFactorial via internalFactorialGraph := + .mk fun v ↦ by + simp [InternalFactorial.construction.result_defined_iff, internalFactorialGraph, + internalFactorial, _root_.Matrix.empty_eq] + +private instance internalFactorial_definable : Σ₁-Function₁[V] internalFactorial := + internalFactorial_defined.to_definable + +private instance internalFactorial_definable' (Γ m) : + Γ-[m + 1]-Function₁[V] internalFactorial := + internalFactorial_definable.of_sigmaOne + +namespace ModulusProduct +private def blueprint : PR.Blueprint 1 where + zero := .mkSigma “y b. y = 1” + succ := .mkSigma “y ih k b. y = ((k + 1) * b + 1) * ih” + +private noncomputable def construction : PR.Construction V blueprint + where + zero _ := 1 + succ param k ih := ((k + 1) * param 0 + 1) * ih + zero_defined := .mk fun v ↦ by simp [blueprint] + succ_defined := .mk fun v ↦ by simp [blueprint] +end ModulusProduct + +/-- The internal product of the beta moduli below a given index. -/ +private noncomputable def modulusProduct (b j : V) : V := + ModulusProduct.construction.result ![b] j + +@[simp] +private lemma modulusProduct_zero (b : V) : modulusProduct b 0 = 1 := by + simp [modulusProduct, ModulusProduct.construction] + +@[simp] +private lemma modulusProduct_succ (b j : V) : + modulusProduct b (j + 1) = ((j + 1) * b + 1) * modulusProduct b j := by + simp [modulusProduct, ModulusProduct.construction] + +private noncomputable def modulusProductGraph : Σ₁.Semisentence 3 := + ModulusProduct.blueprint.resultDef + +private instance modulusProduct_defined : + Σ₁-Function₂[V] (fun b j => modulusProduct b j) via + modulusProductGraph.rew (Rew.subst ![#0, #2, #1]) := + .mk fun v ↦ by + simp [ModulusProduct.construction.result_defined_iff, modulusProductGraph, modulusProduct, + show (fun _ : Fin 1 => v 1) = (![v 1] : Fin 1 → V) from + funext fun i => by rcases Fin.eq_zero i with rfl; simp] + +private instance modulusProduct_definable : + Σ₁-Function₂[V] (fun b j : V => modulusProduct b j) := + modulusProduct_defined.to_definable + +private instance modulusProduct_definable' (Γ m) : + Γ-[m + 1]-Function₂[V] (fun b j : V => modulusProduct b j) := + modulusProduct_definable.of_sigmaOne + +private lemma internalFactorial_pos (k : V) : 0 < internalFactorial k := + by + induction k using ISigma1.sigma1_succ_induction + · definability + case zero => simp + case succ k ih => simp only [internalFactorial_succ]; exact mul_pos (by simp) ih + +private lemma self_le_internalFactorial (k : V) : k ≤ internalFactorial k := + by + induction k using ISigma1.sigma1_succ_induction + · definability + case zero => simp + case succ k ih => + simp only [internalFactorial_succ] + exact le_mul_self_of_pos_right (internalFactorial_pos k) + +private lemma dvd_internalFactorial {j k : V} (hj : 0 < j) (hjk : j ≤ k) : + j ∣ internalFactorial k := + by + have main : ∀ k : V, ∀ j < k + 1, 0 < j → j ∣ internalFactorial k := + by + intro k + induction k using ISigma1.pi1_succ_induction + · definability + case zero => + intro j hj hjpos + exact absurd (lt_succ_iff_le.mp hj) (not_le.mpr hjpos) + case succ k ih => + intro j hj hjpos + simp only [internalFactorial_succ] + rcases le_iff_lt_or_eq.mp (lt_succ_iff_le.mp hj) with h | rfl + · exact Dvd.dvd.mul_left (ih j h hjpos) _ + · exact Dvd.dvd.mul_right dvd_rfl _ + exact main k j (lt_succ_iff_le.mpr hjk) hj + +private lemma dvd_modulusProduct {b i j : V} (hij : i < j) : + ((i + 1) * b + 1) ∣ modulusProduct b j := + by + have main : ∀ j : V, ∀ i < j, ((i + 1) * b + 1) ∣ modulusProduct b j := + by + intro j + induction j using ISigma1.pi1_succ_induction + · definability + case zero => intro i hi; exact absurd hi (by simp) + case succ j ih => + intro i hi + simp only [modulusProduct_succ] + rcases le_iff_lt_or_eq.mp (lt_succ_iff_le.mp hi) with h | rfl + · exact Dvd.dvd.mul_left (ih i h) _ + · exact Dvd.dvd.mul_right dvd_rfl _ + exact main j i hij + +private lemma inv_mul {m a c : V} (hm : 1 < m) + (ha : ∃ u : V, (a * u) % m = 1) (hc : ∃ w : V, (c * w) % m = 1) : + ∃ z : V, (a * c * z) % m = 1 := by + obtain ⟨u, hu⟩ := ha + obtain ⟨w, hw⟩ := hc + have hm0 : 0 < m := lt_trans _root_.zero_lt_one hm + refine ⟨u * w, ?_⟩ + calc (a * c * (u * w)) % m = ((a * u) * (c * w)) % m := by congr 1; simp [mul_comm, mul_left_comm, + ] + _ = (((a * u) % m) * ((c * w) % m)) % m := mod_mul hm0 + _ = 1 := by rw [hu, hw, mul_one, mod_eq_self_of_lt hm] + +/-- Two beta moduli whose index difference divides the multiplier have no common +divisor above one. -/ +private lemma modulus_coprime {b i j : V} (hij : i < j) (hdvd : (j - i) ∣ b) + (d : V) (hi : d ∣ (i + 1) * b + 1) (hj : d ∣ (j + 1) * b + 1) : d = 1 := by + have hsum : ((i + 1) * b + 1) + (j - i) * b = (j + 1) * b + 1 := by + have e : i + (j - i) = j := add_tsub_self_of_le (le_of_lt hij) + calc ((i + 1) * b + 1) + (j - i) * b = ((i + (j - i)) + 1) * b + 1 := by simp [mul_add, + mul_comm, add_comm, add_left_comm, add_assoc] + _ = (j + 1) * b + 1 := by rw [e] + have hdb : d ∣ (j - i) * b := by + have e : ((j + 1) * b + 1) - ((i + 1) * b + 1) = (j - i) * b := by rw [← hsum]; simp + exact e ▸ dvd_sub_of hj hi + have hbb : d ∣ b * b := by + obtain ⟨w, hw⟩ := hdvd + have e : ((j - i) * b) * w = b * b := by + calc ((j - i) * b) * w = ((j - i) * w) * b := by simp [mul_comm, mul_left_comm, ] + _ = b * b := by rw [← hw] + exact e ▸ Dvd.dvd.mul_right hdb w + have hco : ∀ e : V, e ∣ b → e ∣ d → e = 1 := by + intro e heb hed + have h1 : e ∣ (i + 1) * b + 1 := Dvd.dvd.trans hed hi + have h2 : e ∣ (i + 1) * b := Dvd.dvd.mul_left heb _ + have h3 : ((i + 1) * b + 1) - ((i + 1) * b) = 1 := by simp + exact dvd_one_iff.mp (h3 ▸ dvd_sub_of h1 h2) + rcases eq_or_ne d 1 with h | h + · exact h + · exfalso + have hd0 : d ≠ 0 := by + intro h0 + rw [h0, zero_dvd_iff] at hi + simp at hi + have hd1 : 1 < d := lt_of_le_of_ne (ne_zero_iff_one_le.mp hd0) (Ne.symm h) + have hd0' : 0 < d := lt_trans _root_.zero_lt_one hd1 + obtain ⟨v, hv⟩ := exists_mul_mod_eq_one hd1 hco + have hzero : (b * b * (v * v)) % d = 0 := by + rw [mod_mul hd0', mod_eq_zero_iff_dvd.mpr hbb] + simp + have hone : (b * b * (v * v)) % d = 1 := by + calc (b * b * (v * v)) % d = ((b * v) * (b * v)) % d := by congr 1; simp [mul_comm, + mul_left_comm, ] + _ = (((b * v) % d) * ((b * v) % d)) % d := mod_mul hd0' + _ = 1 := by rw [hv, mul_one, mod_eq_self_of_lt hd1] + exact absurd (hzero.symm.trans hone) zero_ne_one + +/-- The product of the beta moduli below an index is invertible modulo the +modulus at that index. -/ +private lemma exists_inv_modulusProduct {b L : V} (hm : 1 < (L + 1) * b + 1) + (hcop : ∀ i < L, ∀ d : V, d ∣ (i + 1) * b + 1 → d ∣ (L + 1) * b + 1 → d = 1) : + ∀ j ≤ L, ∃ u : V, (modulusProduct b j * u) % ((L + 1) * b + 1) = 1 := + by + intro j + induction j using ISigma1.sigma1_succ_induction + · definability + case zero => + intro _ + exact ⟨1, by rw [modulusProduct_zero, mul_one, mod_eq_self_of_lt hm]⟩ + case succ j ih => + intro hj + have hjL : j < L := succ_le_iff_lt.mp hj + rw [modulusProduct_succ] + exact inv_mul hm (exists_mul_mod_eq_one hm (hcop j hjL)) (ih (le_of_lt hjL)) + +/-- Simultaneous solution of the beta congruences supplied by an internal +sequence. -/ +private lemma exists_crt {s b : V} (hb : 0 < b) + (hcop : ∀ i j : V, i < j → j < lh s → ∀ d : V, + d ∣ (i + 1) * b + 1 → d ∣ (j + 1) * b + 1 → d = 1) + (hlt : ∀ i < lh s, znth s i < (i + 1) * b + 1) : + ∃ c : V, ∀ i < lh s, c % ((i + 1) * b + 1) = znth s i := by + have hmod : ∀ i : V, 1 < (i + 1) * b + 1 := by + intro i + have : 0 < (i + 1) * b := mul_pos (by simp) hb + simpa using this + have main : ∀ L : V, L ≤ lh s → ∃ c : V, ∀ i < L, c % ((i + 1) * b + 1) = znth s i := by + intro L + induction L using ISigma1.sigma1_succ_induction + · definability + case zero => intro _; exact ⟨0, by intro i hi; exact absurd hi (by simp)⟩ + case succ L ih => + intro hL + have hLs : L < lh s := succ_le_iff_lt.mp hL + obtain ⟨c, hc⟩ := ih (le_of_lt hLs) + have hm : 1 < (L + 1) * b + 1 := hmod L + have hm0 : 0 < (L + 1) * b + 1 := lt_trans _root_.zero_lt_one hm + obtain ⟨u, hu⟩ := exists_inv_modulusProduct hm + (fun i hiL d h₁ h₂ => hcop i L hiL hLs d h₁ h₂) L (le_refl L) + have hclt : c < ((L + 1) * b + 1) * (c + 1) := + lt_of_lt_of_le (lt_add_one c) (le_mul_self_of_pos_left hm0) + have hr : (znth s L + ((L + 1) * b + 1) * (c + 1) - c) + c + = znth s L + ((L + 1) * b + 1) * (c + 1) := + sub_add_self_of_le (le_trans (le_of_lt hclt) le_add_self) + refine ⟨c + u * (znth s L + ((L + 1) * b + 1) * (c + 1) - c) * modulusProduct b L, ?_⟩ + intro i hi + rcases le_iff_lt_or_eq.mp (lt_succ_iff_le.mp hi) with hiL | rfl + · rw [mod_add_remove_right_of_dvd + (Dvd.dvd.mul_left (dvd_modulusProduct hiL) _) (lt_trans _root_.zero_lt_one (hmod i))] + exact hc i hiL + · have hres : (u * (znth s i + ((i + 1) * b + 1) * (c + 1) - c) * modulusProduct b i) + % ((i + 1) * b + 1) + = (znth s i + ((i + 1) * b + 1) * (c + 1) - c) % ((i + 1) * b + 1) := by + calc (u * (znth s i + ((i + 1) * b + 1) * (c + 1) - c) * modulusProduct b i) + % ((i + 1) * b + 1) + = ((znth s i + ((i + 1) * b + 1) * (c + 1) - c) * (modulusProduct b i * u)) + % ((i + 1) * b + 1) := by + congr 1 + simp [mul_add, mul_comm, mul_left_comm, mul_assoc, add_comm, + add_left_comm, add_assoc] + _ = (((znth s i + ((i + 1) * b + 1) * (c + 1) - c) % ((i + 1) * b + 1)) + * ((modulusProduct b i * u) % ((i + 1) * b + 1))) % ((i + 1) * b + 1) := + mod_mul hm0 + _ = (znth s i + ((i + 1) * b + 1) * (c + 1) - c) % ((i + 1) * b + 1) := by + rw [hu, mul_one, mod_mod_self hm0] + calc (c + u * (znth s i + ((i + 1) * b + 1) * (c + 1) - c) * modulusProduct b i) + % ((i + 1) * b + 1) + = (c + (znth s i + ((i + 1) * b + 1) * (c + 1) - c)) % ((i + 1) * b + 1) := + mod_add_congr hm0 rfl hres + _ = (znth s i + ((i + 1) * b + 1) * (c + 1)) % ((i + 1) * b + 1) := by + rw [add_comm c, hr] + _ = znth s i := by + rw [mod_add_mul' _ _ hm0, mod_eq_self_of_lt (hlt i hLs)] + exact main (lh s) (le_refl _) + +/-- Gödel beta coding of an internal finite sequence. -/ +private lemma exists_beta_of_seq {s : V} (hs : Seq s) : + ∃ c b : V, 0 < b ∧ ∀ i < lh s, c % ((i + 1) * b + 1) = znth s i := by + have hb : 0 < internalFactorial (s + lh s) := internalFactorial_pos _ + have hlt : ∀ i < lh s, znth s i < (i + 1) * internalFactorial (s + lh s) + 1 := by + intro i hi + calc znth s i < s := lt_of_mem_rng (hs.znth hi) + _ ≤ s + lh s := le_self_add + _ ≤ internalFactorial (s + lh s) := self_le_internalFactorial _ + _ ≤ (i + 1) * internalFactorial (s + lh s) := le_mul_self_of_pos_left (by simp) + _ < (i + 1) * internalFactorial (s + lh s) + 1 := lt_add_one _ + have hcop : ∀ i j : V, i < j → j < lh s → ∀ d : V, + d ∣ (i + 1) * internalFactorial (s + lh s) + 1 → + d ∣ (j + 1) * internalFactorial (s + lh s) + 1 → d = 1 := by + intro i j hij hj d h₁ h₂ + refine modulus_coprime hij (dvd_internalFactorial (pos_sub_iff_lt.mpr hij) ?_) d h₁ h₂ + calc j - i ≤ j := FFL.FirstOrder.Arithmetic.sub_le_self _ _ + _ ≤ s + lh s := le_trans (le_of_lt hj) le_add_self + obtain ⟨c, hc⟩ := exists_crt hb hcop hlt + exact ⟨c, internalFactorial (s + lh s), hb, hc⟩ + +end ISigmaOne + +end Internal + +/-- Every Gödel beta code extends to one that keeps its values below an index and +takes a prescribed value at that index. + +The two evaluations are the graph of `codeBeta (Code.proj 0) (Code.proj 1)` at +the assignments `![n, i]` and `![n', i]`; `eval_codeBeta_of_values` identifies +that graph with the remainder the code computes. -/ +theorem exists_codeBeta_extension + {M : Type*} [ORingStructure M] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] + (n l x : M) : + ∃ n' : M, + (∀ i y : M, i < l → + Semiformula.Evalb (y :> ![n, i]) + (code (codeBeta + (Code.proj (0 : Fin 2)) (Code.proj (1 : Fin 2)))) → + Semiformula.Evalb (y :> ![n', i]) + (code (codeBeta + (Code.proj (0 : Fin 2)) (Code.proj (1 : Fin 2))))) ∧ + Semiformula.Evalb (x :> ![n', l]) + (code (codeBeta + (Code.proj (0 : Fin 2)) (Code.proj (1 : Fin 2)))) := by + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ 1 := + models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + -- the graph of `codeBeta` on the two projections, at an arbitrary pair + have hbeta : ∀ a i : M, Semiformula.Evalb + ((FFL.FirstOrder.Arithmetic.pi₁ a % + ((i + 1) * FFL.FirstOrder.Arithmetic.pi₂ a + 1)) :> ![a, i]) + (code (codeBeta (Code.proj (0 : Fin 2)) (Code.proj (1 : Fin 2)))) := by + intro a i + exact eval_codeBeta_of_values _ _ a i ![a, i] + ((eval_proj_iff _ _ _).mpr (by simp)) ((eval_proj_iff _ _ _).mpr (by simp)) + -- the sequence of old beta values below `l`, extended by `x` at `l` + have hR : Σ₁-Relation (fun i y : M => + (i < l ∧ y = FFL.FirstOrder.Arithmetic.pi₁ n % + ((i + 1) * FFL.FirstOrder.Arithmetic.pi₂ n + 1)) ∨ (i = l ∧ y = x)) := by + definability + have hU : ∀ i < l + 1, ∃ y : M, + (i < l ∧ y = FFL.FirstOrder.Arithmetic.pi₁ n % + ((i + 1) * FFL.FirstOrder.Arithmetic.pi₂ n + 1)) ∨ (i = l ∧ y = x) := by + intro i hi + rcases le_iff_lt_or_eq.mp (lt_succ_iff_le.mp hi) with h | rfl + · exact ⟨_, Or.inl ⟨h, rfl⟩⟩ + · exact ⟨x, Or.inr ⟨rfl, rfl⟩⟩ + obtain ⟨s, hs, hlh, hsR⟩ := sigmaOne_skolem_seq hR hU + obtain ⟨c, b, -, hc⟩ := exists_beta_of_seq hs + have hval : ∀ i < l + 1, + (i < l ∧ znth s i = FFL.FirstOrder.Arithmetic.pi₁ n % + ((i + 1) * FFL.FirstOrder.Arithmetic.pi₂ n + 1)) ∨ (i = l ∧ znth s i = x) := + fun i hi => hsR i (znth s i) (hs.znth (by rw [hlh]; exact hi)) + refine ⟨FFL.FirstOrder.Arithmetic.pair c b, ?_, ?_⟩ + · intro i y hi hy + have hyval : y = FFL.FirstOrder.Arithmetic.pi₁ n % + ((i + 1) * FFL.FirstOrder.Arithmetic.pi₂ n + 1) := eval_unique hy (hbeta n i) + have hcv : c % ((i + 1) * b + 1) = znth s i := + hc i (by rw [hlh]; exact lt_succ_iff_le.mpr (le_of_lt hi)) + have hzn : znth s i = FFL.FirstOrder.Arithmetic.pi₁ n % + ((i + 1) * FFL.FirstOrder.Arithmetic.pi₂ n + 1) := by + rcases hval i (lt_succ_iff_le.mpr (le_of_lt hi)) with ⟨-, h⟩ | ⟨rfl, -⟩ + · exact h + · exact absurd hi (_root_.lt_irrefl _) + have h := hbeta (FFL.FirstOrder.Arithmetic.pair c b) i + rw [FFL.FirstOrder.Arithmetic.pi₁_pair, FFL.FirstOrder.Arithmetic.pi₂_pair, + hcv, hzn, ← hyval] at h + exact h + · have hcv : c % ((l + 1) * b + 1) = znth s l := hc l (by rw [hlh]; exact lt_add_one l) + have hzn : znth s l = x := by + rcases hval l (lt_add_one l) with ⟨h, -⟩ | ⟨-, h⟩ + · exact absurd h (_root_.lt_irrefl _) + · exact h + have h := hbeta (FFL.FirstOrder.Arithmetic.pair c b) l + rw [FFL.FirstOrder.Arithmetic.pi₁_pair, FFL.FirstOrder.Arithmetic.pi₂_pair, + hcv, hzn] at h + exact h + +end ArithmeticCode +end CategoricalRiceShapiro + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/Conditional.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/Conditional.lean new file mode 100644 index 000000000..3dea1a039 --- /dev/null +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/Conditional.lean @@ -0,0 +1,77 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.Basic + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# An eager conditional and non-strict comparison + +`codeIfPos df dg dh` is arithmetic, not lazy: it evaluates `dg` and `dh` +both, and selects one of them by multiplying with the characteristic values +`codePos df` and `codeInv df`. `codeLe` is the disjunction of strict order +and equality. + +Each construction is accompanied by the theorem that it realizes the intended +function over the natural numbers. Those `Computes` theorems are the input of +the standard-model bridge, which turns a computation over `ℕ` into evaluation at +standard numerals in an arbitrary model. +-/ + +@[expose] public section + +open _root_.Nat Nat Nat.ArithPart₁ + +namespace CategoricalRiceShapiro +namespace ArithmeticCode + +/-- `dg` when `df` is positive and `dh` otherwise, selected arithmetically. + +Both branches are evaluated; the construction is a sum of products, not a +selected-branch semantics. -/ +def codeIfPos {n : ℕ} (df dg dh : Code n) : Code n := + codeAdd (codeMul (codePos df) dg) (codeMul (codeInv df) dh) + +/-- The characteristic value of `d₀ ≤ d₁`. -/ +def codeLe {n : ℕ} (d₀ d₁ : Code n) : Code n := + codeOr (codeLt d₀ d₁) (codeEq d₀ d₁) + +/-! +### Standard computations over the natural numbers -/ + +theorem computes_codeIfPos {n : ℕ} {df dg dh : Code n} {f g h : List.Vector ℕ n → ℕ} + (hf : Computes df f) (hg : Computes dg g) (hh : Computes dh h) : + Computes (codeIfPos df dg dh) (fun v => if 0 < f v then g v else h v) := + (computes_codeAdd (computes_codeMul (computes_codePos hf) hg) + (computes_codeMul (computes_codeInv hf) hh)).of_eq + (fun v => by + by_cases hz : f v = 0 <;> simp [hz, Nat.pos, Nat.inv, isLtNat, isEqNat, zero_lt_iff]) + +theorem computes_codeLe {n : ℕ} {d₀ d₁ : Code n} {g₀ g₁ : List.Vector ℕ n → ℕ} + (h₀ : Computes d₀ g₀) (h₁ : Computes d₁ g₁) : + Computes (codeLe d₀ d₁) (fun v => isLeNat (g₀ v) (g₁ v)) := + (computes_codeOr (computes_codeLt h₀ h₁) (computes_codeEq h₀ h₁)).of_eq + (fun v => by + by_cases h : g₀ v < g₁ v + · simp [Nat.or, isLeNat, isLtNat, isEqNat, h, le_of_lt h] + · by_cases h2 : g₀ v = g₁ v + · simp [Nat.or, isLeNat, isLtNat, isEqNat, h2] + · have : ¬g₀ v ≤ g₁ v := by omega + simp [Nat.or, isLeNat, isLtNat, isEqNat, h, h2, this]) + +end ArithmeticCode +end CategoricalRiceShapiro + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/EncodedList.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/EncodedList.lean new file mode 100644 index 000000000..7b4c66b86 --- /dev/null +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/EncodedList.lean @@ -0,0 +1,136 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.Pairing +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.Recursion + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# Codes acting on an encoded list + +A list of natural numbers is represented by its `Encodable` code, in which the +empty list is `0` and a cons cell is the successor of a Cantor pair of head and +tail. `codeListHead?` and `codeListTail` invert that representation, and +`codeListDrop` iterates the tail by primitive recursion, so that +`codeListGet?` reads the entry at an index as an encoded `Option`. `codeListLength` +minimizes the number of entries that must be dropped to reach the empty list, and +`codeOptionBind` is the bind of the encoded option monad. + +Only the code constructions are given here. The standard computation theorems +over the natural numbers are not part of this migration. +-/ + +@[expose] public section + +open _root_.Nat Nat Nat.ArithPart₁ + +namespace CategoricalRiceShapiro +namespace ArithmeticCode + +/-- The head of an encoded list, as an encoded `Option`. -/ +def codeListHeadOptional {n : ℕ} (d : Code n) : Code n := + codeIfPos d (codeSucc (codeUnpair₁ (codeSub d (codeConst 1)))) (Code.zero n) + +/-- The tail of an encoded list. -/ +def codeListTail {n : ℕ} (d : Code n) : Code n := + codeUnpair₂ (codeSub d (codeConst 1)) + +/-- Iterated tail of an encoded list, as a code in the index and the list. -/ +def codeListDropCore : Code 2 := + codePrec (Code.proj (0 : Fin 1)) (codeListTail (Code.proj (1 : Fin 3))) + +/-- Drop `didx` entries from the encoded list `dlist`. -/ +def codeListDrop {n : ℕ} (dlist didx : Code n) : Code n := + codeListDropCore.comp ![didx, dlist] + +/-- The entry of the encoded list `dlist` at index `didx`, as an encoded +`Option`. -/ +def codeListGetOptional {n : ℕ} (dlist didx : Code n) : Code n := + codeListHeadOptional (codeListDrop dlist didx) + +/-- The length of an encoded list: the least index at which dropping that many +entries leaves the empty list. -/ +def codeListLength {n : ℕ} (dlist : Code n) : Code n := + codeRfindPos (codeInv (codeListDrop (codeLift dlist) codeHead)) + +/-- Bind on an encoded `Option`: run `dk` on the payload when `dopt` encodes +`some`, and return the encoding of `none` otherwise. -/ +def codeOptionBind {n : ℕ} (dopt : Code n) (dk : Code (n + 1)) : Code n := + codeIfPos dopt (codeBind (codeSub dopt (Code.one n)) dk) (Code.zero n) + +/-- `codeListDrop` applies one fixed arity-two code to its two arguments. + +A context that changes only those arguments is therefore a composition context, +to which `eval_comp_congr` applies. The arity-two code is an implementation +detail and stays private; a proof reaches it by rewriting with this equation. -/ +theorem codeListDrop_eq_comp {n : ℕ} (dlist didx : Code n) : + codeListDrop dlist didx = codeListDropCore.comp ![didx, dlist] := + rfl + +/-! +### One-layer view of an encoded list + +The pinned encoding of `List ℕ` satisfies `encode [] = 0` and +`encode (x :: xs) = Nat.pair x (encode xs) + 1`. The two constructors below +name that layer as codes; no arithmetic property of the encoding is asserted +here. -/ + +/-- The encoded empty list. -/ +def codeListNil {n : ℕ} : Code n := + Code.zero n + +/-- The encoded list with head `dx` and tail `dt`. -/ +def codeListCons {n : ℕ} (dx dt : Code n) : Code n := + codeSucc (codePair dx dt) + +/-- The recursion that rebuilds an encoded list with one entry appended: at +recursion argument `i` the entry at index `length - (i + 1)` is consed onto the +list built so far, starting from the singleton `[dx]`. -/ +def codeListSnocCore {r : ℕ} (dlist dx : Code r) : Code (r + 1) := + codePrec (codeListCons dx (codeListNil (n := r))) + (codeListCons + (codeSub + (codeListGetOptional (codeLift (codeLift dlist)) + (codeSub (codeListLength (codeLift (codeLift dlist))) + (codeSucc (Code.proj (0 : Fin (r + 2)))))) + (codeConst 1)) + (Code.proj (1 : Fin (r + 2)))) + +/-- Append `dx` to the end of the encoded list `dlist`. -/ +def codeListSnoc {r : ℕ} (dlist dx : Code r) : Code r := + codeBind (codeListLength dlist) (codeListSnocCore dlist dx) + +/-- `codeListSnoc` binds the length of its list argument as the recursion +argument of one fixed arity-`r + 1` code. + +The recursion is an implementation detail and stays private; a proof reaches it +by rewriting with this equation. -/ +theorem codeListSnoc_eq_bind {r : ℕ} (dlist dx : Code r) : + codeListSnoc dlist dx = + codeBind (codeListLength dlist) + (codePrec (codeListCons dx (codeListNil (n := r))) + (codeListCons + (codeSub + (codeListGetOptional (codeLift (codeLift dlist)) + (codeSub (codeListLength (codeLift (codeLift dlist))) + (codeSucc (Code.proj (0 : Fin (r + 2)))))) + (codeConst 1)) + (Code.proj (1 : Fin (r + 2))))) := + rfl + +end ArithmeticCode +end CategoricalRiceShapiro + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/EncodedListEvaluation.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/EncodedListEvaluation.lean new file mode 100644 index 000000000..49fa0dc31 --- /dev/null +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/EncodedListEvaluation.lean @@ -0,0 +1,499 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.EncodedList +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.RecursionEvaluation + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# Evaluation existence for the encoded-list codes + +`EncodedList` defines the codes that act on an encoded list; this file proves +that the five public operations below have a value in an arbitrary model, given +the evaluations required by their arguments. Their public conclusions assert +only existence: nothing here decodes an arbitrary model element as a list or +identifies its semantic list contents. Exact private evaluations of the head, +tail and iterated tail are used internally to establish that existence. + +Cons needs no induction: its eager conditional has two polynomial branches. +Option bind also needs no induction once the continuation is supplied at the +payload; because its conditional is eager, that evaluation is required even at +zero. Thus `𝐏𝐀⁻` suffices for both public existence theorems. The indexed +entry, the length and the appended list rest on the iterated tail, whose +termination is a `𝐏𝐀` statement. + +The iterated tail is `codePrec` with the list as base and one tail as step, so +`eval_codePrec_exists_of_total` gives it a value at every index. A separate +Sigma-one induction proves that, for `i ≤ l`, an iterated-tail value `z` satisfies +`z + i ≤ l`; hence the value at index `l` is zero. The length minimization +therefore terminates, by the Sigma-one least-number principle applied to the +indices whose iterated tail is zero. + +The head, tail and iterated tail lemmas stay private; the file exposes only the +five existence statements the evaluator layers consume. +-/ + +@[expose] public section + +open _root_.Nat Nat Nat.ArithPart₁ + +namespace CategoricalRiceShapiro +namespace ArithmeticCode + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +open scoped FFL.FirstOrder.Arithmetic + +open HierarchySymbol + +variable {M : Type*} [ORingStructure M] + +/-! +### The pairing and cons layers -/ + +/-- Cantor pairing has a value at any two values, without an induction +assumption: the two branches of the eager conditional are polynomials. -/ +private theorem eval_codePair_exists [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : ℕ} (A B : Code k) (a b : M) + (v : Fin k → M) (hA : Semiformula.Evalb (a :> v) (code A)) + (hB : Semiformula.Evalb (b :> v) (code B)) : + ∃ p : M, Semiformula.Evalb (p :> v) (code (codePair A B)) := + by + have hhigh : Semiformula.Evalb ((b * b + a) :> v) (code (codeAdd (codeMul B B) A)) := + (eval_codeAdd_iff _ _ _ _).mpr + ⟨b * b, a, (eval_codeMul_iff _ _ _ _).mpr ⟨b, b, hB, hB, rfl⟩, hA, rfl⟩ + have hlow : + Semiformula.Evalb ((a * a + a + b) :> v) (code (codeAdd (codeAdd (codeMul A A) A) B)) := + (eval_codeAdd_iff _ _ _ _).mpr + ⟨a * a + a, b, + (eval_codeAdd_iff _ _ _ _).mpr + ⟨a * a, a, (eval_codeMul_iff _ _ _ _).mpr ⟨a, a, hA, hA, rfl⟩, hA, rfl⟩, + hB, rfl⟩ + simp only [codePair] + by_cases hab : a < b + · exact + ⟨b * b + a, + eval_codeIfPos_of _ _ _ 1 (b * b + a) (a * a + a + b) (b * b + a) v + ((eval_codeLt_iff _ _ _ _).mpr ⟨a, b, hA, hB, Or.inl ⟨hab, rfl⟩⟩) hhigh hlow + (Or.inl ⟨by simp, rfl⟩)⟩ + · exact + ⟨a * a + a + b, + eval_codeIfPos_of _ _ _ 0 (b * b + a) (a * a + a + b) (a * a + a + b) v + ((eval_codeLt_iff _ _ _ _).mpr ⟨a, b, hA, hB, Or.inr ⟨hab, rfl⟩⟩) hhigh hlow + (Or.inr ⟨rfl, rfl⟩)⟩ + +/-! +### Head and tail -/ + +/-- The encoded head has a value at any value of its argument. -/ +private theorem eval_codeListHeadOptional_exists [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] {k : ℕ} (d : Code k) (x : M) + (v : Fin k → M) (hd : Semiformula.Evalb (x :> v) (code d)) : + ∃ z : M, Semiformula.Evalb (z :> v) (code (codeListHeadOptional d)) := + by + have hone : Semiformula.Evalb ((1 : M) :> v) (code (codeConst (n := k) 1)) := by + rw [eval_codeConst_iff]; simp + have hsub := eval_codeSub d (codeConst 1) x 1 v hd hone + have hsucc : + Semiformula.Evalb ((FFL.FirstOrder.Arithmetic.pi₁ (x - 1) + 1) :> v) + (code (codeSucc (codeUnpair₁ (codeSub d (codeConst 1))))) := + (eval_codeSucc_iff _ _ _).mpr + ⟨_, eval_codeUnpair₁ (codeSub d (codeConst 1)) (x - 1) v hsub, rfl⟩ + have hzero : Semiformula.Evalb ((0 : M) :> v) (code (Code.zero k)) := + (eval_zero_iff _ _).mpr rfl + simp only [codeListHeadOptional] + by_cases hx : 0 < x + · exact + ⟨_, + eval_codeIfPos_of _ _ _ x _ 0 (FFL.FirstOrder.Arithmetic.pi₁ (x - 1) + 1) v hd hsucc + hzero (Or.inl ⟨hx, rfl⟩)⟩ + · exact + ⟨0, + eval_codeIfPos_of _ _ _ x _ 0 0 v hd hsucc hzero + (Or.inr ⟨le_antisymm (not_lt.mp hx) (by simp), rfl⟩)⟩ + +/-- The encoded tail at a value, with its value displayed as the second Cantor +component of the predecessor. -/ +private theorem eval_codeListTail_value [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] {k : ℕ} (d : Code k) (x : M) + (v : Fin k → M) (hd : Semiformula.Evalb (x :> v) (code d)) : + Semiformula.Evalb ((FFL.FirstOrder.Arithmetic.pi₂ (x - 1)) :> v) (code (codeListTail d)) := + by + have hone : Semiformula.Evalb ((1 : M) :> v) (code (codeConst (n := k) 1)) := by + rw [eval_codeConst_iff]; simp + exact eval_codeUnpair₂ _ _ v (eval_codeSub d (codeConst 1) x 1 v hd hone) + +/-! +### The iterated-tail recursion -/ + +/-- The iterated-tail recursion that `codeListDrop` applies to its index and +its list. -/ +private def dropCore : Code 2 := + codePrec (Code.proj (0 : Fin 1)) (codeListTail (Code.proj (1 : Fin 3))) + +/-- `codeListDrop` applies `dropCore` to its two arguments. -/ +private theorem codeListDrop_eq_dropCore {n : ℕ} (dlist didx : Code n) : + codeListDrop dlist didx = dropCore.comp ![didx, dlist] := + rfl + +/-- The iterated tail has a value at every index and every list value. The +base is the list itself and the step is one tail, total at every value. -/ +private theorem eval_dropCore_exists [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] (i l : M) : + ∃ z : M, Semiformula.Evalb (z :> ![i, l]) (code dropCore) := + by + let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + exact + eval_codePrec_exists_of_total (Code.proj (0 : Fin 1)) (codeListTail (Code.proj (1 : Fin 3))) + i ![l] ⟨l, (eval_proj_iff _ _ _).mpr (by simp)⟩ + (fun j _ z => + ⟨_, + eval_codeListTail_value (Code.proj (1 : Fin 3)) z (j :> z :> ![l]) + ((eval_proj_iff _ _ _).mpr (by simp))⟩) + +/-- The iterated tail at evaluated list and index codes. -/ +private theorem eval_codeListDrop_exists [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] {n : ℕ} (dlist didx : Code n) (l i : M) + (v : Fin n → M) (hlist : Semiformula.Evalb (l :> v) (code dlist)) + (hidx : Semiformula.Evalb (i :> v) (code didx)) : + ∃ z : M, Semiformula.Evalb (z :> v) (code (codeListDrop dlist didx)) := + by + obtain ⟨z, hz⟩ := eval_dropCore_exists i l + refine ⟨z, ?_⟩ + rw [codeListDrop_eq_dropCore, eval_comp_iff] + refine ⟨![i, l], hz, ?_⟩ + intro j + refine Fin.cases ?_ ?_ j + · simpa using hidx + · intro j1 + refine Fin.cases ?_ (fun j2 => Fin.elim0 j2) j1 + simpa using hlist + +/-! +### Sigma-one definability of a literal code graph -/ + +open HierarchySymbol in +/-- Varying the first argument of the graph formula of a code, with the output +and the remaining arguments fixed as parameters, is a Sigma-one condition. -/ +private theorem definable_code_head_slot {m : ℕ} (A : Code (m + 1)) (out : M) + (par : Fin m → M) : + Σ-[1].DefinablePred (fun c : M => Semiformula.Evalb (out :> c :> par) (code A)) := + by + refine + ⟨HierarchySymbol.Semiformula.mkSigma + ((Rew.embSubsts + ((&out : Semiterm ℒₒᵣ M 1) :> + (#0 : Semiterm ℒₒᵣ M 1) :> fun j => (&(par j) : Semiterm ℒₒᵣ M 1))) ▹ + (code A)) + (Hierarchy.rew _ (code_sigma_one A)), + ?_⟩ + intro w + simp only [HierarchySymbol.Semiformula.val_mkSigma, Semiformula.eval_embSubsts] + have hv : + (Semiterm.val w id ∘ + ((&out : Semiterm ℒₒᵣ M 1) :> + (#0 : Semiterm ℒₒᵣ M 1) :> fun j => (&(par j) : Semiterm ℒₒᵣ M 1))) = + (out :> w 0 :> par) := + by + funext j + refine Fin.cases ?_ ?_ j + · simp + · intro j1 + refine Fin.cases ?_ ?_ j1 + · simp + · intro j2; simp + rw [hv] + +open HierarchySymbol in +/-- Varying the output and the first argument of the graph formula of a code, +with the remaining arguments fixed as parameters, is a Sigma-one condition. -/ +private theorem definable_code_out_head_slot {m : ℕ} (A : Code (m + 1)) (par : Fin m → M) : + Σ-[1].Definable (fun w : Fin 2 → M => Semiformula.Evalb (w 0 :> w 1 :> par) (code A)) := + by + refine + ⟨HierarchySymbol.Semiformula.mkSigma + ((Rew.embSubsts + ((#0 : Semiterm ℒₒᵣ M 2) :> + (#1 : Semiterm ℒₒᵣ M 2) :> fun j => (&(par j) : Semiterm ℒₒᵣ M 2))) ▹ + (code A)) + (Hierarchy.rew _ (code_sigma_one A)), + ?_⟩ + intro w + simp only [HierarchySymbol.Semiformula.val_mkSigma, Semiformula.eval_embSubsts] + have hv : + (Semiterm.val w id ∘ + ((#0 : Semiterm ℒₒᵣ M 2) :> + (#1 : Semiterm ℒₒᵣ M 2) :> fun j => (&(par j) : Semiterm ℒₒᵣ M 2))) = + (w 0 :> w 1 :> par) := + by + funext j + refine Fin.cases ?_ ?_ j + · simp + · intro j1 + refine Fin.cases ?_ ?_ j1 + · simp + · intro j2; simp + rw [hv] + +/-! +### The iterated tail decreases -/ + +/-- At every index up to the list value, the iterated tail has a value whose +sum with the index is bounded by the list value. + +The bound is what makes the minimization inside `codeListLength` terminate at an +arbitrary element of the model, well formed or not. -/ +private theorem dropCore_bound [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] (l : M) : + ∀ i : M, (∃ z : M, Semiformula.Evalb (z :> ![i, l]) (code dropCore) ∧ z + i ≤ l) ∨ l < i := + by + let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + have hgraph : + Σ-[1].Definable + (fun w : Fin 2 → M => + Semiformula.Evalb (w 0 :> ![w 1, l]) (code dropCore) ∧ w 0 + w 1 ≤ l) := + HierarchySymbol.Definable.and (definable_code_out_head_slot dropCore ![l]) (by definability) + have hdef : + Σ-[1].DefinablePred + (fun i : M => + (∃ z : M, Semiformula.Evalb (z :> ![i, l]) (code dropCore) ∧ z + i ≤ l) ∨ l < i) := + HierarchySymbol.Definable.or + (HierarchySymbol.Definable.exs (hgraph.of_iff (by intro w; simp))) (by definability) + refine InductionOnHierarchy.succ_induction Σ 1 hdef ?_ ?_ + · obtain ⟨z, hz⟩ := eval_dropCore_exists 0 l + have hzl : z = l := + (eval_proj_iff _ _ _).mp + (eval_codePrec_zero (Code.proj (0 : Fin 1)) (codeListTail (Code.proj (1 : Fin 3))) z + ![l] hz) + exact Or.inl ⟨z, hz, by rw [hzl]; simp⟩ + · intro i IH + by_cases hli : l < i + 1 + · exact Or.inr hli + · have hil : i + 1 ≤ l := not_lt.mp hli + obtain ⟨z, hz, hzi⟩ := + IH.resolve_right (not_lt.mpr (le_of_lt (lt_of_lt_of_le (by simp) hil))) + obtain ⟨z', hz'⟩ := eval_dropCore_exists (i + 1) l + obtain ⟨w, hw, hstep⟩ := + eval_codePrec_succ (Code.proj (0 : Fin 1)) (codeListTail (Code.proj (1 : Fin 3))) i z' + ![l] hz' + have hwz : w = z := eval_unique hw hz + have htail := + eval_codeListTail_value (Code.proj (1 : Fin 3)) z (i :> z :> ![l]) + ((eval_proj_iff _ _ _).mpr (by simp)) + have hz'val : z' = FFL.FirstOrder.Arithmetic.pi₂ (z - 1) := + by + rw [hwz] at hstep + exact eval_unique hstep htail + refine Or.inl ⟨z', hz', ?_⟩ + rcases eq_or_ne z 0 with hz0 | hz0 + · have : z' = 0 := by + rw [hz'val, hz0] + exact + le_antisymm (by simpa using FFL.FirstOrder.Arithmetic.pi₂_le_self ((0 : M) - 1)) + (by simp) + rw [this, zero_add] + exact hil + · have hone : 1 ≤ z := FFL.FirstOrder.Arithmetic.ne_zero_iff_one_le.mp hz0 + have hz'le : z' + 1 ≤ z := + by + have h1 : z' ≤ z - 1 := by + rw [hz'val] + exact FFL.FirstOrder.Arithmetic.pi₂_le_self _ + calc + z' + 1 ≤ (z - 1) + 1 := by simpa using h1 + _ = z := FFL.FirstOrder.Arithmetic.sub_add_self_of_le hone + calc + z' + (i + 1) = (z' + 1) + i := by simp [add_comm, add_left_comm] + _ ≤ z + i := by simpa using hz'le + _ ≤ l := hzi + +/-- The iterated tail at the list value itself is zero. -/ +private theorem eval_dropCore_zero_at_value [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] (l : M) : + Semiformula.Evalb ((0 : M) :> ![l, l]) (code dropCore) := + by + let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + obtain ⟨z, hz, hzl⟩ := (dropCore_bound l l).resolve_right (_root_.lt_irrefl l) + have hz0 : z = 0 := by + have h1 : z + l = l := le_antisymm hzl le_add_self + exact add_right_cancel (b := l) (by simpa using h1) + rwa [hz0] at hz + +/-! +### Local unfolding equations + +Rewriting with the definitions of `EncodedList` directly would make this module +generate their equation lemmas, moving ownership of those constants away from +the modules that already generate them. These `rfl` equations keep the +unfolding local. -/ + +/-- `codeListLength` written out. -/ +private theorem codeListLength_eq {n : ℕ} (dlist : Code n) : + codeListLength dlist = + codeRfindPos (codeInv (codeListDrop (codeLift dlist) (codeHead (n := n)))) := + rfl + +/-- `codeOptionBind` written out. -/ +private theorem codeOptionBind_eq {n : ℕ} (dopt : Code n) (dk : Code (n + 1)) : + codeOptionBind dopt dk = + codeIfPos dopt (codeBind (codeSub dopt (Code.one n)) dk) (Code.zero n) := + rfl + +/-! +### Evaluation existence for the encoded-list constructors -/ + +/-- The encoded cons cell has a value at any head and tail values. -/ +theorem eval_codeListCons_exists_of_values [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : ℕ} (A B : Code k) (a b : M) + (v : Fin k → M) (hA : Semiformula.Evalb (a :> v) (code A)) + (hB : Semiformula.Evalb (b :> v) (code B)) : + ∃ c : M, Semiformula.Evalb (c :> v) (code (codeListCons A B)) := + by + obtain ⟨p, hp⟩ := eval_codePair_exists A B a b v hA hB + exact ⟨p + 1, (eval_codeSucc_iff _ _ _).mpr ⟨p, hp, rfl⟩⟩ + +/-- The length minimization terminates at any list value. + +Nothing is asserted about the value found: for an arbitrary element of the model +it is the least index whose iterated tail is zero, which agrees with the number +of entries only on an actual encoded list. -/ +theorem eval_codeListLength_exists_of_value [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] {k : ℕ} (dlist : Code k) (l : M) + (v : Fin k → M) (hlist : Semiformula.Evalb (l :> v) (code dlist)) : + ∃ n : M, Semiformula.Evalb (n :> v) (code (codeListLength dlist)) := + by + let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + have hdrop : + ∀ t : M, + ∃ z : M, + Semiformula.Evalb (z :> t :> v) + (code (codeListDrop (codeLift dlist) (codeHead (n := k)))) := + fun t => + eval_codeListDrop_exists (codeLift dlist) (codeHead (n := k)) l t (t :> v) + ((eval_codeLift_iff _ _ _ _).mpr hlist) ((eval_codeHead_iff _ _).mpr rfl) + have hzeroL : + Semiformula.Evalb ((0 : M) :> l :> v) + (code (codeListDrop (codeLift dlist) (codeHead (n := k)))) := + by + rw [codeListDrop_eq_dropCore, eval_comp_iff] + refine ⟨![l, l], eval_dropCore_zero_at_value l, ?_⟩ + intro j + refine Fin.cases ?_ ?_ j + · simpa using (eval_codeHead_iff (k := k) l (l :> v)).mpr rfl + · intro j1 + refine Fin.cases ?_ (fun j2 => Fin.elim0 j2) j1 + simpa using (eval_codeLift_iff dlist l l v).mpr hlist + have hdef : + Σ-[1].DefinablePred + (fun t : M => + Semiformula.Evalb ((0 : M) :> t :> v) + (code (codeListDrop (codeLift dlist) (codeHead (n := k))))) := + definable_code_head_slot _ (0 : M) v + obtain ⟨t₀, ht₀, hmin⟩ := InductionOnHierarchy.least_number Σ 1 hdef hzeroL + refine ⟨t₀, ?_⟩ + rw [codeListLength_eq, eval_codeRfindPos_iff] + refine ⟨⟨1, by simp, (eval_codeInv_iff _ _ _).mpr ⟨0, ht₀, Or.inl ⟨rfl, rfl⟩⟩⟩, ?_⟩ + intro t ht + obtain ⟨z, hz⟩ := hdrop t + exact (eval_codeInv_iff _ _ _).mpr ⟨z, hz, Or.inr ⟨fun h0 => hmin t ht (h0 ▸ hz), rfl⟩⟩ + +/-- The indexed entry has a value at any list and index values: the iterated +tail terminates, and the encoded head is eager. -/ +theorem eval_codeListGetOptional_exists_of_values [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] {k : ℕ} (dlist didx : Code k) + (l i : M) (v : Fin k → M) (hlist : Semiformula.Evalb (l :> v) (code dlist)) + (hidx : Semiformula.Evalb (i :> v) (code didx)) : + ∃ z : M, Semiformula.Evalb (z :> v) (code (codeListGetOptional dlist didx)) := + by + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + obtain ⟨z, hz⟩ := eval_codeListDrop_exists dlist didx l i v hlist hidx + exact eval_codeListHeadOptional_exists (codeListDrop dlist didx) z v hz + +/-- Bind on an encoded option has a value once the continuation has one at the +payload of the supplied option value. + +The continuation premise is needed even when the option value is zero: the +conditional evaluates both branches. -/ +theorem eval_codeOptionBind_exists_of_value [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : ℕ} (dopt : Code k) + (dk : Code (k + 1)) (o : M) (v : Fin k → M) (hopt : Semiformula.Evalb (o :> v) (code dopt)) + (hk : ∃ y : M, Semiformula.Evalb (y :> (o - 1) :> v) (code dk)) : + ∃ z : M, Semiformula.Evalb (z :> v) (code (codeOptionBind dopt dk)) := + by + obtain ⟨y, hy⟩ := hk + have hone : Semiformula.Evalb ((1 : M) :> v) (code (Code.one k)) := (eval_one_iff _ _).mpr rfl + have hbind : Semiformula.Evalb (y :> v) (code (codeBind (codeSub dopt (Code.one k)) dk)) := + (eval_codeBind_iff _ _ _ _).mpr ⟨o - 1, eval_codeSub dopt (Code.one k) o 1 v hopt hone, hy⟩ + have hzero : Semiformula.Evalb ((0 : M) :> v) (code (Code.zero k)) := + (eval_zero_iff _ _).mpr rfl + rw [codeOptionBind_eq] + by_cases ho : 0 < o + · exact ⟨y, eval_codeIfPos_of _ _ _ o y 0 y v hopt hbind hzero (Or.inl ⟨ho, rfl⟩)⟩ + · exact + ⟨0, + eval_codeIfPos_of _ _ _ o y 0 0 v hopt hbind hzero + (Or.inr ⟨le_antisymm (not_lt.mp ho) (by simp), rfl⟩)⟩ + +/-- Appending one entry has a value at any list and entry values. + +The bound of the rebuilding recursion is the value of `codeListLength`, and its +step is total at every index up to and including that bound. -/ +theorem eval_codeListSnoc_exists_of_values [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] {k : ℕ} (dlist dx : Code k) (l x : M) + (v : Fin k → M) (hlist : Semiformula.Evalb (l :> v) (code dlist)) + (hx : Semiformula.Evalb (x :> v) (code dx)) : + ∃ s : M, Semiformula.Evalb (s :> v) (code (codeListSnoc dlist dx)) := + by + let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + obtain ⟨n, hn⟩ := eval_codeListLength_exists_of_value dlist l v hlist + have hbase : + ∃ z : M, Semiformula.Evalb (z :> v) (code (codeListCons dx (codeListNil (n := k)))) := + eval_codeListCons_exists_of_values dx (codeListNil (n := k)) x 0 v hx + ((eval_zero_iff _ _).mpr rfl) + have hstep : + ∀ i : M, + i ≤ n → + ∀ z : M, + ∃ w : M, + Semiformula.Evalb (w :> i :> z :> v) + (code + (codeListCons + (codeSub + (codeListGetOptional (codeLift (codeLift dlist)) + (codeSub (codeListLength (codeLift (codeLift dlist))) + (codeSucc (Code.proj (0 : Fin (k + 2)))))) + (codeConst 1)) + (Code.proj (1 : Fin (k + 2))))) := + by + intro i _ z + have hlist2 : Semiformula.Evalb (l :> i :> z :> v) (code (codeLift (codeLift dlist))) := + (eval_codeLift_iff (codeLift dlist) l i (z :> v)).mpr + ((eval_codeLift_iff dlist l z v).mpr hlist) + obtain ⟨n', hn'⟩ := + eval_codeListLength_exists_of_value (codeLift (codeLift dlist)) l (i :> z :> v) hlist2 + have hsucc : + Semiformula.Evalb ((i + 1) :> i :> z :> v) + (code (codeSucc (Code.proj (0 : Fin (k + 2))))) := + (eval_codeSucc_iff _ _ _).mpr ⟨i, (eval_proj_iff _ _ _).mpr rfl, rfl⟩ + have hrev := eval_codeSub _ _ n' (i + 1) (i :> z :> v) hn' hsucc + obtain ⟨g, hg⟩ := + eval_codeListGetOptional_exists_of_values (codeLift (codeLift dlist)) _ l (n' - (i + 1)) + (i :> z :> v) hlist2 hrev + have hone : Semiformula.Evalb ((1 : M) :> i :> z :> v) (code (codeConst (n := k + 2) 1)) := + by rw [eval_codeConst_iff]; simp + exact + eval_codeListCons_exists_of_values _ _ (g - 1) z (i :> z :> v) + (eval_codeSub _ _ g 1 (i :> z :> v) hg hone) ((eval_proj_iff _ _ _).mpr rfl) + obtain ⟨s, hs⟩ := eval_codePrec_exists_of_total _ _ n v hbase hstep + refine ⟨s, ?_⟩ + rw [codeListSnoc_eq_bind, eval_codeBind_iff] + exact ⟨n, hn, hs⟩ + +end ArithmeticCode +end CategoricalRiceShapiro + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/Evaluation.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/Evaluation.lean new file mode 100644 index 000000000..c5bf80f44 --- /dev/null +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/Evaluation.lean @@ -0,0 +1,492 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.Basic +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.FoundationCompat + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# Evaluation of arithmetic codes in an arbitrary model + +Every result in this module describes `Semiformula.Evalb` for the arithmetic +formula `FFL.FirstOrder.Arithmetic.code c` under an arbitrary assignment in an +arbitrary structure. + +Two results assume a model of `𝐏𝐀⁻`. `eval_codeConst` states the value of a +constant code, and needs that assumption already for the numeral cast +`(m : M)`. `eval_codeConst_iff` characterises that value, and additionally +uses evaluator functionality (`eval_unique`, proved in +`CategoricalRiceShapiro.ArithmeticCode.FoundationCompat`, which also assumes +`𝐏𝐀⁻`). Every other evaluation result in this module assumes only +`ORingStructure M`. + +The equivalences for the primitive constructors and for composition are the +reusable core; the derived constructors and the congruence law under a +composed-code context are proved from them. +-/ + +@[expose] public section + +open Nat.ArithPart₁ + +namespace CategoricalRiceShapiro +namespace ArithmeticCode + +open Encodable FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +open scoped FFL.FirstOrder.Arithmetic + +variable {M : Type*} [ORingStructure M] + +/-! +### Primitive constructors -/ + +theorem eval_zero_iff {k : ℕ} (z : M) (v : Fin k → M) : + Semiformula.Evalb (z :> v) (FFL.FirstOrder.Arithmetic.code (Code.zero k)) ↔ z = 0 := by + simp [FFL.FirstOrder.Arithmetic.code, FFL.FirstOrder.Arithmetic.codeAux, Function.comp_def, + Matrix.empty_eq] + +theorem eval_one_iff {k : ℕ} (z : M) (v : Fin k → M) : + Semiformula.Evalb (z :> v) (FFL.FirstOrder.Arithmetic.code (Code.one k)) ↔ z = 1 := by + simp [FFL.FirstOrder.Arithmetic.code, FFL.FirstOrder.Arithmetic.codeAux, Function.comp_def, + Matrix.empty_eq] + +theorem eval_proj_iff {k : ℕ} (i : Fin k) (z : M) (v : Fin k → M) : + Semiformula.Evalb (z :> v) (FFL.FirstOrder.Arithmetic.code (Code.proj i)) ↔ z = v i := by + simp [FFL.FirstOrder.Arithmetic.code, FFL.FirstOrder.Arithmetic.codeAux, Function.comp_def] + +theorem eval_add_iff {k : ℕ} (i j : Fin k) (z : M) (v : Fin k → M) : + Semiformula.Evalb (z :> v) (FFL.FirstOrder.Arithmetic.code (Code.add i j)) ↔ + z = v i + v j := + by + have hop : ((v i :> fun _ => v j) : Fin 2 → M) = ![v i, v j] := + by + funext x + refine Fin.cases ?_ ?_ x + · rfl + · intro y; simp + simp [FFL.FirstOrder.Arithmetic.code, FFL.FirstOrder.Arithmetic.codeAux, Function.comp_def, + Matrix.comp_vecCons', hop] + +theorem eval_mul_iff {k : ℕ} (i j : Fin k) (z : M) (v : Fin k → M) : + Semiformula.Evalb (z :> v) (FFL.FirstOrder.Arithmetic.code (Code.mul i j)) ↔ + z = v i * v j := + by + have hop : ((v i :> fun _ => v j) : Fin 2 → M) = ![v i, v j] := + by + funext x + refine Fin.cases ?_ ?_ x + · rfl + · intro y; simp + simp [FFL.FirstOrder.Arithmetic.code, FFL.FirstOrder.Arithmetic.codeAux, Function.comp_def, + Matrix.comp_vecCons', hop] + +theorem eval_equal_iff {k : ℕ} (i j : Fin k) (z : M) (v : Fin k → M) : + Semiformula.Evalb (z :> v) (FFL.FirstOrder.Arithmetic.code (Code.equal i j)) ↔ + ((v i = v j ∧ z = 1) ∨ (¬v i = v j ∧ z = 0)) := + by + simp [FFL.FirstOrder.Arithmetic.code, FFL.FirstOrder.Arithmetic.codeAux, Function.comp_def, + Matrix.empty_eq] + +theorem eval_lt_iff {k : ℕ} (i j : Fin k) (z : M) (v : Fin k → M) : + Semiformula.Evalb (z :> v) (FFL.FirstOrder.Arithmetic.code (Code.lt i j)) ↔ + ((v i < v j ∧ z = 1) ∨ (¬v i < v j ∧ z = 0)) := + by + simp [FFL.FirstOrder.Arithmetic.code, FFL.FirstOrder.Arithmetic.codeAux, Function.comp_def, + Matrix.empty_eq, -not_lt] + +/-! +### Composition -/ + +theorem eval_comp_iff {m k : ℕ} (c : Code m) (d : Fin m → Code k) (z : M) (v : Fin k → M) : + Semiformula.Evalb (z :> v) (FFL.FirstOrder.Arithmetic.code (Code.comp c d)) ↔ + ∃ w : Fin m → M, + Semiformula.Evalb (z :> w) (FFL.FirstOrder.Arithmetic.code c) ∧ + ∀ i : Fin m, Semiformula.Evalb (w i :> v) (FFL.FirstOrder.Arithmetic.code (d i)) := + by + simp [FFL.FirstOrder.Arithmetic.code, FFL.FirstOrder.Arithmetic.codeAux, Semiformula.eval_rew, + Function.comp_def, Matrix.empty_eq, Matrix.comp_vecCons'] + +theorem eval_comp₂_iff {k : ℕ} (c : Code 2) (A B : Code k) (z : M) (v : Fin k → M) : + Semiformula.Evalb (z :> v) (FFL.FirstOrder.Arithmetic.code (Code.comp c ![A, B])) ↔ + ∃ e : Fin 2 → M, + Semiformula.Evalb (z :> e) (FFL.FirstOrder.Arithmetic.code c) ∧ + Semiformula.Evalb (e 0 :> v) (FFL.FirstOrder.Arithmetic.code A) ∧ + Semiformula.Evalb (e 1 :> v) (FFL.FirstOrder.Arithmetic.code B) := + by + rw [eval_comp_iff] + simp [Fin.forall_fin_two] + +theorem eval_comp_congr {m k : ℕ} (c : Code m) (d e : Fin m → Code k) (z : M) (v : Fin k → M) + (h : + ∀ (i : Fin m) (x : M), + Semiformula.Evalb (x :> v) (FFL.FirstOrder.Arithmetic.code (d i)) ↔ + Semiformula.Evalb (x :> v) (FFL.FirstOrder.Arithmetic.code (e i))) : + Semiformula.Evalb (z :> v) (FFL.FirstOrder.Arithmetic.code (Code.comp c d)) ↔ + Semiformula.Evalb (z :> v) (FFL.FirstOrder.Arithmetic.code (Code.comp c e)) := + by + rw [eval_comp_iff, eval_comp_iff] + exact exists_congr fun w => and_congr_right fun _ => forall_congr' fun i => h i (w i) + +/-! +### Derived constructors -/ + +theorem eval_codeAdd_iff {k : ℕ} (A B : Code k) (z : M) (v : Fin k → M) : + Semiformula.Evalb (z :> v) (FFL.FirstOrder.Arithmetic.code (codeAdd A B)) ↔ + ∃ a b : M, + Semiformula.Evalb (a :> v) (FFL.FirstOrder.Arithmetic.code A) ∧ + Semiformula.Evalb (b :> v) (FFL.FirstOrder.Arithmetic.code B) ∧ z = a + b := + by + rw [codeAdd, eval_comp₂_iff] + constructor + · rintro ⟨e, he, hA, hB⟩ + exact ⟨e 0, e 1, hA, hB, (eval_add_iff 0 1 z e).mp he⟩ + · rintro ⟨a, b, hA, hB, hz⟩ + exact + ⟨![a, b], (eval_add_iff 0 1 z ![a, b]).mpr (by simpa using hz), by simpa using hA, by + simpa using hB⟩ + +theorem eval_codeMul_iff {k : ℕ} (A B : Code k) (z : M) (v : Fin k → M) : + Semiformula.Evalb (z :> v) (FFL.FirstOrder.Arithmetic.code (codeMul A B)) ↔ + ∃ a b : M, + Semiformula.Evalb (a :> v) (FFL.FirstOrder.Arithmetic.code A) ∧ + Semiformula.Evalb (b :> v) (FFL.FirstOrder.Arithmetic.code B) ∧ z = a * b := + by + rw [codeMul, eval_comp₂_iff] + constructor + · rintro ⟨e, he, hA, hB⟩ + exact ⟨e 0, e 1, hA, hB, (eval_mul_iff 0 1 z e).mp he⟩ + · rintro ⟨a, b, hA, hB, hz⟩ + exact + ⟨![a, b], (eval_mul_iff 0 1 z ![a, b]).mpr (by simpa using hz), by simpa using hA, by + simpa using hB⟩ + +theorem eval_codeEq_iff {k : ℕ} (A B : Code k) (z : M) (v : Fin k → M) : + Semiformula.Evalb (z :> v) (FFL.FirstOrder.Arithmetic.code (codeEq A B)) ↔ + ∃ a b : M, + Semiformula.Evalb (a :> v) (FFL.FirstOrder.Arithmetic.code A) ∧ + Semiformula.Evalb (b :> v) (FFL.FirstOrder.Arithmetic.code B) ∧ + ((a = b ∧ z = 1) ∨ (¬a = b ∧ z = 0)) := + by + rw [codeEq, eval_comp₂_iff] + constructor + · rintro ⟨e, he, hA, hB⟩ + exact ⟨e 0, e 1, hA, hB, (eval_equal_iff 0 1 z e).mp he⟩ + · rintro ⟨a, b, hA, hB, hcase⟩ + exact + ⟨![a, b], (eval_equal_iff 0 1 z ![a, b]).mpr (by simpa using hcase), by simpa using hA, by + simpa using hB⟩ + +theorem eval_codeLt_iff {k : ℕ} (A B : Code k) (z : M) (v : Fin k → M) : + Semiformula.Evalb (z :> v) (FFL.FirstOrder.Arithmetic.code (codeLt A B)) ↔ + ∃ a b : M, + Semiformula.Evalb (a :> v) (FFL.FirstOrder.Arithmetic.code A) ∧ + Semiformula.Evalb (b :> v) (FFL.FirstOrder.Arithmetic.code B) ∧ + ((a < b ∧ z = 1) ∨ (¬a < b ∧ z = 0)) := + by + rw [codeLt, eval_comp₂_iff] + constructor + · rintro ⟨e, he, hA, hB⟩ + exact ⟨e 0, e 1, hA, hB, (eval_lt_iff 0 1 z e).mp he⟩ + · rintro ⟨a, b, hA, hB, hcase⟩ + exact + ⟨![a, b], (eval_lt_iff 0 1 z ![a, b]).mpr (by simpa using hcase), by simpa using hA, by + simpa using hB⟩ + +theorem eval_codeSucc_iff {k : ℕ} (A : Code k) (z : M) (v : Fin k → M) : + Semiformula.Evalb (z :> v) (FFL.FirstOrder.Arithmetic.code (codeSucc A)) ↔ + ∃ a : M, Semiformula.Evalb (a :> v) (FFL.FirstOrder.Arithmetic.code A) ∧ z = a + 1 := + by + rw [codeSucc, eval_comp₂_iff] + constructor + · rintro ⟨e, he, hA, hB⟩ + have h1 : e 1 = 1 := (eval_one_iff (e 1) v).mp hB + refine ⟨e 0, hA, ?_⟩ + have hz := (eval_add_iff 0 1 z e).mp he + rw [h1] at hz + exact hz + · rintro ⟨a, hA, hz⟩ + exact + ⟨![a, 1], (eval_add_iff 0 1 z ![a, 1]).mpr (by simpa using hz), by simpa using hA, by + simpa using (eval_one_iff (1 : M) v).mpr rfl⟩ + +theorem eval_codePos_iff {k : ℕ} (A : Code k) (z : M) (v : Fin k → M) : + Semiformula.Evalb (z :> v) (FFL.FirstOrder.Arithmetic.code (codePos A)) ↔ + ∃ a : M, + Semiformula.Evalb (a :> v) (FFL.FirstOrder.Arithmetic.code A) ∧ + ((0 < a ∧ z = 1) ∨ (¬0 < a ∧ z = 0)) := + by + rw [codePos, eval_comp₂_iff] + constructor + · rintro ⟨e, he, h0, hA⟩ + have he0 : e 0 = 0 := (eval_zero_iff (e 0) v).mp h0 + refine ⟨e 1, hA, ?_⟩ + have hcase := (eval_lt_iff 0 1 z e).mp he + rw [he0] at hcase + exact hcase + · rintro ⟨a, hA, hcase⟩ + exact + ⟨![0, a], (eval_lt_iff 0 1 z ![0, a]).mpr (by simpa using hcase), by + simpa using (eval_zero_iff (0 : M) v).mpr rfl, by simpa using hA⟩ + +theorem eval_codeInv_iff {k : ℕ} (A : Code k) (z : M) (v : Fin k → M) : + Semiformula.Evalb (z :> v) (FFL.FirstOrder.Arithmetic.code (codeInv A)) ↔ + ∃ a : M, + Semiformula.Evalb (a :> v) (FFL.FirstOrder.Arithmetic.code A) ∧ + ((a = 0 ∧ z = 1) ∨ (¬a = 0 ∧ z = 0)) := + by + rw [codeInv, eval_comp₂_iff] + constructor + · rintro ⟨e, he, hA, h0⟩ + have he1 : e 1 = 0 := (eval_zero_iff (e 1) v).mp h0 + refine ⟨e 0, hA, ?_⟩ + have hcase := (eval_equal_iff 0 1 z e).mp he + rw [he1] at hcase + exact hcase + · rintro ⟨a, hA, hcase⟩ + exact + ⟨![a, 0], (eval_equal_iff 0 1 z ![a, 0]).mpr (by simpa using hcase), by simpa using hA, by + simpa using (eval_zero_iff (0 : M) v).mpr rfl⟩ + +theorem eval_codeAnd_iff {k : ℕ} (A B : Code k) (z : M) (v : Fin k → M) : + Semiformula.Evalb (z :> v) (FFL.FirstOrder.Arithmetic.code (codeAnd A B)) ↔ + ∃ a b : M, + Semiformula.Evalb (a :> v) (FFL.FirstOrder.Arithmetic.code A) ∧ + Semiformula.Evalb (b :> v) (FFL.FirstOrder.Arithmetic.code B) ∧ + ((0 < a * b ∧ z = 1) ∨ (¬0 < a * b ∧ z = 0)) := + by + rw [codeAnd, eval_comp₂_iff] + constructor + · rintro ⟨e, he, h0, hmul⟩ + have he0 : e 0 = 0 := (eval_zero_iff (e 0) v).mp h0 + obtain ⟨a, b, hA, hB, hab⟩ := + (eval_codeMul_iff A B (e 1) v).mp (by simpa only [codeMul] using hmul) + refine ⟨a, b, hA, hB, ?_⟩ + have hcase := (eval_lt_iff 0 1 z e).mp he + rw [he0, hab] at hcase + exact hcase + · rintro ⟨a, b, hA, hB, hcase⟩ + refine + ⟨![0, a * b], (eval_lt_iff 0 1 z ![0, a * b]).mpr (by simpa using hcase), by + simpa using (eval_zero_iff (0 : M) v).mpr rfl, ?_⟩ + have := (eval_codeMul_iff A B (a * b) v).mpr ⟨a, b, hA, hB, rfl⟩ + simpa only [codeMul, Matrix.cons_val_one, Matrix.head_cons, Matrix.cons_val_zero] using this + +theorem eval_codeOr_iff {k : ℕ} (A B : Code k) (z : M) (v : Fin k → M) : + Semiformula.Evalb (z :> v) (FFL.FirstOrder.Arithmetic.code (codeOr A B)) ↔ + ∃ a b : M, + Semiformula.Evalb (a :> v) (FFL.FirstOrder.Arithmetic.code A) ∧ + Semiformula.Evalb (b :> v) (FFL.FirstOrder.Arithmetic.code B) ∧ + ((0 < a + b ∧ z = 1) ∨ (¬0 < a + b ∧ z = 0)) := + by + rw [codeOr, eval_comp₂_iff] + constructor + · rintro ⟨e, he, h0, hadd⟩ + have he0 : e 0 = 0 := (eval_zero_iff (e 0) v).mp h0 + obtain ⟨a, b, hA, hB, hab⟩ := + (eval_codeAdd_iff A B (e 1) v).mp (by simpa only [codeAdd] using hadd) + refine ⟨a, b, hA, hB, ?_⟩ + have hcase := (eval_lt_iff 0 1 z e).mp he + rw [he0, hab] at hcase + exact hcase + · rintro ⟨a, b, hA, hB, hcase⟩ + refine + ⟨![0, a + b], (eval_lt_iff 0 1 z ![0, a + b]).mpr (by simpa using hcase), by + simpa using (eval_zero_iff (0 : M) v).mpr rfl, ?_⟩ + have := (eval_codeAdd_iff A B (a + b) v).mpr ⟨a, b, hA, hB, rfl⟩ + simpa only [codeAdd, Matrix.cons_val_one, Matrix.head_cons, Matrix.cons_val_zero] using this + +/-! +### Weakening and constants -/ + +theorem eval_codeHead_iff {k : ℕ} (z : M) (w : Fin (k + 1) → M) : + Semiformula.Evalb (z :> w) (FFL.FirstOrder.Arithmetic.code (codeHead (n := k))) ↔ z = w 0 := + eval_proj_iff (0 : Fin (k + 1)) z w + +theorem eval_codeLift_iff {k : ℕ} (d : Code k) (z t : M) (v : Fin k → M) : + Semiformula.Evalb (z :> (t :> v)) (FFL.FirstOrder.Arithmetic.code (codeLift d)) ↔ + Semiformula.Evalb (z :> v) (FFL.FirstOrder.Arithmetic.code d) := + by + simp only [Nat.succ_eq_add_one, code, Matrix.zero_cons_succ_eq_self, codeLift, codeAux, + Rew.hom_finitary2, Rew.bind_fvar, Matrix.cons_val_zero, Matrix.cons_val_succ, + Semiformula.eval_rew, Matrix.empty_eq, Function.comp_def, Semiterm.val_bvar, + Semiformula.eval_exsClosure, LogicalConnective.HomClass.map_and, Matrix.comp_vecCons', + Semiterm.val_fvar, Matrix.conj_hom_prop, Semiformula.eval_operator, Matrix.cons_val_fin_one, + Tarski.Structure.eq_iff_eq, Fin.isValue, Matrix.cons_val_one, LogicalConnective.Prop.and_eq] + constructor + · rintro ⟨w, hw, hi⟩ + have hwv : w = v := funext hi + rw [hwv] at hw + simpa using hw + · intro h + exact ⟨v, by simpa using h, fun i => rfl⟩ + +theorem eval_codeConst [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : ℕ} (m : ℕ) (v : Fin k → M) : + Semiformula.Evalb (((m : ℕ) : M) :> v) + (FFL.FirstOrder.Arithmetic.code (codeConst (n := k) m)) := + by + induction m with + | zero => + have h0 : (((0 : ℕ)) : M) = (0 : M) := by simp + rw [h0] + exact (eval_zero_iff (0 : M) v).mpr rfl + | succ p + ih => + have hcast : (((p + 1 : ℕ)) : M) = ((p : ℕ) : M) + 1 := by push_cast; rfl + rw [hcast, codeConst] + exact (eval_codeSucc_iff (codeConst (n := k) p) _ v).mpr ⟨((p : ℕ) : M), ih, rfl⟩ + +theorem eval_codeConst_iff [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : ℕ} (m : ℕ) (z : M) (v : Fin k → M) : + Semiformula.Evalb (z :> v) (FFL.FirstOrder.Arithmetic.code (codeConst (n := k) m)) ↔ + z = (m : M) := + by + constructor + · intro h + exact eval_unique h (eval_codeConst m v) + · intro h + rw [h] + exact eval_codeConst m v + +/-! +### Bridges between a graph and a constant -/ + +/-- A code whose graph holds at the standard value `m` under the assignment +`v` has, at that same assignment, exactly the graph of the constant code `m`. + +The hypothesis is one instance of the graph; functionality of evaluation turns +it into the full equivalence. -/ +theorem eval_iff_codeConst_of_eval {M : Type*} [ORingStructure M] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} + (d : Code r) (m : ℕ) (v : Fin r → M) (hd : Semiformula.Evalb ((m : M) :> v) (code d)) + (z : M) : + Semiformula.Evalb (z :> v) (code d) ↔ + Semiformula.Evalb (z :> v) (code (codeConst (n := r) m)) := + by + rw [eval_codeConst_iff] + constructor + · intro hz + exact eval_unique hz hd + · intro hz + rw [hz] + exact hd + +/-- Lifting a constant code past one argument is the constant code of the +larger arity. -/ +theorem eval_codeLift_codeConst_iff {M : Type*} [ORingStructure M] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} + (m : ℕ) (z t : M) (v : Fin r → M) : + Semiformula.Evalb (z :> t :> v) (code (codeLift (codeConst (n := r) m))) ↔ + Semiformula.Evalb (z :> t :> v) (code (codeConst (n := r + 1) m)) := + by rw [eval_codeLift_iff, eval_codeConst_iff, eval_codeConst_iff] + +/-! +### Valuation-local congruence for the derived constructors + +Each lemma below fixes one assignment `v` and transports an equivalence of the +argument codes, quantified over the possible argument values, to an equivalence +of the constructed codes. No assignment other than `v` occurs, and no model +assumption beyond `ORingStructure M` is used. Composition is already covered +by `eval_comp_congr`. -/ + +theorem eval_codeSucc_congr {k : ℕ} (A A' : Code k) (z : M) (v : Fin k → M) + (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) : + Semiformula.Evalb (z :> v) (code (codeSucc A)) ↔ + Semiformula.Evalb (z :> v) (code (codeSucc A')) := + by + rw [eval_codeSucc_iff, eval_codeSucc_iff] + exact exists_congr fun a => and_congr (hA a) Iff.rfl + +theorem eval_codePos_congr {k : ℕ} (A A' : Code k) (z : M) (v : Fin k → M) + (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) : + Semiformula.Evalb (z :> v) (code (codePos A)) ↔ + Semiformula.Evalb (z :> v) (code (codePos A')) := + by + rw [eval_codePos_iff, eval_codePos_iff] + exact exists_congr fun a => and_congr (hA a) Iff.rfl + +theorem eval_codeInv_congr {k : ℕ} (A A' : Code k) (z : M) (v : Fin k → M) + (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) : + Semiformula.Evalb (z :> v) (code (codeInv A)) ↔ + Semiformula.Evalb (z :> v) (code (codeInv A')) := + by + rw [eval_codeInv_iff, eval_codeInv_iff] + exact exists_congr fun a => and_congr (hA a) Iff.rfl + +theorem eval_codeAdd_congr {k : ℕ} (A A' B B' : Code k) (z : M) (v : Fin k → M) + (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) + (hB : ∀ x : M, Semiformula.Evalb (x :> v) (code B) ↔ Semiformula.Evalb (x :> v) (code B')) : + Semiformula.Evalb (z :> v) (code (codeAdd A B)) ↔ + Semiformula.Evalb (z :> v) (code (codeAdd A' B')) := + by + rw [eval_codeAdd_iff, eval_codeAdd_iff] + exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) + +theorem eval_codeMul_congr {k : ℕ} (A A' B B' : Code k) (z : M) (v : Fin k → M) + (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) + (hB : ∀ x : M, Semiformula.Evalb (x :> v) (code B) ↔ Semiformula.Evalb (x :> v) (code B')) : + Semiformula.Evalb (z :> v) (code (codeMul A B)) ↔ + Semiformula.Evalb (z :> v) (code (codeMul A' B')) := + by + rw [eval_codeMul_iff, eval_codeMul_iff] + exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) + +theorem eval_codeEq_congr {k : ℕ} (A A' B B' : Code k) (z : M) (v : Fin k → M) + (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) + (hB : ∀ x : M, Semiformula.Evalb (x :> v) (code B) ↔ Semiformula.Evalb (x :> v) (code B')) : + Semiformula.Evalb (z :> v) (code (codeEq A B)) ↔ + Semiformula.Evalb (z :> v) (code (codeEq A' B')) := + by + rw [eval_codeEq_iff, eval_codeEq_iff] + exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) + +theorem eval_codeLt_congr {k : ℕ} (A A' B B' : Code k) (z : M) (v : Fin k → M) + (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) + (hB : ∀ x : M, Semiformula.Evalb (x :> v) (code B) ↔ Semiformula.Evalb (x :> v) (code B')) : + Semiformula.Evalb (z :> v) (code (codeLt A B)) ↔ + Semiformula.Evalb (z :> v) (code (codeLt A' B')) := + by + rw [eval_codeLt_iff, eval_codeLt_iff] + exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) + +theorem eval_codeAnd_congr {k : ℕ} (A A' B B' : Code k) (z : M) (v : Fin k → M) + (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) + (hB : ∀ x : M, Semiformula.Evalb (x :> v) (code B) ↔ Semiformula.Evalb (x :> v) (code B')) : + Semiformula.Evalb (z :> v) (code (codeAnd A B)) ↔ + Semiformula.Evalb (z :> v) (code (codeAnd A' B')) := + by + rw [eval_codeAnd_iff, eval_codeAnd_iff] + exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) + +theorem eval_codeOr_congr {k : ℕ} (A A' B B' : Code k) (z : M) (v : Fin k → M) + (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) + (hB : ∀ x : M, Semiformula.Evalb (x :> v) (code B) ↔ Semiformula.Evalb (x :> v) (code B')) : + Semiformula.Evalb (z :> v) (code (codeOr A B)) ↔ + Semiformula.Evalb (z :> v) (code (codeOr A' B')) := + by + rw [eval_codeOr_iff, eval_codeOr_iff] + exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) + +/-- An equivalence at `v` lifts to an equivalence at every assignment extending +`v` by one value. -/ +theorem eval_codeLift_congr {k : ℕ} (A A' : Code k) (z t : M) (v : Fin k → M) + (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) : + Semiformula.Evalb (z :> t :> v) (code (codeLift A)) ↔ + Semiformula.Evalb (z :> t :> v) (code (codeLift A')) := + by + rw [eval_codeLift_iff, eval_codeLift_iff] + exact hA z + +end ArithmeticCode +end CategoricalRiceShapiro + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/EvaluationCongruence.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/EvaluationCongruence.lean new file mode 100644 index 000000000..ad41b8d4b --- /dev/null +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/EvaluationCongruence.lean @@ -0,0 +1,629 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.Evaluation +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.EncodedList +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.Pairing + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# Valuation-local congruence for the minimized constructors + +`CategoricalRiceShapiro.ArithmeticCode.Evaluation` proves congruence at a fixed +assignment for composition and for the constructors built directly from the +primitives. This module continues the same discipline through the constructors +defined by minimization. + +Every statement fixes one assignment `v`, quantifies the hypothesis over the +possible values of the argument codes, and assumes only `ORingStructure M`. No +result here assumes `𝐏𝐀⁻`, and none quantifies over assignments. + +The minimization step is the substantive one. `Nat.ArithPart₁.Code.rfind` +translates to a conjunction of two occurrences of the body formula, one at the +found value and one under a bounded quantifier, and an equivalence of bodies at +every extended assignment transports both. +-/ + +@[expose] public section + +open _root_.Nat Nat Nat.ArithPart₁ + +namespace CategoricalRiceShapiro +namespace ArithmeticCode + +open Encodable FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +open scoped FFL.FirstOrder.Arithmetic + +variable {M : Type*} [ORingStructure M] + +/-! +### Minimization -/ + +/-- `code` differs from `codeAux` by a renaming that evaluation absorbs. -/ +private theorem evalb_iff_evalf {k : ℕ} (c : Code k) (z : M) (w : Fin k → M) : + Semiformula.Evalb (z :> w) (code c) ↔ Semiformula.Evalf (M := M) (z :> w) (codeAux c) := by + simp [code, Semiformula.eval_rew, Matrix.empty_eq, Function.comp_def] + +/-- Evaluation of a search for a zero: the body vanishes at the found value, +and below it the body is somewhere nonzero. -/ +private theorem eval_rfind_iff {k : ℕ} (c : Code (k + 1)) (z : M) (v : Fin k → M) : + Semiformula.Evalb (z :> v) (code (Code.rfind c)) ↔ + (Semiformula.Evalb ((0 : M) :> z :> v) (code c) ∧ + ∀ t : M, t < z → ∃ x : M, x ≠ 0 ∧ Semiformula.Evalb (x :> t :> v) (code c)) := + by + simp only [evalb_iff_evalf] + simp [codeAux, Semiformula.eval_rew, Function.comp_def, Matrix.empty_eq, Matrix.comp_vecCons'] + +/-- Equivalent search bodies determine equivalent searches. -/ +private theorem eval_rfind_congr {k : ℕ} (c c' : Code (k + 1)) (z : M) (v : Fin k → M) + (h : + ∀ x t : M, + Semiformula.Evalb (x :> t :> v) (code c) ↔ Semiformula.Evalb (x :> t :> v) (code c')) : + Semiformula.Evalb (z :> v) (code (Code.rfind c)) ↔ + Semiformula.Evalb (z :> v) (code (Code.rfind c')) := + by + rw [eval_rfind_iff, eval_rfind_iff] + exact + and_congr (h 0 z) + (forall_congr' fun t => + imp_congr Iff.rfl (exists_congr fun x => and_congr Iff.rfl (h x t))) + +/-- Evaluation of a substitution: the body holds at the value the substituted +code takes. + +`codeBind` is a composition whose argument vector is the substituted code +followed by the projections, so this is `eval_comp_iff` with that vector +identified. -/ +theorem eval_codeBind_iff {n : ℕ} (dg : Code n) (dc : Code (n + 1)) (y : M) (v : Fin n → M) : + Semiformula.Evalb (y :> v) (code (codeBind dg dc)) ↔ + ∃ x : M, + Semiformula.Evalb (x :> v) (code dg) ∧ Semiformula.Evalb (y :> x :> v) (code dc) := + by + simp only [codeBind] + rw [eval_comp_iff] + constructor + · rintro ⟨w, hc, hi⟩ + have hw : w = (w 0 :> v) := by + funext i + refine Fin.cases rfl ?_ i + intro j + have hj := hi j.succ + simp only [Fin.cases_succ] at hj + have : w j.succ = v j := (eval_proj_iff j (w j.succ) v).mp hj + simpa using this + refine ⟨w 0, by simpa using hi 0, ?_⟩ + rw [hw] at hc + exact hc + · rintro ⟨x, hg, hy⟩ + refine ⟨x :> v, hy, ?_⟩ + intro i + refine Fin.cases ?_ ?_ i + · simpa using hg + · intro j + simp only [Fin.cases_succ] + exact (eval_proj_iff j _ v).mpr (by simp) + +/-- Evaluation of a minimization: the body is positive somewhere at the found +value, and vanishes at every smaller one. + +`codeRfindPos` searches for the least argument at which its body is positive, +which `Code.rfind` reaches by inverting the body twice. This states the search +directly in terms of the body, and is the form every use below needs. -/ +theorem eval_codeRfindPos_iff [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : ℕ} (d : Code (k + 1)) (s : M) + (v : Fin k → M) : + Semiformula.Evalb (s :> v) (code (codeRfindPos d)) ↔ + ((∃ a : M, 0 < a ∧ Semiformula.Evalb (a :> s :> v) (code d)) ∧ + ∀ t : M, t < s → Semiformula.Evalb ((0 : M) :> t :> v) (code d)) := + by + have hinv : + ∀ (w : M) (u : Fin (k + 1) → M), + Semiformula.Evalb (w :> u) (code (codeInv (codePos d))) ↔ + ((w = 1 ∧ Semiformula.Evalb ((0 : M) :> u) (code d)) ∨ + (w = 0 ∧ ∃ a : M, 0 < a ∧ Semiformula.Evalb (a :> u) (code d))) := + by + intro w u + rw [eval_codeInv_iff] + constructor + · rintro ⟨p, hp, hcase⟩ + rw [eval_codePos_iff] at hp + obtain ⟨b, hb, hbcase⟩ := hp + rcases hbcase with ⟨hbpos, rfl⟩ | ⟨hbnpos, rfl⟩ + · rcases hcase with ⟨h10, _⟩ | ⟨_, rfl⟩ + · exact absurd h10.symm _root_.zero_ne_one + · exact Or.inr ⟨rfl, b, hbpos, hb⟩ + · rcases hcase with ⟨_, rfl⟩ | ⟨h00, _⟩ + · refine Or.inl ⟨rfl, ?_⟩ + have : b = 0 := le_antisymm (not_lt.mp hbnpos) (by simp) + rwa [this] at hb + · exact absurd rfl h00 + · rintro (⟨rfl, hd⟩ | ⟨rfl, a, hapos, ha⟩) + · refine ⟨0, ?_, Or.inl ⟨rfl, rfl⟩⟩ + rw [eval_codePos_iff] + exact ⟨0, hd, Or.inr ⟨by simp, rfl⟩⟩ + · refine ⟨1, ?_, Or.inr ⟨_root_.one_ne_zero, rfl⟩⟩ + rw [eval_codePos_iff] + exact ⟨a, ha, Or.inl ⟨hapos, rfl⟩⟩ + simp only [codeRfindPos] + rw [eval_rfind_iff] + refine and_congr ?_ ?_ + · rw [hinv] + constructor + · rintro (⟨h01, _⟩ | ⟨_, h⟩) + · exact absurd h01 (Ne.symm _root_.one_ne_zero) + · exact h + · intro h + exact Or.inr ⟨rfl, h⟩ + · refine forall_congr' fun t => imp_congr Iff.rfl ?_ + constructor + · rintro ⟨x, hx0, hx⟩ + rw [hinv] at hx + rcases hx with ⟨_, hd⟩ | ⟨rfl, _⟩ + · exact hd + · exact absurd rfl hx0 + · intro hd + exact ⟨1, _root_.one_ne_zero, (hinv 1 (t :> v)).mpr (Or.inl ⟨rfl, hd⟩)⟩ + +/-- Equivalent bodies determine equivalent minimizations. + +This is the congruence law for the minimization context, stated at the +assignment `v` and quantified over the value and the search argument. -/ +theorem eval_codeRfindPos_congr {k : ℕ} (A A' : Code (k + 1)) (z : M) (v : Fin k → M) + (hA : + ∀ x t : M, + Semiformula.Evalb (x :> t :> v) (code A) ↔ Semiformula.Evalb (x :> t :> v) (code A')) : + Semiformula.Evalb (z :> v) (code (codeRfindPos A)) ↔ + Semiformula.Evalb (z :> v) (code (codeRfindPos A')) := + by + simp only [codeRfindPos] + refine eval_rfind_congr _ _ z v ?_ + intro x t + exact + eval_codeInv_congr _ _ x (t :> v) + (fun y => eval_codePos_congr _ _ y (t :> v) (fun w => hA w t)) + +/-! +### Constructors defined by minimization -/ + +theorem eval_codeSub_congr {k : ℕ} (A A' B B' : Code k) (z : M) (v : Fin k → M) + (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) + (hB : ∀ x : M, Semiformula.Evalb (x :> v) (code B) ↔ Semiformula.Evalb (x :> v) (code B')) : + Semiformula.Evalb (z :> v) (code (codeSub A B)) ↔ + Semiformula.Evalb (z :> v) (code (codeSub A' B')) := + by + simp only [codeSub] + refine eval_codeRfindPos_congr _ _ z v ?_ + intro x t + refine eval_codeOr_congr _ _ _ _ x (t :> v) ?_ ?_ + · intro y + exact + eval_codeEq_congr _ _ _ _ y (t :> v) + (fun w => + eval_codeAdd_congr _ _ _ _ w (t :> v) (fun _ => Iff.rfl) + (fun u => eval_codeLift_congr B B' u t v hB)) + (fun w => eval_codeLift_congr A A' w t v hA) + · intro y + exact + eval_codeAnd_congr _ _ _ _ y (t :> v) + (fun w => + eval_codeLt_congr _ _ _ _ w (t :> v) (fun u => eval_codeLift_congr A A' u t v hA) + (fun u => eval_codeLift_congr B B' u t v hB)) + (fun _ => Iff.rfl) + +theorem eval_codeSqrt_congr {k : ℕ} (A A' : Code k) (z : M) (v : Fin k → M) + (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) : + Semiformula.Evalb (z :> v) (code (codeSqrt A)) ↔ + Semiformula.Evalb (z :> v) (code (codeSqrt A')) := + by + simp only [codeSqrt] + refine eval_codeRfindPos_congr _ _ z v ?_ + intro x t + refine eval_codeAnd_congr _ _ _ _ x (t :> v) ?_ ?_ + · intro y + exact + eval_codeOr_congr _ _ _ _ y (t :> v) + (fun w => + eval_codeLt_congr _ _ _ _ w (t :> v) (fun _ => Iff.rfl) + (fun u => eval_codeLift_congr A A' u t v hA)) + (fun w => + eval_codeEq_congr _ _ _ _ w (t :> v) (fun _ => Iff.rfl) + (fun u => eval_codeLift_congr A A' u t v hA)) + · intro y + exact + eval_codeLt_congr _ _ _ _ y (t :> v) (fun u => eval_codeLift_congr A A' u t v hA) + (fun _ => Iff.rfl) + +theorem eval_codeIfPos_congr {k : ℕ} (F F' G G' H H' : Code k) (z : M) (v : Fin k → M) + (hF : ∀ x : M, Semiformula.Evalb (x :> v) (code F) ↔ Semiformula.Evalb (x :> v) (code F')) + (hG : ∀ x : M, Semiformula.Evalb (x :> v) (code G) ↔ Semiformula.Evalb (x :> v) (code G')) + (hH : ∀ x : M, Semiformula.Evalb (x :> v) (code H) ↔ Semiformula.Evalb (x :> v) (code H')) : + Semiformula.Evalb (z :> v) (code (codeIfPos F G H)) ↔ + Semiformula.Evalb (z :> v) (code (codeIfPos F' G' H')) := + by + simp only [codeIfPos] + exact + eval_codeAdd_congr _ _ _ _ z v + (fun x => eval_codeMul_congr _ _ _ _ x v (fun y => eval_codePos_congr _ _ y v hF) hG) + (fun x => eval_codeMul_congr _ _ _ _ x v (fun y => eval_codeInv_congr _ _ y v hF) hH) + +theorem eval_codeUnpair₁_congr {k : ℕ} (A A' : Code k) (z : M) (v : Fin k → M) + (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) : + Semiformula.Evalb (z :> v) (code (codeUnpair₁ A)) ↔ + Semiformula.Evalb (z :> v) (code (codeUnpair₁ A')) := + by + have hsq : + ∀ x : M, + Semiformula.Evalb (x :> v) (code (codeSqrt A)) ↔ + Semiformula.Evalb (x :> v) (code (codeSqrt A')) := + fun x => eval_codeSqrt_congr A A' x v hA + have hdiff : + ∀ x : M, + Semiformula.Evalb (x :> v) (code (codeSub A (codeMul (codeSqrt A) (codeSqrt A)))) ↔ + Semiformula.Evalb (x :> v) (code (codeSub A' (codeMul (codeSqrt A') (codeSqrt A')))) := + fun x => eval_codeSub_congr _ _ _ _ x v hA (fun y => eval_codeMul_congr _ _ _ _ y v hsq hsq) + simp only [codeUnpair₁] + exact + eval_codeIfPos_congr _ _ _ _ _ _ z v (fun x => eval_codeLt_congr _ _ _ _ x v hdiff hsq) + hdiff hsq + +theorem eval_codeUnpair₂_congr {k : ℕ} (A A' : Code k) (z : M) (v : Fin k → M) + (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) : + Semiformula.Evalb (z :> v) (code (codeUnpair₂ A)) ↔ + Semiformula.Evalb (z :> v) (code (codeUnpair₂ A')) := + by + have hsq : + ∀ x : M, + Semiformula.Evalb (x :> v) (code (codeSqrt A)) ↔ + Semiformula.Evalb (x :> v) (code (codeSqrt A')) := + fun x => eval_codeSqrt_congr A A' x v hA + have hdiff : + ∀ x : M, + Semiformula.Evalb (x :> v) (code (codeSub A (codeMul (codeSqrt A) (codeSqrt A)))) ↔ + Semiformula.Evalb (x :> v) (code (codeSub A' (codeMul (codeSqrt A') (codeSqrt A')))) := + fun x => eval_codeSub_congr _ _ _ _ x v hA (fun y => eval_codeMul_congr _ _ _ _ y v hsq hsq) + simp only [codeUnpair₂] + exact + eval_codeIfPos_congr _ _ _ _ _ _ z v (fun x => eval_codeLt_congr _ _ _ _ x v hdiff hsq) hsq + (fun x => eval_codeSub_congr _ _ _ _ x v hdiff hsq) + +/-! +### Pairing -/ + +theorem eval_codePair_congr {k : ℕ} (A A' B B' : Code k) (z : M) (v : Fin k → M) + (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) + (hB : ∀ x : M, Semiformula.Evalb (x :> v) (code B) ↔ Semiformula.Evalb (x :> v) (code B')) : + Semiformula.Evalb (z :> v) (code (codePair A B)) ↔ + Semiformula.Evalb (z :> v) (code (codePair A' B')) := + by + simp only [codePair] + exact + eval_codeIfPos_congr _ _ _ _ _ _ z v (fun x => eval_codeLt_congr _ _ _ _ x v hA hB) + (fun x => + eval_codeAdd_congr _ _ _ _ x v (fun y => eval_codeMul_congr _ _ _ _ y v hB hB) hA) + (fun x => + eval_codeAdd_congr _ _ _ _ x v + (fun y => + eval_codeAdd_congr _ _ _ _ y v (fun w => eval_codeMul_congr _ _ _ _ w v hA hA) hA) + hB) + +/-! +### Encoded lists -/ + +theorem eval_codeListHeadOptional_congr {k : ℕ} (A A' : Code k) (z : M) (v : Fin k → M) + (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) : + Semiformula.Evalb (z :> v) (code (codeListHeadOptional A)) ↔ + Semiformula.Evalb (z :> v) (code (codeListHeadOptional A')) := + by + simp only [codeListHeadOptional] + exact + eval_codeIfPos_congr _ _ _ _ _ _ z v hA + (fun x => + eval_codeSucc_congr _ _ x v + (fun y => + eval_codeUnpair₁_congr _ _ y v + (fun w => eval_codeSub_congr _ _ _ _ w v hA (fun _ => Iff.rfl)))) + (fun _ => Iff.rfl) + +theorem eval_codeListTail_congr {k : ℕ} (A A' : Code k) (z : M) (v : Fin k → M) + (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) : + Semiformula.Evalb (z :> v) (code (codeListTail A)) ↔ + Semiformula.Evalb (z :> v) (code (codeListTail A')) := + by + simp only [codeListTail] + exact + eval_codeUnpair₂_congr _ _ z v + (fun x => eval_codeSub_congr _ _ _ _ x v hA (fun _ => Iff.rfl)) + +theorem eval_codeListDrop_congr {k : ℕ} (L L' I I' : Code k) (z : M) (v : Fin k → M) + (hL : ∀ x : M, Semiformula.Evalb (x :> v) (code L) ↔ Semiformula.Evalb (x :> v) (code L')) + (hI : ∀ x : M, Semiformula.Evalb (x :> v) (code I) ↔ Semiformula.Evalb (x :> v) (code I')) : + Semiformula.Evalb (z :> v) (code (codeListDrop L I)) ↔ + Semiformula.Evalb (z :> v) (code (codeListDrop L' I')) := + by + rw [codeListDrop_eq_comp, codeListDrop_eq_comp] + refine eval_comp_congr _ _ _ z v ?_ + refine Fin.forall_fin_two.mpr ⟨?_, ?_⟩ + · intro x + simpa using hI x + · intro x + simpa using hL x + +theorem eval_codeListGetOptional_congr {k : ℕ} (L L' I I' : Code k) (z : M) (v : Fin k → M) + (hL : ∀ x : M, Semiformula.Evalb (x :> v) (code L) ↔ Semiformula.Evalb (x :> v) (code L')) + (hI : ∀ x : M, Semiformula.Evalb (x :> v) (code I) ↔ Semiformula.Evalb (x :> v) (code I')) : + Semiformula.Evalb (z :> v) (code (codeListGetOptional L I)) ↔ + Semiformula.Evalb (z :> v) (code (codeListGetOptional L' I')) := + by + simp only [codeListGetOptional] + exact + eval_codeListHeadOptional_congr _ _ z v + (fun x => eval_codeListDrop_congr L L' I I' x v hL hI) + +/-! +### Congruence across two arities and two assignments + +The congruence laws above compare two codes of one arity under one assignment. +Relating an entry that `codePrec` reads with the entry its step relation supplies +needs more: the two `codeBeta` applications there have different argument codes, +different arities and different assignments, and agree only through the values +their arguments take. `EvalEq` records exactly that agreement, and the closure +lemmas below propagate it. + +Nothing here evaluates a code in the model, and no arithmetic meaning is +attached to remainder, unpairing or `codeBeta`; each is delta-reduced as a syntax +tree. No arithmetic theory is assumed. -/ + +/-- Two codes have the same graph, each under its own assignment. -/ +private abbrev EvalEq {k l : ℕ} (A : Code k) (v : Fin k → M) (A' : Code l) (v' : Fin l → M) : + Prop := + ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v') (code A') + +private theorem evalEq_proj {k l : ℕ} (i : Fin k) (j : Fin l) (v : Fin k → M) (v' : Fin l → M) + (h : v i = v' j) : EvalEq (Code.proj i) v (Code.proj j) v' := + by + intro x + rw [eval_proj_iff, eval_proj_iff, h] + +private theorem evalEq_zero {k l : ℕ} (v : Fin k → M) (v' : Fin l → M) : + EvalEq (Code.zero k) v (Code.zero l) v' := + by + intro x + rw [eval_zero_iff, eval_zero_iff] + +private theorem evalEq_codeHead {k l : ℕ} (t : M) (v : Fin k → M) (v' : Fin l → M) : + EvalEq (codeHead (n := k)) (t :> v) (codeHead (n := l)) (t :> v') := + evalEq_proj 0 0 _ _ rfl + +private theorem evalEq_codeSucc {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') : EvalEq (codeSucc A) v (codeSucc A') v' := + by + intro x + rw [eval_codeSucc_iff, eval_codeSucc_iff] + exact exists_congr fun a => and_congr (hA a) Iff.rfl + +private theorem evalEq_codePos {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') : EvalEq (codePos A) v (codePos A') v' := + by + intro x + rw [eval_codePos_iff, eval_codePos_iff] + exact exists_congr fun a => and_congr (hA a) Iff.rfl + +private theorem evalEq_codeInv {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') : EvalEq (codeInv A) v (codeInv A') v' := + by + intro x + rw [eval_codeInv_iff, eval_codeInv_iff] + exact exists_congr fun a => and_congr (hA a) Iff.rfl + +private theorem evalEq_codeAdd {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : + EvalEq (codeAdd A B) v (codeAdd A' B') v' := + by + intro x + rw [eval_codeAdd_iff, eval_codeAdd_iff] + exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) + +private theorem evalEq_codeMul {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : + EvalEq (codeMul A B) v (codeMul A' B') v' := + by + intro x + rw [eval_codeMul_iff, eval_codeMul_iff] + exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) + +private theorem evalEq_codeEq {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : + EvalEq (codeEq A B) v (codeEq A' B') v' := + by + intro x + rw [eval_codeEq_iff, eval_codeEq_iff] + exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) + +private theorem evalEq_codeLt {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : + EvalEq (codeLt A B) v (codeLt A' B') v' := + by + intro x + rw [eval_codeLt_iff, eval_codeLt_iff] + exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) + +private theorem evalEq_codeAnd {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : + EvalEq (codeAnd A B) v (codeAnd A' B') v' := + by + intro x + rw [eval_codeAnd_iff, eval_codeAnd_iff] + exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) + +private theorem evalEq_codeOr {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : + EvalEq (codeOr A B) v (codeOr A' B') v' := + by + intro x + rw [eval_codeOr_iff, eval_codeOr_iff] + exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) + +/-- A lift ignores its head, so the two heads need not agree. -/ +private theorem evalEq_codeLift {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} + {v' : Fin l → M} (t t' : M) (hA : EvalEq A v A' v') : + EvalEq (codeLift A) (t :> v) (codeLift A') (t' :> v') := + by + intro x + rw [eval_codeLift_iff, eval_codeLift_iff] + exact hA x + +/-- The raw search, across two arities and assignments. -/ +private theorem eval_rfind_congr_at {k l : ℕ} (c : Code (k + 1)) (c' : Code (l + 1)) (z : M) + (v : Fin k → M) (v' : Fin l → M) + (h : + ∀ x t : M, + Semiformula.Evalb (x :> t :> v) (code c) ↔ Semiformula.Evalb (x :> t :> v') (code c')) : + Semiformula.Evalb (z :> v) (code (Code.rfind c)) ↔ + Semiformula.Evalb (z :> v') (code (Code.rfind c')) := + by + rw [eval_rfind_iff, eval_rfind_iff] + exact + and_congr (h 0 z) + (forall_congr' fun t => + imp_congr Iff.rfl (exists_congr fun x => and_congr Iff.rfl (h x t))) + +private theorem evalEq_codeRfindPos {k l : ℕ} {A : Code (k + 1)} {A' : Code (l + 1)} + {v : Fin k → M} {v' : Fin l → M} (hA : ∀ t : M, EvalEq A (t :> v) A' (t :> v')) : + EvalEq (codeRfindPos A) v (codeRfindPos A') v' := + by + intro x + simp only [codeRfindPos] + refine eval_rfind_congr_at _ _ x v v' ?_ + intro y t + exact evalEq_codeInv (evalEq_codePos (hA t)) y + +private theorem evalEq_codeBind {k l : ℕ} {dg : Code k} {dc : Code (k + 1)} {dg' : Code l} + {dc' : Code (l + 1)} {v : Fin k → M} {v' : Fin l → M} (hg : EvalEq dg v dg' v') + (hc : ∀ t : M, EvalEq dc (t :> v) dc' (t :> v')) : + EvalEq (codeBind dg dc) v (codeBind dg' dc') v' := + by + intro x + rw [eval_codeBind_iff, eval_codeBind_iff] + exact exists_congr fun t => and_congr (hg t) (hc t x) + +/-! +### The derived constructors, across two arities and assignments -/ + +private theorem evalEq_codeSub {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : + EvalEq (codeSub A B) v (codeSub A' B') v' := + by + simp only [codeSub] + refine evalEq_codeRfindPos (fun t => ?_) + exact + evalEq_codeOr + (evalEq_codeEq (evalEq_codeAdd (evalEq_codeHead t v v') (evalEq_codeLift t t hB)) + (evalEq_codeLift t t hA)) + (evalEq_codeAnd (evalEq_codeLt (evalEq_codeLift t t hA) (evalEq_codeLift t t hB)) + (evalEq_codeEq (evalEq_codeHead t v v') (evalEq_zero _ _))) + +private theorem evalEq_codeSqrt {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') : EvalEq (codeSqrt A) v (codeSqrt A') v' := + by + simp only [codeSqrt] + refine evalEq_codeRfindPos (fun t => ?_) + exact + evalEq_codeAnd + (evalEq_codeOr + (evalEq_codeLt (evalEq_codeMul (evalEq_codeHead t v v') (evalEq_codeHead t v v')) + (evalEq_codeLift t t hA)) + (evalEq_codeEq (evalEq_codeMul (evalEq_codeHead t v v') (evalEq_codeHead t v v')) + (evalEq_codeLift t t hA))) + (evalEq_codeLt (evalEq_codeLift t t hA) + (evalEq_codeMul (evalEq_codeSucc (evalEq_codeHead t v v')) + (evalEq_codeSucc (evalEq_codeHead t v v')))) + +private theorem evalEq_codeIfPos {k l : ℕ} {F G H : Code k} {F' G' H' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hF : EvalEq F v F' v') (hG : EvalEq G v G' v') (hH : EvalEq H v H' v') : + EvalEq (codeIfPos F G H) v (codeIfPos F' G' H') v' := + by + simp only [codeIfPos] + exact + evalEq_codeAdd (evalEq_codeMul (evalEq_codePos hF) hG) + (evalEq_codeMul (evalEq_codeInv hF) hH) + +private theorem evalEq_codeLe {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : + EvalEq (codeLe A B) v (codeLe A' B') v' := + by + simp only [codeLe] + exact evalEq_codeOr (evalEq_codeLt hA hB) (evalEq_codeEq hA hB) + +private theorem evalEq_codeUnpair₁ {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') : EvalEq (codeUnpair₁ A) v (codeUnpair₁ A') v' := + by + simp only [codeUnpair₁] + have hsq := evalEq_codeSqrt hA + have hdiff := evalEq_codeSub hA (evalEq_codeMul hsq hsq) + exact evalEq_codeIfPos (evalEq_codeLt hdiff hsq) hdiff hsq + +private theorem evalEq_codeUnpair₂ {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') : EvalEq (codeUnpair₂ A) v (codeUnpair₂ A') v' := + by + simp only [codeUnpair₂] + have hsq := evalEq_codeSqrt hA + have hdiff := evalEq_codeSub hA (evalEq_codeMul hsq hsq) + exact evalEq_codeIfPos (evalEq_codeLt hdiff hsq) hsq (evalEq_codeSub hdiff hsq) + +private theorem evalEq_codeDvd {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : + EvalEq (codeDvd A B) v (codeDvd A' B') v' := + by + simp only [codeDvd] + refine evalEq_codeBind (evalEq_codeRfindPos (fun t => ?_)) (fun t => ?_) + · exact + evalEq_codeOr + (evalEq_codeEq (evalEq_codeMul (evalEq_codeHead t v v') (evalEq_codeLift t t hA)) + (evalEq_codeLift t t hB)) + (evalEq_codeLt (evalEq_codeLift t t hB) (evalEq_codeHead t v v')) + · exact evalEq_codeLe (evalEq_codeHead t v v') (evalEq_codeLift t t hB) + +private theorem evalEq_codeRem {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : + EvalEq (codeRem A B) v (codeRem A' B') v' := + by + simp only [codeRem] + refine evalEq_codeRfindPos (fun t => ?_) + exact + evalEq_codeDvd (evalEq_codeLift t t hB) + (evalEq_codeSub (evalEq_codeLift t t hA) (evalEq_codeHead t v v')) + +/-- Two `codeBeta` applications agree whenever their argument codes do, even at +different arities and under different assignments. + +`codeBeta` is delta-reduced here as a syntax tree only; nothing evaluates it, and +no arithmetic meaning is attached to remainder or unpairing. -/ +theorem eval_codeBeta_congr_at {k l : ℕ} (N I : Code k) (N' I' : Code l) (z : M) (v : Fin k → M) + (v' : Fin l → M) + (hN : ∀ x : M, Semiformula.Evalb (x :> v) (code N) ↔ Semiformula.Evalb (x :> v') (code N')) + (hI : + ∀ x : M, Semiformula.Evalb (x :> v) (code I) ↔ Semiformula.Evalb (x :> v') (code I')) : + Semiformula.Evalb (z :> v) (code (codeBeta N I)) ↔ + Semiformula.Evalb (z :> v') (code (codeBeta N' I')) := + by + simp only [codeBeta] + exact + evalEq_codeRem (evalEq_codeUnpair₁ hN) + (evalEq_codeSucc (evalEq_codeMul (evalEq_codeSucc hI) (evalEq_codeUnpair₂ hN))) z + +end ArithmeticCode +end CategoricalRiceShapiro + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/FoundationCompat.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/FoundationCompat.lean new file mode 100644 index 000000000..864dc554b --- /dev/null +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/FoundationCompat.lean @@ -0,0 +1,116 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.R0.Representation + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# Compatibility results for Foundation's arithmetic codes + +Foundation defines `FFL.FirstOrder.Arithmetic.code`, the arithmetic formula +associated with a partial-recursive code `Nat.ArithPart₁.Code k`, together with +its auxiliary formula `codeAux`. Foundation's own uniqueness statements for +these formulas are dormant source at the recorded revision, so this module +supplies the corresponding active result. + +`eval_unique` states that the evaluation relation of an arithmetic code is +functional in every model of `𝐏𝐀⁻`, under an arbitrary assignment. +-/ + +@[expose] public section + +namespace CategoricalRiceShapiro +namespace ArithmeticCode + +open Encodable FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +open scoped FFL.FirstOrder.Arithmetic + +private theorem evalAux_unique {M : Type*} [ORingStructure M] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : ℕ} + {c : Nat.ArithPart₁.Code k} {v : Fin k → M} {z z' : M} + (hz : Semiformula.Evalf (M := M) (z :> v) (FFL.FirstOrder.Arithmetic.codeAux c)) + (hz' : Semiformula.Evalf (M := M) (z' :> v) (FFL.FirstOrder.Arithmetic.codeAux c)) : + z = z' := by + revert hz hz' + induction c generalizing z z' <;> simp only [Nat.succ_eq_add_one, codeAux, + Semiformula.eval_operator, Matrix.comp₂, Nat.reduceAdd, Semiterm.val_fvar, + Matrix.cons_val_zero, Semiterm.val_operator, Matrix.comp₀, + Tarski.Structure.numeral_eq_numeral, ORingStructure.zero_eq_zero, Tarski.Structure.eq_iff_eq, + Fin.isValue, Matrix.cons_val_one, Matrix.cons_val_fin_one, ORingStructure.one_eq_one, + Matrix.cons_val_succ, Tarski.Structure.Add.add, Tarski.Structure.Mul.mul, + LogicalConnective.HomClass.map_or, LogicalConnective.HomClass.map_and, + LogicalConnective.Prop.and_eq, LogicalConnective.HomClass.map_neg, + LogicalConnective.Prop.neg_eq, LogicalConnective.Prop.or_eq, Tarski.Structure.lt_iff_lt, + not_lt, Semiformula.eval_exsClosure, Matrix.conj_hom_prop, forall_exists_index, and_imp, + Matrix.zero_cons_succ_eq_self, Semiformula.eval_ball, Semiterm.val_bvar, Semiformula.eval_ex] + case zero => rintro rfl rfl; rfl + case one => rintro rfl rfl; rfl + case add => rintro rfl rfl; rfl + case mul => rintro rfl rfl; rfl + case proj => rintro rfl rfl; rfl + case equal i j => + by_cases hv : v i = v j <;> simp only [hv, true_and, not_true_eq_false, false_and, or_false, + not_false_eq_true, false_or] + · rintro rfl rfl; rfl + · rintro rfl rfl; rfl + case lt i j => + by_cases hv : v i < v j <;> simp only [hv, true_and, ← not_lt, not_true_eq_false, false_and, + or_false, not_false_eq_true, false_or] + · rintro rfl rfl; rfl + · rintro rfl rfl; rfl + case comp m n c d ihc + ihd => + simp only [Semiformula.eval_rew, Matrix.empty_eq, Function.comp_def, Rew.bind_fvar, + Matrix.comp_vecCons', Semiterm.val_fvar, Matrix.cons_val_zero, Semiterm.val_bvar, + Matrix.cons_val_succ] + intro w₁ hc₁ hd₁ w₂ hc₂ hd₂ + have hw : w₁ = w₂ := funext fun i => ihd i (hd₁ i) (hd₂ i) + rcases hw with rfl + exact ihc hc₁ hc₂ + case rfind c + ih => + simp only [Semiformula.eval_rew, Matrix.empty_eq, Function.comp_def, Rew.bind_fvar, + Matrix.comp_vecCons', Semiterm.val_operator, Tarski.Structure.numeral_eq_numeral, + ORingStructure.zero_eq_zero, Semiterm.val_fvar, Fin.isValue, Semiterm.val_bvar, + Matrix.cons_val_zero, Matrix.cons_val_one, Matrix.cons_val_fin_one, Matrix.cons_val_succ] + intro h₁ hm₁ h₂ hm₂ + by_contra hzz + wlog h : z < z' with Hz + case isFalse => + have hlt : z' < z := lt_of_le_of_ne (not_lt.mp h) (Ne.symm hzz) + exact Hz (k := k) c ih h₂ hm₂ h₁ hm₁ (Ne.symm hzz) hlt + have hex : + ∃ x, + x ≠ 0 ∧ + Semiformula.Evalf (M := M) (x :> z :> fun i => v i) + (FFL.FirstOrder.Arithmetic.codeAux c) := + hm₂ z h + rcases hex with ⟨x, xz, hx⟩ + exact xz (ih hx h₁) + +theorem eval_unique {M : Type*} [ORingStructure M] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : ℕ} + {c : Nat.ArithPart₁.Code k} {v : Fin k → M} {z z' : M} + (hz : Semiformula.Evalb (M := M) (z :> v) (FFL.FirstOrder.Arithmetic.code c)) + (hz' : Semiformula.Evalb (M := M) (z' :> v) (FFL.FirstOrder.Arithmetic.code c)) : z = z' := + by + simp only [Nat.succ_eq_add_one, code, Matrix.zero_cons_succ_eq_self, + Semiformula.eval_rew, Matrix.empty_eq, Function.comp_def, Rew.bind_fvar, + Semiterm.val_bvar] at hz hz' + exact evalAux_unique hz hz' + +end ArithmeticCode +end CategoricalRiceShapiro + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/Minimization.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/Minimization.lean new file mode 100644 index 000000000..cfe7d9c1b --- /dev/null +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/Minimization.lean @@ -0,0 +1,107 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.Basic + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# Unbounded minimization and substitution of a minimized value + +Two constructors over the primitives of +`CategoricalRiceShapiro.ArithmeticCode.Basic`. + +`codeRfindPos` is the least argument at which a code is positive, expressed +through `Nat.ArithPart₁.Code.rfind`, which searches for a zero. `codeBind` +substitutes the value of one code for the head argument of another, and is the +idiom in which a minimized value is consumed. + +Each construction is accompanied by the theorem that it realizes the intended +function over the natural numbers. Those `Computes` theorems are the input of +the standard-model bridge, which turns a computation over `ℕ` into evaluation at +standard numerals in an arbitrary model. +-/ + +@[expose] public section + +open _root_.Nat Nat Nat.ArithPart₁ + +namespace CategoricalRiceShapiro +namespace ArithmeticCode + +/-- The least argument at which `d` takes a positive value. + +`Code.rfind` searches for a zero, so the body is inverted twice: `codePos` +normalises a positive value to `1`, and `codeInv` exchanges `0` and `1`. -/ +def codeRfindPos {n : ℕ} (d : Code (n + 1)) : Code n := + (codeInv (codePos d)).rfind + +/-- Evaluate `dc` with the value of `dg` as its head argument and the ambient +arguments beneath it. -/ +def codeBind {n : ℕ} (dg : Code n) (dc : Code (n + 1)) : Code n := + dc.comp (Fin.cases dg (fun i => Code.proj i)) + +/-! +### Standard computations over the natural numbers -/ + +theorem eval_codeRfindPos {n : ℕ} {d : Code (n + 1)} {f : List.Vector ℕ (n + 1) → ℕ} + (hd : Computes d f) : + Code.eval (codeRfindPos d) (fun v => Nat.rfind fun m => Part.some (0 < f (m ::ᵥ v))) := + by + have hinv : Computes (codeInv (codePos d)) (fun w => Nat.inv (Nat.pos (f w))) := + computes_codeInv (computes_codePos hd) + have h := Code.eval.rfind (codeInv (codePos d)) (fun w => Nat.inv (Nat.pos (f w))) hinv + refine eval_of_eq h ?_ + funext v + congr 1 + funext m + congr 1 + simp only [Nat.inv, Nat.pos, isEqNat, isLtNat] + by_cases hz : f (m ::ᵥ v) = 0 + · simp [hz] + · simp [Nat.pos_of_ne_zero hz] + +theorem eval_codeBind {n : ℕ} {dg : Code n} {dc : Code (n + 1)} {gp : List.Vector ℕ n →. ℕ} + {f : List.Vector ℕ (n + 1) → ℕ} (hg : Code.eval dg gp) (hc : Computes dc f) : + Code.eval (codeBind dg dc) (fun v => (gp v).bind (fun x => (f (x ::ᵥ v) : Part ℕ))) := + by + unfold PFun at * + have h := + Code.eval.comp dc (Fin.cases dg (fun i => Code.proj i)) (fun w => (f w : Part ℕ)) + (Fin.cases gp (fun i v => ((v.get i : ℕ) : Part ℕ))) hc + (by + intro i + refine Fin.cases ?_ ?_ i + · exact hg + · intro j; exact Code.eval.proj j) + refine eval_of_eq h ?_ + funext v + simp only [List.Vector.mOfFn, Part.bind_eq_bind, Part.pure_eq_some, Part.bind_assoc, + Part.bind_some] + change + (gp v).bind + (fun x => + (List.Vector.mOfFn (fun i => Part.some (v.get i))).bind + (fun w => Part.some (f (x ::ᵥ w)))) = + _ + have hv : List.Vector.mOfFn (fun i => Part.some (v.get i)) = Part.some v := by + simpa only [List.Vector.ofFn_get, Part.pure_eq_some] using + (List.Vector.mOfFn_pure (m := Part) (fun i => v.get i)) + rw [hv] + simp only [Part.bind_some, Part.coe_some] + +end ArithmeticCode +end CategoricalRiceShapiro + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/NumeralEvaluation.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/NumeralEvaluation.lean new file mode 100644 index 000000000..c42372595 --- /dev/null +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/NumeralEvaluation.lean @@ -0,0 +1,1170 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.EvaluationCongruence +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.PartialRecursive +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.IOpen.Basic + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# Evaluation of the derived constructors at standard numerals + +Where `CategoricalRiceShapiro.ArithmeticCode.Evaluation` characterises the +graph of a constructor at arbitrary values, the results here compute it at the +image of a natural number. A code whose graph holds at `(n : M)` has, at the +same assignment, the graph of its truncated difference, integer square root and +Cantor components at the corresponding natural numbers. + +`eval_codeIfPos_of` is the introduction rule for the eager conditional and is +used by every proof below; it evaluates both branches, as the construction does. + +`eval_of_computes` is the bridge from the standard model: a code that realizes a +function over `ℕ` has, in any model of `𝐏𝐀⁻`, the graph of that function at the +images of standard arguments. It is the only route by which a construction +proved correct over `ℕ` — here halving, defined by primitive recursion — becomes +usable in an arbitrary model. +-/ + +@[expose] public section + +open _root_.Nat Nat Nat.ArithPart₁ + +namespace CategoricalRiceShapiro +namespace ArithmeticCode + +open Encodable FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +open scoped FFL.FirstOrder.Arithmetic + +variable {M : Type*} [ORingStructure M] + +/-! +### The eager conditional -/ + +/-- Introduction rule for `codeIfPos`. Both branches are evaluated, and the +test selects which of their values the conditional takes. -/ +theorem eval_codeIfPos_of [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : ℕ} (df dg dh : Code k) (f g h z : M) + (vv : Fin k → M) (hf : Semiformula.Evalb (f :> vv) (code df)) + (hg : Semiformula.Evalb (g :> vv) (code dg)) (hh : Semiformula.Evalb (h :> vv) (code dh)) + (hz : (0 < f ∧ z = g) ∨ (f = 0 ∧ z = h)) : + Semiformula.Evalb (z :> vv) (code (codeIfPos df dg dh)) := + by + have hfne : 0 < f → f ≠ 0 := by + intro hpos hc + rw [hc] at hpos + exact absurd hpos (_root_.lt_irrefl 0) + simp only [codeIfPos] + rcases hz with ⟨hfpos, hzg⟩ | ⟨hf0, hzh⟩ + · rw [hzg] + refine (eval_codeAdd_iff _ _ _ vv).mpr ⟨g, 0, ?_, ?_, by simp⟩ + · exact + (eval_codeMul_iff _ _ _ vv).mpr + ⟨1, g, (eval_codePos_iff _ _ vv).mpr ⟨f, hf, Or.inl ⟨hfpos, rfl⟩⟩, hg, by simp⟩ + · exact + (eval_codeMul_iff _ _ _ vv).mpr + ⟨0, h, (eval_codeInv_iff _ _ vv).mpr ⟨f, hf, Or.inr ⟨hfne hfpos, rfl⟩⟩, hh, by simp⟩ + · rw [hzh] + refine (eval_codeAdd_iff _ _ _ vv).mpr ⟨0, h, ?_, ?_, by simp⟩ + · refine (eval_codeMul_iff _ _ _ vv).mpr ⟨0, g, ?_, hg, by simp⟩ + refine (eval_codePos_iff _ _ vv).mpr ⟨f, hf, Or.inr ⟨?_, rfl⟩⟩ + rw [hf0] + exact _root_.lt_irrefl 0 + · exact + (eval_codeMul_iff _ _ _ vv).mpr + ⟨1, h, (eval_codeInv_iff _ _ vv).mpr ⟨f, hf, Or.inl ⟨hf0, rfl⟩⟩, hh, by simp⟩ + +/-- Elimination rule for `codeIfPos`: a value of the conditional comes from one +of the two branches, chosen by the test. Converse of `eval_codeIfPos_of`. -/ +theorem eval_codeIfPos_cases [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : ℕ} (df dg dh : Code k) (z : M) + (vv : Fin k → M) (hz : Semiformula.Evalb (z :> vv) (code (codeIfPos df dg dh))) : + ∃ f : M, + Semiformula.Evalb (f :> vv) (code df) ∧ + ((0 < f ∧ Semiformula.Evalb (z :> vv) (code dg)) ∨ + (f = 0 ∧ Semiformula.Evalb (z :> vv) (code dh))) := + by + rw [codeIfPos, eval_codeAdd_iff] at hz + obtain ⟨p, q, hp, hq, hzpq⟩ := hz + rw [eval_codeMul_iff] at hp + obtain ⟨pp, gg, hpp, hgg, hpv⟩ := hp + rw [eval_codeMul_iff] at hq + obtain ⟨ii, hh, hii, hhh, hqv⟩ := hq + rw [eval_codePos_iff] at hpp + obtain ⟨a, ha, hacase⟩ := hpp + rw [eval_codeInv_iff] at hii + obtain ⟨a', ha', ha'case⟩ := hii + have haa : a' = a := eval_unique ha' ha + rw [haa] at ha'case + refine ⟨a, ha, ?_⟩ + rcases hacase with ⟨hpos, hpp1⟩ | ⟨hnpos, hpp0⟩ + · have hane : ¬a = 0 := by + intro h + rw [h] at hpos + exact absurd hpos (_root_.lt_irrefl 0) + have hii0 : ii = 0 := by + rcases ha'case with ⟨h0, -⟩ | ⟨-, h0⟩ + · exact absurd h0 hane + · exact h0 + have hzg : z = gg := by rw [hzpq, hpv, hqv, hpp1, hii0, one_mul, zero_mul, add_zero] + refine Or.inl ⟨hpos, ?_⟩ + rw [hzg]; exact hgg + · have ha0 : a = 0 := by + by_contra hne + exact hnpos (pos_iff_ne_zero.mpr hne) + have hii1 : ii = 1 := by + rcases ha'case with ⟨-, h1⟩ | ⟨h0, -⟩ + · exact h1 + · exact absurd ha0 h0 + have hzh : z = hh := by rw [hzpq, hpv, hqv, hpp0, hii1, one_mul, zero_mul, zero_add] + refine Or.inr ⟨ha0, ?_⟩ + rw [hzh]; exact hhh + +/-! +### Truncated subtraction -/ + +/-- Truncated subtraction at standard numerals. -/ +theorem eval_codeSub_natCast [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : ℕ} (A B : Code k) (a b : ℕ) (vv : Fin k → M) + (hA : Semiformula.Evalb (((a : ℕ) : M) :> vv) (code A)) + (hB : Semiformula.Evalb (((b : ℕ) : M) :> vv) (code B)) : + Semiformula.Evalb ((((a - b : ℕ)) : M) :> vv) (code (codeSub A B)) := + by + have hlift : + ∀ (X : Code k) (x t : M), + Semiformula.Evalb (x :> vv) (code X) → + Semiformula.Evalb (x :> t :> vv) (code (codeLift X)) := + fun X x t hX => (eval_codeLift_iff X x t vv).mpr hX + have hhead : ∀ t : M, Semiformula.Evalb (t :> t :> vv) (code (codeHead (n := k))) := fun t => + (eval_codeHead_iff t (t :> vv)).mpr rfl + have hYzero : + b ≤ a → + ∀ t : M, + Semiformula.Evalb ((0 : M) :> t :> vv) + (code + (codeAnd (codeLt (codeLift A) (codeLift B)) + (codeEq (codeHead (n := k)) (Code.zero (k + 1))))) := + by + intro hba t + have hnab : ¬((a : ℕ) : M) < ((b : ℕ) : M) := + by + intro hc + have : a < b := by exact_mod_cast hc + omega + have hlt : + Semiformula.Evalb ((0 : M) :> t :> vv) (code (codeLt (codeLift A) (codeLift B))) := + (eval_codeLt_iff _ _ _ _).mpr ⟨_, _, hlift A _ t hA, hlift B _ t hB, Or.inr ⟨hnab, rfl⟩⟩ + have hz0 : Semiformula.Evalb ((0 : M) :> t :> vv) (code (Code.zero (k + 1))) := + (eval_zero_iff _ _).mpr rfl + by_cases ht0 : t = (0 : M) + · exact + (eval_codeAnd_iff _ _ _ _).mpr + ⟨0, 1, hlt, (eval_codeEq_iff _ _ _ _).mpr ⟨t, 0, hhead t, hz0, Or.inl ⟨ht0, rfl⟩⟩, + Or.inr ⟨by simp, rfl⟩⟩ + · exact + (eval_codeAnd_iff _ _ _ _).mpr + ⟨0, 0, hlt, (eval_codeEq_iff _ _ _ _).mpr ⟨t, 0, hhead t, hz0, Or.inr ⟨ht0, rfl⟩⟩, + Or.inr ⟨by simp, rfl⟩⟩ + simp only [codeSub] + rw [eval_codeRfindPos_iff] + by_cases hba : b ≤ a + · have hsum : (((a - b : ℕ)) : M) + ((b : ℕ) : M) = ((a : ℕ) : M) := + by + have hn : (a - b) + b = a := by omega + calc + (((a - b : ℕ)) : M) + ((b : ℕ) : M) = (((a - b) + b : ℕ) : M) := by push_cast; rfl + _ = ((a : ℕ) : M) := by rw [hn] + constructor + · refine ⟨1, _root_.zero_lt_one, ?_⟩ + refine (eval_codeOr_iff _ _ _ _).mpr ⟨1, 0, ?_, hYzero hba _, Or.inl ⟨by simp, rfl⟩⟩ + exact + (eval_codeEq_iff _ _ _ _).mpr + ⟨_, _, (eval_codeAdd_iff _ _ _ _).mpr ⟨_, _, hhead _, hlift B _ _ hB, rfl⟩, + hlift A _ _ hA, Or.inl ⟨hsum, rfl⟩⟩ + · intro t ht + refine (eval_codeOr_iff _ _ _ _).mpr ⟨0, 0, ?_, hYzero hba t, Or.inr ⟨by simp, rfl⟩⟩ + refine + (eval_codeEq_iff _ _ _ _).mpr + ⟨t + ((b : ℕ) : M), ((a : ℕ) : M), + (eval_codeAdd_iff _ _ _ _).mpr ⟨t, _, hhead t, hlift B _ t hB, rfl⟩, hlift A _ t hA, + Or.inr ⟨?_, rfl⟩⟩ + intro hcontra + have h2 := add_lt_add_right ht (((b : ℕ)) : M) + have h1 : t + ((b : ℕ) : M) < (((a - b : ℕ)) : M) + ((b : ℕ) : M) := by + simpa [add_comm] using h2 + rw [hsum, hcontra] at h1 + exact absurd h1 (_root_.lt_irrefl _) + · have hab : a < b := by omega + have habM : ((a : ℕ) : M) < ((b : ℕ) : M) := by exact_mod_cast hab + have hzero : (((a - b : ℕ)) : M) = (0 : M) := + by + have hn : a - b = 0 := by omega + rw [hn]; simp + constructor + · refine ⟨1, _root_.zero_lt_one, ?_⟩ + rw [hzero] + refine (eval_codeOr_iff _ _ _ _).mpr ⟨0, 1, ?_, ?_, Or.inl ⟨by simp, rfl⟩⟩ + · refine + (eval_codeEq_iff _ _ _ _).mpr + ⟨(0 : M) + ((b : ℕ) : M), ((a : ℕ) : M), + (eval_codeAdd_iff _ _ _ _).mpr ⟨0, _, hhead (0 : M), hlift B _ _ hB, rfl⟩, + hlift A _ _ hA, Or.inr ⟨?_, rfl⟩⟩ + intro hcontra + rw [zero_add] at hcontra + rw [hcontra] at habM + exact absurd habM (_root_.lt_irrefl _) + · exact + (eval_codeAnd_iff _ _ _ _).mpr + ⟨1, 1, + (eval_codeLt_iff _ _ _ _).mpr + ⟨_, _, hlift A _ _ hA, hlift B _ _ hB, Or.inl ⟨habM, rfl⟩⟩, + (eval_codeEq_iff _ _ _ _).mpr + ⟨0, 0, hhead (0 : M), (eval_zero_iff _ _).mpr rfl, Or.inl ⟨rfl, rfl⟩⟩, + Or.inl ⟨by simp, rfl⟩⟩ + · intro t ht + rw [hzero] at ht + exact absurd ht (by simp) + +/-! +### Integer square root and Cantor unpairing -/ + +/-- The integer square root at a standard numeral. -/ +theorem eval_codeSqrt_natCast [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : ℕ} (d : Code k) (n : ℕ) (v : Fin k → M) + (hd : Semiformula.Evalb (((n : ℕ) : M) :> v) (code d)) : + Semiformula.Evalb (((Nat.sqrt n : ℕ) : M) :> v) (code (codeSqrt d)) := + by + have hcastmul : ∀ a b : ℕ, ((a : ℕ) : M) * ((b : ℕ) : M) = (((a * b : ℕ)) : M) := by + intro a b; push_cast; rfl + have hcastsucc : ∀ a : ℕ, ((a : ℕ) : M) + 1 = (((a + 1 : ℕ)) : M) := + by + intro a + push_cast + rfl + have hhead : + ∀ j : ℕ, + Semiformula.Evalb (((j : ℕ) : M) :> ((j : ℕ) : M) :> v) (code (codeHead (n := k))) := + fun j => (eval_codeHead_iff _ _).mpr rfl + have hheadsq : + ∀ j : ℕ, + Semiformula.Evalb ((((j * j : ℕ)) : M) :> ((j : ℕ) : M) :> v) + (code (codeMul (codeHead (n := k)) (codeHead (n := k)))) := + by + intro j + refine (eval_codeMul_iff _ _ _ _).mpr ⟨_, _, hhead j, hhead j, ?_⟩ + rw [hcastmul j j] + have hheadsucc : + ∀ j : ℕ, + Semiformula.Evalb ((((j + 1 : ℕ)) : M) :> ((j : ℕ) : M) :> v) + (code (codeSucc (codeHead (n := k)))) := + by + intro j + refine (eval_codeSucc_iff _ _ _).mpr ⟨_, hhead j, ?_⟩ + rw [hcastsucc j] + have hheadsuccsq : + ∀ j : ℕ, + Semiformula.Evalb ((((j + 1) * (j + 1) : ℕ) : M) :> ((j : ℕ) : M) :> v) + (code (codeMul (codeSucc (codeHead (n := k))) (codeSucc (codeHead (n := k))))) := + by + intro j + refine (eval_codeMul_iff _ _ _ _).mpr ⟨_, _, hheadsucc j, hheadsucc j, ?_⟩ + rw [hcastmul (j + 1) (j + 1)] + have hliftd : + ∀ j : ℕ, Semiformula.Evalb (((n : ℕ) : M) :> ((j : ℕ) : M) :> v) (code (codeLift d)) := + fun j => (eval_codeLift_iff d _ _ v).mpr hd + have hAone : + ∀ j : ℕ, + j * j ≤ n → + Semiformula.Evalb ((1 : M) :> ((j : ℕ) : M) :> v) + (code + (codeOr (codeLt (codeMul (codeHead (n := k)) (codeHead (n := k))) (codeLift d)) + (codeEq (codeMul (codeHead (n := k)) (codeHead (n := k))) (codeLift d)))) := + by + intro j hle + rcases lt_or_eq_of_le hle with hlt | heq + · refine (eval_codeOr_iff _ _ _ _).mpr ⟨1, 0, ?_, ?_, Or.inl ⟨by simp, rfl⟩⟩ + · exact + (eval_codeLt_iff _ _ _ _).mpr + ⟨_, _, hheadsq j, hliftd j, Or.inl ⟨by exact_mod_cast hlt, rfl⟩⟩ + · refine (eval_codeEq_iff _ _ _ _).mpr ⟨_, _, hheadsq j, hliftd j, Or.inr ⟨?_, rfl⟩⟩ + intro hc + have : j * j = n := by exact_mod_cast hc + omega + · refine (eval_codeOr_iff _ _ _ _).mpr ⟨0, 1, ?_, ?_, Or.inl ⟨by simp, rfl⟩⟩ + · refine (eval_codeLt_iff _ _ _ _).mpr ⟨_, _, hheadsq j, hliftd j, Or.inr ⟨?_, rfl⟩⟩ + intro hc + have : j * j < n := by exact_mod_cast hc + omega + · exact + (eval_codeEq_iff _ _ _ _).mpr + ⟨_, _, hheadsq j, hliftd j, Or.inl ⟨by exact_mod_cast heq, rfl⟩⟩ + have hBval : + ∀ (j : ℕ) (y : M), + ((n < (j + 1) * (j + 1) ∧ y = 1) ∨ (¬n < (j + 1) * (j + 1) ∧ y = 0)) → + Semiformula.Evalb (y :> ((j : ℕ) : M) :> v) + (code + (codeLt (codeLift d) + (codeMul (codeSucc (codeHead (n := k))) (codeSucc (codeHead (n := k)))))) := + by + intro j y hy + refine (eval_codeLt_iff _ _ _ _).mpr ⟨_, _, hliftd j, hheadsuccsq j, ?_⟩ + rcases hy with ⟨hlt, rfl⟩ | ⟨hnlt, rfl⟩ + · exact Or.inl ⟨by exact_mod_cast hlt, rfl⟩ + · exact Or.inr ⟨fun hc => hnlt (by exact_mod_cast hc), rfl⟩ + have hsqle : Nat.sqrt n * Nat.sqrt n ≤ n := by simpa [pow_two] using Nat.sqrt_le' n + have hsqlt : n < (Nat.sqrt n + 1) * (Nat.sqrt n + 1) := by + simpa [pow_two] using Nat.lt_succ_sqrt' n + simp only [codeSqrt] + rw [eval_codeRfindPos_iff] + constructor + · exact + ⟨1, _root_.zero_lt_one, + (eval_codeAnd_iff _ _ _ _).mpr + ⟨1, 1, hAone (Nat.sqrt n) hsqle, hBval (Nat.sqrt n) 1 (Or.inl ⟨hsqlt, rfl⟩), + Or.inl ⟨by simp, rfl⟩⟩⟩ + · intro t ht + obtain ⟨j, rfl⟩ := FFL.FirstOrder.Arithmetic.eq_fin_of_lt_nat ht + have hup : ((j : ℕ) + 1) * ((j : ℕ) + 1) ≤ n := by + simpa [pow_two] using Nat.le_sqrt'.mp j.isLt + have hjj : (j : ℕ) * (j : ℕ) < n := + lt_of_lt_of_le (Nat.mul_self_lt_mul_self (Nat.lt_succ_self (j : ℕ))) hup + exact + (eval_codeAnd_iff _ _ _ _).mpr + ⟨1, 0, hAone (j : ℕ) (le_of_lt hjj), hBval (j : ℕ) 0 (Or.inr ⟨by omega, rfl⟩), + Or.inr ⟨by simp, rfl⟩⟩ + +/-- The three subterms both Cantor components are built from, evaluated once. -/ +private theorem eval_unpair_parts [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : ℕ} (d : Code k) (n : ℕ) (v : Fin k → M) + (hd : Semiformula.Evalb (((n : ℕ) : M) :> v) (code d)) : + Semiformula.Evalb (((Nat.sqrt n : ℕ) : M) :> v) (code (codeSqrt d)) ∧ + Semiformula.Evalb ((((n - Nat.sqrt n * Nat.sqrt n : ℕ)) : M) :> v) + (code (codeSub d (codeMul (codeSqrt d) (codeSqrt d)))) ∧ + Semiformula.Evalb ((((n - Nat.sqrt n * Nat.sqrt n - Nat.sqrt n : ℕ)) : M) :> v) + (code (codeSub (codeSub d (codeMul (codeSqrt d) (codeSqrt d))) (codeSqrt d))) := + by + have hsq := eval_codeSqrt_natCast d n v hd + have hmulss : + Semiformula.Evalb ((((Nat.sqrt n * Nat.sqrt n : ℕ)) : M) :> v) + (code (codeMul (codeSqrt d) (codeSqrt d))) := + by + refine (eval_codeMul_iff _ _ _ _).mpr ⟨_, _, hsq, hsq, ?_⟩ + push_cast; rfl + have hsub1 := eval_codeSub_natCast d _ n (Nat.sqrt n * Nat.sqrt n) v hd hmulss + exact + ⟨hsq, hsub1, + eval_codeSub_natCast _ _ (n - Nat.sqrt n * Nat.sqrt n) (Nat.sqrt n) v hsub1 hsq⟩ + +/-- The first Cantor component at a standard numeral. -/ +theorem eval_codeUnpair₁_natCast [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : ℕ} (d : Code k) (n : ℕ) (v : Fin k → M) + (hd : Semiformula.Evalb (((n : ℕ) : M) :> v) (code d)) : + Semiformula.Evalb ((((Nat.unpair n).1 : ℕ) : M) :> v) (code (codeUnpair₁ d)) := + by + obtain ⟨hsq, hsub1, -⟩ := eval_unpair_parts d n v hd + by_cases hcase : n - Nat.sqrt n * Nat.sqrt n < Nat.sqrt n + · have hu : (Nat.unpair n).1 = n - Nat.sqrt n * Nat.sqrt n := by simp [Nat.unpair, hcase] + rw [hu] + simp only [codeUnpair₁] + refine + eval_codeIfPos_of _ _ _ (1 : M) _ _ _ v ?_ hsub1 hsq (Or.inl ⟨_root_.zero_lt_one, rfl⟩) + exact + (eval_codeLt_iff _ _ _ _).mpr ⟨_, _, hsub1, hsq, Or.inl ⟨by exact_mod_cast hcase, rfl⟩⟩ + · have hu : (Nat.unpair n).1 = Nat.sqrt n := by simp [Nat.unpair, hcase] + rw [hu] + simp only [codeUnpair₁] + refine eval_codeIfPos_of _ _ _ (0 : M) _ _ _ v ?_ hsub1 hsq (Or.inr ⟨rfl, rfl⟩) + exact + (eval_codeLt_iff _ _ _ _).mpr + ⟨_, _, hsub1, hsq, Or.inr ⟨fun hc => hcase (by exact_mod_cast hc), rfl⟩⟩ + +/-- The second Cantor component at a standard numeral. -/ +theorem eval_codeUnpair₂_natCast [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : ℕ} (d : Code k) (n : ℕ) (v : Fin k → M) + (hd : Semiformula.Evalb (((n : ℕ) : M) :> v) (code d)) : + Semiformula.Evalb ((((Nat.unpair n).2 : ℕ) : M) :> v) (code (codeUnpair₂ d)) := + by + obtain ⟨hsq, hsub1, hsub2⟩ := eval_unpair_parts d n v hd + by_cases hcase : n - Nat.sqrt n * Nat.sqrt n < Nat.sqrt n + · have hu : (Nat.unpair n).2 = Nat.sqrt n := by simp [Nat.unpair, hcase] + rw [hu] + simp only [codeUnpair₂] + refine + eval_codeIfPos_of _ _ _ (1 : M) _ _ _ v ?_ hsq hsub2 (Or.inl ⟨_root_.zero_lt_one, rfl⟩) + exact + (eval_codeLt_iff _ _ _ _).mpr ⟨_, _, hsub1, hsq, Or.inl ⟨by exact_mod_cast hcase, rfl⟩⟩ + · have hu : (Nat.unpair n).2 = n - Nat.sqrt n * Nat.sqrt n - Nat.sqrt n := by + simp [Nat.unpair, hcase] + rw [hu] + simp only [codeUnpair₂] + refine eval_codeIfPos_of _ _ _ (0 : M) _ _ _ v ?_ hsq hsub2 (Or.inr ⟨rfl, rfl⟩) + exact + (eval_codeLt_iff _ _ _ _).mpr + ⟨_, _, hsub1, hsq, Or.inr ⟨fun hc => hcase (by exact_mod_cast hc), rfl⟩⟩ + +/-! +### The standard-model bridge -/ + +/-- A code realizing `f` over `ℕ` has the graph of `f` at standard arguments in +any model of `𝐏𝐀⁻`. + +`Computes` is a statement about `ℕ`. Sigma-one completeness transports the +corresponding sentence, whose free variables are all interpreted by numerals. -/ +theorem eval_of_computes [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : ℕ} (c : Code k) (f : List.Vector ℕ k → ℕ) + (hc : Computes c f) (w : Fin k → ℕ) : + Semiformula.Evalb (M := M) + (((f (List.Vector.ofFn w) : ℕ) : M) :> (fun i => ((w i : ℕ) : M))) (code c) := + by + have hnat : Semiformula.Evalb (M := ℕ) ((f (List.Vector.ofFn w)) :> w) (code c) := + (FFL.FirstOrder.Arithmetic.models_code hc _ w).mpr (by simp) + have htr := + FFL.FirstOrder.Arithmetic.bold_sigma_one_completeness' (M := M) + (FFL.FirstOrder.Arithmetic.code_sigma_one c) hnat + rw [FFL.FirstOrder.Arithmetic.numeral_eq_natCast] at htr + have heq : + (Nat.cast ∘ ((f (List.Vector.ofFn w)) :> w) : Fin (k + 1) → M) = + (((f (List.Vector.ofFn w) : ℕ) : M) :> (fun i => ((w i : ℕ) : M))) := + by + funext i + refine Fin.cases ?_ ?_ i + · rfl + · intro j; rfl + rw [heq] at htr + exact htr + +/-- Halving at a standard numeral. -/ +theorem eval_codeDiv2_natCast [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : ℕ} (A : Code k) (n : ℕ) (vv : Fin k → M) + (hA : Semiformula.Evalb (((n : ℕ) : M) :> vv) (code A)) : + Semiformula.Evalb ((((Nat.div2 n : ℕ)) : M) :> vv) (code (codeDiv2 A)) := + by + simp only [codeDiv2] + refine (eval_comp_iff _ _ _ _).mpr ⟨fun i => (((![n] : Fin 1 → ℕ) i : ℕ) : M), ?_, ?_⟩ + · have hs := + eval_of_computes (M := M) codeDiv2Unary (fun w => Nat.div2 w.head) computes_codeDiv2Unary + ![n] + have hhead : (List.Vector.ofFn (![n] : Fin 1 → ℕ)).head = n := by simp + rw [hhead] at hs + exact hs + · intro i + refine Fin.cases ?_ (fun j => j.elim0) i + simpa using hA + +/-! +### Divisibility, remainder and parity -/ + +/-- Every element below a standard numeral is itself a standard numeral. -/ +private theorem exists_lt_natCast [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] : + ∀ (n : ℕ) (t : M), t < ((n : ℕ) : M) → ∃ j : ℕ, j < n ∧ t = ((j : ℕ) : M) := + by + intro n + induction n with + | zero => intro t h; simp at h + | succ m ih => + intro t h + have hcast : (((m + 1 : ℕ)) : M) = ((m : ℕ) : M) + 1 := by push_cast; rfl + rw [hcast] at h + have hle : t ≤ ((m : ℕ) : M) := FFL.FirstOrder.Arithmetic.lt_succ_iff_le.mp h + rcases lt_or_eq_of_le hle with hlt | heq + · obtain ⟨j, hj, hjt⟩ := ih t hlt + exact ⟨j, Nat.lt_succ_of_lt hj, hjt⟩ + · exact ⟨m, Nat.lt_succ_self m, heq⟩ + +/-- Introduction rule for the non-strict comparison. -/ +theorem eval_codeLe_of [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : ℕ} (A B : Code k) (x y z : M) (vv : Fin k → M) + (hA : Semiformula.Evalb (x :> vv) (code A)) (hB : Semiformula.Evalb (y :> vv) (code B)) + (hz : (x ≤ y ∧ z = 1) ∨ (¬x ≤ y ∧ z = 0)) : + Semiformula.Evalb (z :> vv) (code (codeLe A B)) := + by + simp only [codeLe] + by_cases hlt : x < y + · refine (eval_codeOr_iff _ _ _ _).mpr ⟨1, 0, ?_, ?_, ?_⟩ + · exact (eval_codeLt_iff _ _ _ _).mpr ⟨x, y, hA, hB, Or.inl ⟨hlt, rfl⟩⟩ + · exact + (eval_codeEq_iff _ _ _ _).mpr + ⟨x, y, hA, hB, Or.inr ⟨fun hc => absurd (hc ▸ hlt) (_root_.lt_irrefl _), rfl⟩⟩ + · rcases hz with ⟨_, rfl⟩ | ⟨hnle, _⟩ + · exact Or.inl ⟨by simp, rfl⟩ + · exact absurd (le_of_lt hlt) hnle + · by_cases heq : x = y + · refine (eval_codeOr_iff _ _ _ _).mpr ⟨0, 1, ?_, ?_, ?_⟩ + · exact (eval_codeLt_iff _ _ _ _).mpr ⟨x, y, hA, hB, Or.inr ⟨hlt, rfl⟩⟩ + · exact (eval_codeEq_iff _ _ _ _).mpr ⟨x, y, hA, hB, Or.inl ⟨heq, rfl⟩⟩ + · rcases hz with ⟨_, rfl⟩ | ⟨hnle, _⟩ + · exact Or.inl ⟨by simp, rfl⟩ + · exact absurd (le_of_eq heq) hnle + · refine (eval_codeOr_iff _ _ _ _).mpr ⟨0, 0, ?_, ?_, ?_⟩ + · exact (eval_codeLt_iff _ _ _ _).mpr ⟨x, y, hA, hB, Or.inr ⟨hlt, rfl⟩⟩ + · exact (eval_codeEq_iff _ _ _ _).mpr ⟨x, y, hA, hB, Or.inr ⟨heq, rfl⟩⟩ + · rcases hz with ⟨hle, _⟩ | ⟨_, rfl⟩ + · exact absurd (lt_of_le_of_ne hle heq) hlt + · exact Or.inr ⟨by simp, rfl⟩ + +/-- Divisibility at standard numerals. -/ +theorem eval_codeDvd_natCast [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : ℕ} (A B : Code k) (a b : ℕ) (z : M) + (vv : Fin k → M) (hA : Semiformula.Evalb (((a : ℕ) : M) :> vv) (code A)) + (hB : Semiformula.Evalb (((b : ℕ) : M) :> vv) (code B)) + (hz : (a ∣ b ∧ z = 1) ∨ (¬a ∣ b ∧ z = 0)) : + Semiformula.Evalb (z :> vv) (code (codeDvd A B)) := + by + have hlift : + ∀ (X : Code k) (x t : M), + Semiformula.Evalb (x :> vv) (code X) → + Semiformula.Evalb (x :> t :> vv) (code (codeLift X)) := + fun X x t hX => (eval_codeLift_iff X x t vv).mpr hX + have hhead : ∀ t : M, Semiformula.Evalb (t :> t :> vv) (code (codeHead (n := k))) := fun t => + (eval_codeHead_iff t (t :> vv)).mpr rfl + have hex : ∃ m : ℕ, m * a = b ∨ b < m := ⟨b + 1, Or.inr (Nat.lt_succ_self b)⟩ + have hspec : Nat.find hex * a = b ∨ b < Nat.find hex := Nat.find_spec hex + have hmin : ∀ j : ℕ, j < Nat.find hex → ¬(j * a = b ∨ b < j) := fun j hj => + Nat.find_min hex hj + have hEqComp : + ∀ (j : ℕ) (y : M), + ((j * a = b ∧ y = 1) ∨ (¬j * a = b ∧ y = 0)) → + Semiformula.Evalb (y :> ((j : ℕ) : M) :> vv) + (code (codeEq (codeMul (codeHead (n := k)) (codeLift A)) (codeLift B))) := + by + intro j y hy + have hmulv : + Semiformula.Evalb ((((j * a : ℕ)) : M) :> ((j : ℕ) : M) :> vv) + (code (codeMul (codeHead (n := k)) (codeLift A))) := + by + refine (eval_codeMul_iff _ _ _ _).mpr ⟨_, _, hhead _, hlift A _ _ hA, ?_⟩ + push_cast; rfl + refine (eval_codeEq_iff _ _ _ _).mpr ⟨_, _, hmulv, hlift B _ _ hB, ?_⟩ + rcases hy with ⟨he, rfl⟩ | ⟨hne, rfl⟩ + · exact Or.inl ⟨by exact_mod_cast he, rfl⟩ + · exact Or.inr ⟨fun h => hne (by exact_mod_cast h), rfl⟩ + have hLtComp : + ∀ (j : ℕ) (y : M), + ((b < j ∧ y = 1) ∨ (¬b < j ∧ y = 0)) → + Semiformula.Evalb (y :> ((j : ℕ) : M) :> vv) + (code (codeLt (codeLift B) (codeHead (n := k)))) := + by + intro j y hy + refine (eval_codeLt_iff _ _ _ _).mpr ⟨_, _, hlift B _ _ hB, hhead _, ?_⟩ + rcases hy with ⟨he, rfl⟩ | ⟨hne, rfl⟩ + · exact Or.inl ⟨by exact_mod_cast he, rfl⟩ + · exact Or.inr ⟨fun h => hne (by exact_mod_cast h), rfl⟩ + have hG1 : + ∀ j : ℕ, + (j * a = b ∨ b < j) → + Semiformula.Evalb ((1 : M) :> ((j : ℕ) : M) :> vv) + (code + (codeOr (codeEq (codeMul (codeHead (n := k)) (codeLift A)) (codeLift B)) + (codeLt (codeLift B) (codeHead (n := k))))) := + by + intro j hj + by_cases h1 : j * a = b + · by_cases h2 : b < j + · exact + (eval_codeOr_iff _ _ _ _).mpr + ⟨1, 1, hEqComp j 1 (Or.inl ⟨h1, rfl⟩), hLtComp j 1 (Or.inl ⟨h2, rfl⟩), + Or.inl ⟨by simp, rfl⟩⟩ + · exact + (eval_codeOr_iff _ _ _ _).mpr + ⟨1, 0, hEqComp j 1 (Or.inl ⟨h1, rfl⟩), hLtComp j 0 (Or.inr ⟨h2, rfl⟩), + Or.inl ⟨by simp, rfl⟩⟩ + · have h2 : b < j := hj.resolve_left h1 + exact + (eval_codeOr_iff _ _ _ _).mpr + ⟨0, 1, hEqComp j 0 (Or.inr ⟨h1, rfl⟩), hLtComp j 1 (Or.inl ⟨h2, rfl⟩), + Or.inl ⟨by simp, rfl⟩⟩ + have hG0 : + ∀ j : ℕ, + ¬(j * a = b ∨ b < j) → + Semiformula.Evalb ((0 : M) :> ((j : ℕ) : M) :> vv) + (code + (codeOr (codeEq (codeMul (codeHead (n := k)) (codeLift A)) (codeLift B)) + (codeLt (codeLift B) (codeHead (n := k))))) := + by + intro j hj + exact + (eval_codeOr_iff _ _ _ _).mpr + ⟨0, 0, hEqComp j 0 (Or.inr ⟨fun h => hj (Or.inl h), rfl⟩), + hLtComp j 0 (Or.inr ⟨fun h => hj (Or.inr h), rfl⟩), Or.inr ⟨by simp, rfl⟩⟩ + simp only [codeDvd] + rw [eval_codeBind_iff] + refine ⟨((Nat.find hex : ℕ) : M), ?_, ?_⟩ + · rw [eval_codeRfindPos_iff] + refine ⟨⟨1, _root_.zero_lt_one, hG1 (Nat.find hex) hspec⟩, ?_⟩ + intro t ht + obtain ⟨j, hj, rfl⟩ := exists_lt_natCast (Nat.find hex) t ht + exact hG0 j (hmin j hj) + · refine + eval_codeLe_of _ _ ((Nat.find hex : ℕ) : M) ((b : ℕ) : M) z _ (hhead _) (hlift B _ _ hB) + ?_ + rcases hz with ⟨hdvd, rfl⟩ | ⟨hndvd, rfl⟩ + · refine Or.inl ⟨?_, rfl⟩ + obtain ⟨c, hc⟩ := hdvd + have hcs : c * a = b := by rw [hc, Nat.mul_comm] + have hfc : Nat.find hex ≤ c := Nat.find_le (Or.inl hcs) + have hle : Nat.find hex ≤ b := + by + rcases Nat.eq_zero_or_pos a with ha0 | hap + · have hb0 : b = 0 := by rw [hc, ha0, Nat.zero_mul] + have h0 : Nat.find hex ≤ 0 := Nat.find_le (Or.inl (by simp [ha0, hb0])) + omega + · calc + Nat.find hex ≤ c := hfc + _ = c * 1 := (Nat.mul_one c).symm + _ ≤ c * a := (Nat.mul_le_mul_left c hap) + _ = b := hcs + exact_mod_cast hle + · refine Or.inr ⟨?_, rfl⟩ + have hlt : b < Nat.find hex := by + rcases hspec with hfa | hbf + · exact + absurd ⟨Nat.find hex, ((Nat.mul_comm (Nat.find hex) a).symm.trans hfa).symm⟩ hndvd + · exact hbf + intro hcon + have hle : Nat.find hex ≤ b := by exact_mod_cast hcon + omega + +/-- Remainder at standard numerals. -/ +theorem eval_codeRem_natCast [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : ℕ} (A B : Code k) (a b : ℕ) (vv : Fin k → M) + (hA : Semiformula.Evalb (((a : ℕ) : M) :> vv) (code A)) + (hB : Semiformula.Evalb (((b : ℕ) : M) :> vv) (code B)) : + Semiformula.Evalb ((((a % b : ℕ)) : M) :> vv) (code (codeRem A B)) := + by + have hlift : + ∀ (X : Code k) (x t : M), + Semiformula.Evalb (x :> vv) (code X) → + Semiformula.Evalb (x :> t :> vv) (code (codeLift X)) := + fun X x t hX => (eval_codeLift_iff X x t vv).mpr hX + have hhead : ∀ t : M, Semiformula.Evalb (t :> t :> vv) (code (codeHead (n := k))) := fun t => + (eval_codeHead_iff t (t :> vv)).mpr rfl + simp only [codeRem] + rw [eval_codeRfindPos_iff] + constructor + · refine ⟨1, _root_.zero_lt_one, ?_⟩ + exact + eval_codeDvd_natCast _ _ b (a - a % b) 1 _ (hlift B _ _ hB) + (eval_codeSub_natCast _ _ a (a % b) _ (hlift A _ _ hA) (hhead _)) + (Or.inl ⟨Nat.dvd_sub_mod a, rfl⟩) + · intro t ht + obtain ⟨j, hj, rfl⟩ := exists_lt_natCast (a % b) t ht + refine + eval_codeDvd_natCast _ _ b (a - j) 0 _ (hlift B _ _ hB) + (eval_codeSub_natCast _ _ a j _ (hlift A _ _ hA) (hhead _)) (Or.inr ⟨?_, rfl⟩) + intro hdvd + have hmod_le : a % b ≤ a := Nat.mod_le _ _ + rcases Nat.eq_zero_or_pos b with hz0 | hbpos + · rw [hz0] at hdvd + rw [hz0, Nat.mod_zero] at hj + rw [Nat.zero_dvd] at hdvd + omega + · have hsub2 : b ∣ a % b - j := + by + have heq : a - j - (a - a % b) = a % b - j := by omega + rw [← heq] + exact Nat.dvd_sub hdvd (Nat.dvd_sub_mod a) + have hpos : 0 < a % b - j := by omega + have hmodlt : a % b < b := Nat.mod_lt _ hbpos + exact absurd (Nat.le_of_dvd hpos hsub2) (by omega) + +/-- Parity at a standard numeral. -/ +theorem eval_codeBodd_natCast [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : ℕ} (A : Code k) (n : ℕ) (vv : Fin k → M) + (hA : Semiformula.Evalb (((n : ℕ) : M) :> vv) (code A)) : + Semiformula.Evalb ((((n % 2 : ℕ)) : M) :> vv) (code (codeBodd A)) := + by + simp only [codeBodd] + exact eval_codeRem_natCast A _ n 2 vv hA (by simpa using eval_codeConst (M := M) 2 vv) + +/-! +### Truncated subtraction, square root and the Cantor components at +arbitrary values + +The results above compute a constructor at the image of a natural number. Those +below compute the same constructors at an arbitrary element, against the +operations the pinned `IOpen` theory of Foundation already supplies: +`FFL.FirstOrder.Arithmetic.sqrt`, `pair`, `pi₁` and `pi₂`, together with their +specifications. No arithmetic identity is reproved here; each proof only +matches a code against the operation Foundation defines. -/ + +/-- Truncated subtraction at arbitrary values. -/ +theorem eval_codeSub [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : ℕ} (A B : Code k) (a b : M) (v : Fin k → M) + (hA : Semiformula.Evalb (a :> v) (code A)) (hB : Semiformula.Evalb (b :> v) (code B)) : + Semiformula.Evalb ((a - b) :> v) (code (codeSub A B)) := + by + have hhead : ∀ t : M, Semiformula.Evalb (t :> t :> v) (code (codeHead (n := k))) := fun t => + (eval_codeHead_iff _ _).mpr rfl + have hliftA : ∀ t : M, Semiformula.Evalb (a :> t :> v) (code (codeLift A)) := fun t => + (eval_codeLift_iff A _ _ v).mpr hA + have hliftB : ∀ t : M, Semiformula.Evalb (b :> t :> v) (code (codeLift B)) := fun t => + (eval_codeLift_iff B _ _ v).mpr hB + have hzero : ∀ t : M, Semiformula.Evalb ((0 : M) :> t :> v) (code (Code.zero (k + 1))) := + fun t => (eval_zero_iff _ _).mpr rfl + have hsum : + ∀ t : M, + Semiformula.Evalb ((t + b) :> t :> v) (code (codeAdd (codeHead (n := k)) (codeLift B))) := + fun t => (eval_codeAdd_iff _ _ _ _).mpr ⟨t, b, hhead t, hliftB t, rfl⟩ + have heqs : + ∀ t y : M, + ((t + b = a ∧ y = 1) ∨ (¬t + b = a ∧ y = 0)) → + Semiformula.Evalb (y :> t :> v) + (code (codeEq (codeAdd (codeHead (n := k)) (codeLift B)) (codeLift A))) := + fun t y hy => (eval_codeEq_iff _ _ _ _).mpr ⟨t + b, a, hsum t, hliftA t, hy⟩ + have hcmp : + ∀ t y : M, + ((a < b ∧ y = 1) ∨ (¬a < b ∧ y = 0)) → + Semiformula.Evalb (y :> t :> v) (code (codeLt (codeLift A) (codeLift B))) := + fun t y hy => (eval_codeLt_iff _ _ _ _).mpr ⟨a, b, hliftA t, hliftB t, hy⟩ + have hnil : + ∀ t : M, + ∃ y : M, + Semiformula.Evalb (y :> t :> v) + (code (codeEq (codeHead (n := k)) (Code.zero (k + 1)))) := + by + intro t + by_cases h : t = 0 + · exact ⟨1, (eval_codeEq_iff _ _ _ _).mpr ⟨t, 0, hhead t, hzero t, Or.inl ⟨h, rfl⟩⟩⟩ + · exact ⟨0, (eval_codeEq_iff _ _ _ _).mpr ⟨t, 0, hhead t, hzero t, Or.inr ⟨h, rfl⟩⟩⟩ + simp only [codeSub] + rw [eval_codeRfindPos_iff] + by_cases hba : b ≤ a + · have hab : ¬a < b := not_lt.mpr hba + have hand : + ∀ t : M, + Semiformula.Evalb ((0 : M) :> t :> v) + (code + (codeAnd (codeLt (codeLift A) (codeLift B)) + (codeEq (codeHead (n := k)) (Code.zero (k + 1))))) := + by + intro t + obtain ⟨y, hy⟩ := hnil t + exact + (eval_codeAnd_iff _ _ _ _).mpr + ⟨0, y, hcmp t 0 (Or.inr ⟨hab, rfl⟩), hy, Or.inr ⟨by simp, rfl⟩⟩ + constructor + · exact + ⟨1, _root_.zero_lt_one, + (eval_codeOr_iff _ _ _ _).mpr + ⟨1, 0, heqs _ 1 (Or.inl ⟨sub_add_self_of_le hba, rfl⟩), hand _, + Or.inl ⟨by simp, rfl⟩⟩⟩ + · intro t ht + have hne : ¬t + b = a := by + intro hc + have hlt' : t + b < a - b + b := by simpa [add_comm] using (add_lt_add_left ht b) + rw [hc, sub_add_self_of_le hba] at hlt' + exact absurd hlt' (_root_.lt_irrefl a) + exact + (eval_codeOr_iff _ _ _ _).mpr + ⟨0, 0, heqs t 0 (Or.inr ⟨hne, rfl⟩), hand t, Or.inr ⟨by simp, rfl⟩⟩ + · have hab : a < b := not_le.mp hba + rw [sub_spec_of_lt hab] + constructor + · refine + ⟨1, _root_.zero_lt_one, + (eval_codeOr_iff _ _ _ _).mpr + ⟨0, 1, heqs 0 0 (Or.inr ⟨?_, rfl⟩), ?_, Or.inl ⟨by simp, rfl⟩⟩⟩ + · intro hc + rw [zero_add] at hc + exact absurd hc (ne_of_gt hab) + · exact + (eval_codeAnd_iff _ _ _ _).mpr + ⟨1, 1, hcmp 0 1 (Or.inl ⟨hab, rfl⟩), + (eval_codeEq_iff _ _ _ _).mpr ⟨0, 0, hhead 0, hzero 0, Or.inl ⟨rfl, rfl⟩⟩, + Or.inl ⟨by simp, rfl⟩⟩ + · intro t ht + exact absurd ht (by simp) + +/-- The integer square root at an arbitrary value, given the defining bounds. -/ +theorem eval_codeSqrt_of_bounds [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : ℕ} (d : Code k) (a r : M) (v : Fin k → M) + (hd : Semiformula.Evalb (a :> v) (code d)) (hle : r * r ≤ a) (hlt : a < (r + 1) * (r + 1)) : + Semiformula.Evalb (r :> v) (code (codeSqrt d)) := + by + have hhead : ∀ t : M, Semiformula.Evalb (t :> t :> v) (code (codeHead (n := k))) := fun t => + (eval_codeHead_iff _ _).mpr rfl + have hliftd : ∀ t : M, Semiformula.Evalb (a :> t :> v) (code (codeLift d)) := fun t => + (eval_codeLift_iff d _ _ v).mpr hd + have hheadsq : + ∀ t : M, + Semiformula.Evalb ((t * t) :> t :> v) + (code (codeMul (codeHead (n := k)) (codeHead (n := k)))) := + fun t => (eval_codeMul_iff _ _ _ _).mpr ⟨t, t, hhead t, hhead t, rfl⟩ + have hheadsucc : + ∀ t : M, Semiformula.Evalb ((t + 1) :> t :> v) (code (codeSucc (codeHead (n := k)))) := + fun t => (eval_codeSucc_iff _ _ _).mpr ⟨t, hhead t, rfl⟩ + have hheadsuccsq : + ∀ t : M, + Semiformula.Evalb (((t + 1) * (t + 1)) :> t :> v) + (code (codeMul (codeSucc (codeHead (n := k))) (codeSucc (codeHead (n := k))))) := + fun t => (eval_codeMul_iff _ _ _ _).mpr ⟨t + 1, t + 1, hheadsucc t, hheadsucc t, rfl⟩ + have hAone : + ∀ t : M, + t * t ≤ a → + Semiformula.Evalb ((1 : M) :> t :> v) + (code + (codeOr (codeLt (codeMul (codeHead (n := k)) (codeHead (n := k))) (codeLift d)) + (codeEq (codeMul (codeHead (n := k)) (codeHead (n := k))) (codeLift d)))) := + by + intro t hlet + rcases lt_or_eq_of_le hlet with hltt | heqt + · exact + (eval_codeOr_iff _ _ _ _).mpr + ⟨1, 0, + (eval_codeLt_iff _ _ _ _).mpr ⟨t * t, a, hheadsq t, hliftd t, Or.inl ⟨hltt, rfl⟩⟩, + (eval_codeEq_iff _ _ _ _).mpr + ⟨t * t, a, hheadsq t, hliftd t, Or.inr ⟨ne_of_lt hltt, rfl⟩⟩, + Or.inl ⟨by simp, rfl⟩⟩ + · exact + (eval_codeOr_iff _ _ _ _).mpr + ⟨0, 1, + (eval_codeLt_iff _ _ _ _).mpr + ⟨t * t, a, hheadsq t, hliftd t, + Or.inr ⟨by rw [heqt]; exact _root_.lt_irrefl a, rfl⟩⟩, + (eval_codeEq_iff _ _ _ _).mpr ⟨t * t, a, hheadsq t, hliftd t, Or.inl ⟨heqt, rfl⟩⟩, + Or.inl ⟨by simp, rfl⟩⟩ + have hBval : + ∀ t y : M, + ((a < (t + 1) * (t + 1) ∧ y = 1) ∨ (¬a < (t + 1) * (t + 1) ∧ y = 0)) → + Semiformula.Evalb (y :> t :> v) + (code + (codeLt (codeLift d) + (codeMul (codeSucc (codeHead (n := k))) (codeSucc (codeHead (n := k)))))) := + fun t y hy => + (eval_codeLt_iff _ _ _ _).mpr ⟨a, (t + 1) * (t + 1), hliftd t, hheadsuccsq t, hy⟩ + simp only [codeSqrt] + rw [eval_codeRfindPos_iff] + constructor + · exact + ⟨1, _root_.zero_lt_one, + (eval_codeAnd_iff _ _ _ _).mpr + ⟨1, 1, hAone r hle, hBval r 1 (Or.inl ⟨hlt, rfl⟩), Or.inl ⟨by simp, rfl⟩⟩⟩ + · intro t ht + have hsucc : t + 1 ≤ r := FFL.FirstOrder.Arithmetic.succ_le_iff_lt.mpr ht + have hup : (t + 1) * (t + 1) ≤ r * r := mul_le_mul hsucc hsucc (by simp) (by simp) + have hnlt : ¬a < (t + 1) * (t + 1) := not_lt.mpr (le_trans hup hle) + have hstt : t * t ≤ a := + le_trans + (le_trans (mul_le_mul (le_of_lt (by simp)) (le_of_lt (by simp)) (by simp) (by simp)) + hup) + hle + exact + (eval_codeAnd_iff _ _ _ _).mpr + ⟨1, 0, hAone t hstt, hBval t 0 (Or.inr ⟨hnlt, rfl⟩), Or.inr ⟨by simp, rfl⟩⟩ + +/-- The integer square root at an arbitrary value. -/ +theorem eval_codeSqrt [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] {k : ℕ} (d : Code k) (a : M) (v : Fin k → M) + (hd : Semiformula.Evalb (a :> v) (code d)) : + Semiformula.Evalb (FFL.FirstOrder.Arithmetic.sqrt a :> v) (code (codeSqrt d)) := + eval_codeSqrt_of_bounds d a _ v hd (FFL.FirstOrder.Arithmetic.sqrt_spec_le a) + (FFL.FirstOrder.Arithmetic.sqrt_spec_lt a) + +/-- Cantor pairing at arbitrary values. -/ +theorem eval_codePair [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] {k : ℕ} (A B : Code k) (a b : M) (v : Fin k → M) + (hA : Semiformula.Evalb (a :> v) (code A)) (hB : Semiformula.Evalb (b :> v) (code B)) : + Semiformula.Evalb (FFL.FirstOrder.Arithmetic.pair a b :> v) (code (codePair A B)) := + by + have hhigh : Semiformula.Evalb ((b * b + a) :> v) (code (codeAdd (codeMul B B) A)) := + (eval_codeAdd_iff _ _ _ _).mpr + ⟨b * b, a, (eval_codeMul_iff _ _ _ _).mpr ⟨b, b, hB, hB, rfl⟩, hA, rfl⟩ + have hlow : + Semiformula.Evalb ((a * a + a + b) :> v) (code (codeAdd (codeAdd (codeMul A A) A) B)) := + (eval_codeAdd_iff _ _ _ _).mpr + ⟨a * a + a, b, + (eval_codeAdd_iff _ _ _ _).mpr + ⟨a * a, a, (eval_codeMul_iff _ _ _ _).mpr ⟨a, a, hA, hA, rfl⟩, hA, rfl⟩, + hB, rfl⟩ + simp only [codePair] + by_cases hab : a < b + · refine + eval_codeIfPos_of _ _ _ 1 (b * b + a) (a * a + a + b) _ v + ((eval_codeLt_iff _ _ _ _).mpr ⟨a, b, hA, hB, Or.inl ⟨hab, rfl⟩⟩) hhigh hlow + (Or.inl ⟨by simp, ?_⟩) + simp [FFL.FirstOrder.Arithmetic.pair, hab] + · refine + eval_codeIfPos_of _ _ _ 0 (b * b + a) (a * a + a + b) _ v + ((eval_codeLt_iff _ _ _ _).mpr ⟨a, b, hA, hB, Or.inr ⟨hab, rfl⟩⟩) hhigh hlow + (Or.inr ⟨rfl, ?_⟩) + simp [FFL.FirstOrder.Arithmetic.pair, hab] + +/-- The first Cantor component at an arbitrary value. -/ +theorem eval_codeUnpair₁ [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] {k : ℕ} (d : Code k) (a : M) (v : Fin k → M) + (hd : Semiformula.Evalb (a :> v) (code d)) : + Semiformula.Evalb (FFL.FirstOrder.Arithmetic.pi₁ a :> v) (code (codeUnpair₁ d)) := + by + have hsq := eval_codeSqrt d a v hd + have hmul : + Semiformula.Evalb + ((FFL.FirstOrder.Arithmetic.sqrt a * FFL.FirstOrder.Arithmetic.sqrt a) :> v) + (code (codeMul (codeSqrt d) (codeSqrt d))) := + (eval_codeMul_iff _ _ _ _).mpr ⟨_, _, hsq, hsq, rfl⟩ + have hsub := + eval_codeSub d (codeMul (codeSqrt d) (codeSqrt d)) a + (FFL.FirstOrder.Arithmetic.sqrt a * FFL.FirstOrder.Arithmetic.sqrt a) v hd hmul + simp only [codeUnpair₁] + by_cases hlt : + a - FFL.FirstOrder.Arithmetic.sqrt a * FFL.FirstOrder.Arithmetic.sqrt a < + FFL.FirstOrder.Arithmetic.sqrt a + · refine + eval_codeIfPos_of _ _ _ 1 _ _ _ v + ((eval_codeLt_iff _ _ _ _).mpr ⟨_, _, hsub, hsq, Or.inl ⟨hlt, rfl⟩⟩) hsub hsq + (Or.inl ⟨by simp, ?_⟩) + simp [FFL.FirstOrder.Arithmetic.pi₁, FFL.FirstOrder.Arithmetic.unpair, hlt] + · refine + eval_codeIfPos_of _ _ _ 0 _ _ _ v + ((eval_codeLt_iff _ _ _ _).mpr ⟨_, _, hsub, hsq, Or.inr ⟨hlt, rfl⟩⟩) hsub hsq + (Or.inr ⟨rfl, ?_⟩) + simp [FFL.FirstOrder.Arithmetic.pi₁, FFL.FirstOrder.Arithmetic.unpair, hlt] + +/-- The second Cantor component at an arbitrary value. -/ +theorem eval_codeUnpair₂ [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] {k : ℕ} (d : Code k) (a : M) (v : Fin k → M) + (hd : Semiformula.Evalb (a :> v) (code d)) : + Semiformula.Evalb (FFL.FirstOrder.Arithmetic.pi₂ a :> v) (code (codeUnpair₂ d)) := + by + have hsq := eval_codeSqrt d a v hd + have hmul : + Semiformula.Evalb + ((FFL.FirstOrder.Arithmetic.sqrt a * FFL.FirstOrder.Arithmetic.sqrt a) :> v) + (code (codeMul (codeSqrt d) (codeSqrt d))) := + (eval_codeMul_iff _ _ _ _).mpr ⟨_, _, hsq, hsq, rfl⟩ + have hsub := + eval_codeSub d (codeMul (codeSqrt d) (codeSqrt d)) a + (FFL.FirstOrder.Arithmetic.sqrt a * FFL.FirstOrder.Arithmetic.sqrt a) v hd hmul + have hsub2 := + eval_codeSub (codeSub d (codeMul (codeSqrt d) (codeSqrt d))) (codeSqrt d) + (a - FFL.FirstOrder.Arithmetic.sqrt a * FFL.FirstOrder.Arithmetic.sqrt a) + (FFL.FirstOrder.Arithmetic.sqrt a) v hsub hsq + simp only [codeUnpair₂] + by_cases hlt : + a - FFL.FirstOrder.Arithmetic.sqrt a * FFL.FirstOrder.Arithmetic.sqrt a < + FFL.FirstOrder.Arithmetic.sqrt a + · refine + eval_codeIfPos_of _ _ _ 1 _ _ _ v + ((eval_codeLt_iff _ _ _ _).mpr ⟨_, _, hsub, hsq, Or.inl ⟨hlt, rfl⟩⟩) hsq hsub2 + (Or.inl ⟨by simp, ?_⟩) + simp [FFL.FirstOrder.Arithmetic.pi₂, FFL.FirstOrder.Arithmetic.unpair, hlt] + · refine + eval_codeIfPos_of _ _ _ 0 _ _ _ v + ((eval_codeLt_iff _ _ _ _).mpr ⟨_, _, hsub, hsq, Or.inr ⟨hlt, rfl⟩⟩) hsq hsub2 + (Or.inr ⟨rfl, ?_⟩) + simp [FFL.FirstOrder.Arithmetic.pi₂, FFL.FirstOrder.Arithmetic.unpair, hlt] + +/-- The first Cantor component of a pair is its first argument. -/ +theorem eval_codeUnpair₁_codePair [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] {k : ℕ} (A B : Code k) (a b : M) + (v : Fin k → M) (hA : Semiformula.Evalb (a :> v) (code A)) + (hB : Semiformula.Evalb (b :> v) (code B)) : + Semiformula.Evalb (a :> v) (code (codeUnpair₁ (codePair A B))) := + by + have h := + eval_codeUnpair₁ (codePair A B) (FFL.FirstOrder.Arithmetic.pair a b) v + (eval_codePair A B a b v hA hB) + rwa [FFL.FirstOrder.Arithmetic.pi₁_pair] at h + +/-- The second Cantor component of a pair is its second argument. -/ +theorem eval_codeUnpair₂_codePair [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] {k : ℕ} (A B : Code k) (a b : M) + (v : Fin k → M) (hA : Semiformula.Evalb (a :> v) (code A)) + (hB : Semiformula.Evalb (b :> v) (code B)) : + Semiformula.Evalb (b :> v) (code (codeUnpair₂ (codePair A B))) := + by + have h := + eval_codeUnpair₂ (codePair A B) (FFL.FirstOrder.Arithmetic.pair a b) v + (eval_codePair A B a b v hA hB) + rwa [FFL.FirstOrder.Arithmetic.pi₂_pair] at h + +/-! +### Divisibility, remainder and the Gödel beta value at arbitrary values + +`codeDvd` searches for the least quotient candidate, `codeRem` searches for the +least amount whose removal leaves a multiple of the divisor, and `codeBeta` +composes the two Cantor components with that remainder. The three results below +compute each construction at arbitrary elements of a model of `𝐈𝐎𝐩𝐞𝐧`, against +the division and remainder Foundation already defines there. No division +identity is reproved; each proof identifies the searched value and shows that +the search body vanishes below it. -/ + +/-- Divisibility at arbitrary values. -/ +theorem eval_codeDvd [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] {k : ℕ} (A B : Code k) (a b z : M) (v : Fin k → M) + (hA : Semiformula.Evalb (a :> v) (code A)) (hB : Semiformula.Evalb (b :> v) (code B)) + (hz : (a ∣ b ∧ z = 1) ∨ (¬a ∣ b ∧ z = 0)) : + Semiformula.Evalb (z :> v) (code (codeDvd A B)) := + by + have hhead : ∀ t : M, Semiformula.Evalb (t :> t :> v) (code (codeHead (n := k))) := fun t => + (eval_codeHead_iff _ _).mpr rfl + have hliftA : ∀ t : M, Semiformula.Evalb (a :> t :> v) (code (codeLift A)) := fun t => + (eval_codeLift_iff A _ _ v).mpr hA + have hliftB : ∀ t : M, Semiformula.Evalb (b :> t :> v) (code (codeLift B)) := fun t => + (eval_codeLift_iff B _ _ v).mpr hB + have hEq : + ∀ t y : M, + ((t * a = b ∧ y = 1) ∨ (¬t * a = b ∧ y = 0)) → + Semiformula.Evalb (y :> t :> v) + (code (codeEq (codeMul (codeHead (n := k)) (codeLift A)) (codeLift B))) := + fun t y hy => + (eval_codeEq_iff _ _ _ _).mpr + ⟨t * a, b, (eval_codeMul_iff _ _ _ _).mpr ⟨t, a, hhead t, hliftA t, rfl⟩, hliftB t, hy⟩ + have hLt : + ∀ t y : M, + ((b < t ∧ y = 1) ∨ (¬b < t ∧ y = 0)) → + Semiformula.Evalb (y :> t :> v) (code (codeLt (codeLift B) (codeHead (n := k)))) := + fun t y hy => (eval_codeLt_iff _ _ _ _).mpr ⟨b, t, hliftB t, hhead t, hy⟩ + have hG1 : + ∀ t : M, + (t * a = b ∨ b < t) → + Semiformula.Evalb ((1 : M) :> t :> v) + (code + (codeOr (codeEq (codeMul (codeHead (n := k)) (codeLift A)) (codeLift B)) + (codeLt (codeLift B) (codeHead (n := k))))) := + by + intro t ht + by_cases h1 : t * a = b + · by_cases h2 : b < t + · exact + (eval_codeOr_iff _ _ _ _).mpr + ⟨1, 1, hEq t 1 (Or.inl ⟨h1, rfl⟩), hLt t 1 (Or.inl ⟨h2, rfl⟩), + Or.inl ⟨by simp, rfl⟩⟩ + · exact + (eval_codeOr_iff _ _ _ _).mpr + ⟨1, 0, hEq t 1 (Or.inl ⟨h1, rfl⟩), hLt t 0 (Or.inr ⟨h2, rfl⟩), + Or.inl ⟨by simp, rfl⟩⟩ + · exact + (eval_codeOr_iff _ _ _ _).mpr + ⟨0, 1, hEq t 0 (Or.inr ⟨h1, rfl⟩), hLt t 1 (Or.inl ⟨ht.resolve_left h1, rfl⟩), + Or.inl ⟨by simp, rfl⟩⟩ + have hG0 : + ∀ t : M, + ¬(t * a = b ∨ b < t) → + Semiformula.Evalb ((0 : M) :> t :> v) + (code + (codeOr (codeEq (codeMul (codeHead (n := k)) (codeLift A)) (codeLift B)) + (codeLt (codeLift B) (codeHead (n := k))))) := + fun t ht => + (eval_codeOr_iff _ _ _ _).mpr + ⟨0, 0, hEq t 0 (Or.inr ⟨fun h => ht (Or.inl h), rfl⟩), + hLt t 0 (Or.inr ⟨fun h => ht (Or.inr h), rfl⟩), Or.inr ⟨by simp, rfl⟩⟩ + simp only [codeDvd] + rw [eval_codeBind_iff] + by_cases hdvd : a ∣ b + · obtain ⟨c, hcb, hbc⟩ := dvd_iff_bounded.mp hdvd + have hz1 : z = 1 := by + rcases hz with ⟨-, h⟩ | ⟨hnd, -⟩ + · exact h + · exact absurd hdvd hnd + refine ⟨c, ?_, ?_⟩ + · rw [eval_codeRfindPos_iff] + refine ⟨⟨1, _root_.zero_lt_one, hG1 c (Or.inl ?_)⟩, ?_⟩ + · rw [mul_comm]; exact hbc.symm + · intro t ht + refine hG0 t ?_ + rintro (h1 | h2) + · by_cases ha0 : a = 0 + · have hb0 : b = 0 := by rw [hbc, ha0, zero_mul] + have hc0 : c = 0 := by + rw [hb0] at hcb + exact le_antisymm hcb (FFL.FirstOrder.Arithmetic.zero_le c) + rw [hc0] at ht + exact absurd ht (not_lt.mpr (FFL.FirstOrder.Arithmetic.zero_le t)) + · have hap : 0 < a := pos_iff_ne_zero.mpr ha0 + have hbb : b < b := by + calc + b = t * a := h1.symm + _ < c * a := (mul_lt_mul_of_pos_right ht hap) + _ = a * c := (mul_comm c a) + _ = b := hbc.symm + exact absurd hbb (_root_.lt_irrefl b) + · exact absurd (lt_of_lt_of_le ht hcb) (not_lt.mpr (le_of_lt h2)) + · rw [hz1] + exact eval_codeLe_of _ _ c b 1 _ (hhead _) (hliftB _) (Or.inl ⟨hcb, rfl⟩) + · have hz0 : z = 0 := by + rcases hz with ⟨hd, -⟩ | ⟨-, h⟩ + · exact absurd hd hdvd + · exact h + refine ⟨b + 1, ?_, ?_⟩ + · rw [eval_codeRfindPos_iff] + refine ⟨⟨1, _root_.zero_lt_one, hG1 (b + 1) (Or.inr (lt_add_one b))⟩, ?_⟩ + intro t ht + have htb : t ≤ b := FFL.FirstOrder.Arithmetic.lt_succ_iff_le.mp ht + refine hG0 t ?_ + rintro (h1 | h2) + · exact absurd ⟨t, by rw [← h1, mul_comm]⟩ hdvd + · exact absurd h2 (not_lt.mpr htb) + · rw [hz0] + refine eval_codeLe_of _ _ (b + 1) b 0 _ (hhead _) (hliftB _) (Or.inr ⟨?_, rfl⟩) + intro hcon + exact absurd (lt_of_lt_of_le (lt_add_one b) hcon) (_root_.lt_irrefl b) + +/-- The remainder at arbitrary values. -/ +theorem eval_codeRem [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] {k : ℕ} (A B : Code k) (a b : M) (v : Fin k → M) + (hA : Semiformula.Evalb (a :> v) (code A)) (hB : Semiformula.Evalb (b :> v) (code B)) : + Semiformula.Evalb ((a % b) :> v) (code (codeRem A B)) := + by + have hhead : ∀ t : M, Semiformula.Evalb (t :> t :> v) (code (codeHead (n := k))) := fun t => + (eval_codeHead_iff _ _).mpr rfl + have hliftA : ∀ t : M, Semiformula.Evalb (a :> t :> v) (code (codeLift A)) := fun t => + (eval_codeLift_iff A _ _ v).mpr hA + have hliftB : ∀ t : M, Semiformula.Evalb (b :> t :> v) (code (codeLift B)) := fun t => + (eval_codeLift_iff B _ _ v).mpr hB + have hsub : + ∀ t : M, + Semiformula.Evalb ((a - t) :> t :> v) (code (codeSub (codeLift A) (codeHead (n := k)))) := + fun t => eval_codeSub (codeLift A) (codeHead (n := k)) a t (t :> v) (hliftA t) (hhead t) + have hdm : b * (a / b) + a % b = a := div_add_mod a b + simp only [codeRem] + rw [eval_codeRfindPos_iff] + constructor + · refine ⟨1, _root_.zero_lt_one, ?_⟩ + refine + eval_codeDvd (codeLift B) (codeSub (codeLift A) (codeHead (n := k))) b (a - a % b) 1 _ + (hliftB _) (hsub _) (Or.inl ⟨?_, rfl⟩) + have hsplit : a - a % b = b * (a / b) := FFL.FirstOrder.Arithmetic.sub_remove_left hdm.symm + rw [hsplit] + exact Dvd.intro _ rfl + · intro t ht + refine + eval_codeDvd (codeLift B) (codeSub (codeLift A) (codeHead (n := k))) b (a - t) 0 _ + (hliftB _) (hsub _) (Or.inr ⟨?_, rfl⟩) + intro hdvd + rcases eq_or_ne b 0 with hb0 | hb0 + · rw [hb0, FFL.FirstOrder.Arithmetic.mod_zero] at ht + rw [hb0] at hdvd + exact absurd ht (not_lt.mpr (sub_eq_zero_iff_le.mp (zero_dvd_iff.mp hdvd))) + · have hbpos : 0 < b := pos_iff_ne_zero.mpr hb0 + have hmlt : a % b < b := mod_lt a hbpos + have hsplit : a - t = b * (a / b) + (a % b - t) := + by + conv_lhs => rw [← hdm] + exact add_sub_of_le (le_of_lt ht) _ + have hmod : (a - t) % b = a % b - t := by + rw [hsplit, mod_mul_add' (a / b) (a % b - t) hbpos, + mod_eq_self_of_lt (lt_of_le_of_lt (FFL.FirstOrder.Arithmetic.sub_le_self _ _) hmlt)] + have hzero : a % b - t = 0 := by rw [← hmod]; exact mod_eq_zero_iff_dvd.mpr hdvd + have hpos : 0 < a % b - t := pos_sub_iff_lt.mpr ht + rw [hzero] at hpos + exact absurd hpos (_root_.lt_irrefl 0) + +/-- The Gödel beta value at arbitrary values. `eval_codeBeta` in `Arithmetic` +computes the same construction over `ℕ`; this result instead proves that the +graph of `codeBeta N I` holds at the displayed remainder in an arbitrary model. +It does not assert the existence of a finite sequence with that beta value. -/ +theorem eval_codeBeta_of_values [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] {k : ℕ} (N I : Code k) (n i : M) + (v : Fin k → M) (hN : Semiformula.Evalb (n :> v) (code N)) + (hI : Semiformula.Evalb (i :> v) (code I)) : + Semiformula.Evalb + ((FFL.FirstOrder.Arithmetic.pi₁ n % ((i + 1) * FFL.FirstOrder.Arithmetic.pi₂ n + 1)) :> v) + (code (codeBeta N I)) := + by + have h1 := eval_codeUnpair₁ N n v hN + have h2 := eval_codeUnpair₂ N n v hN + have hsi : Semiformula.Evalb ((i + 1) :> v) (code (codeSucc I)) := + (eval_codeSucc_iff _ _ _).mpr ⟨i, hI, rfl⟩ + have hmul : + Semiformula.Evalb (((i + 1) * FFL.FirstOrder.Arithmetic.pi₂ n) :> v) + (code (codeMul (codeSucc I) (codeUnpair₂ N))) := + (eval_codeMul_iff _ _ _ _).mpr ⟨_, _, hsi, h2, rfl⟩ + have hsucc : + Semiformula.Evalb (((i + 1) * FFL.FirstOrder.Arithmetic.pi₂ n + 1) :> v) + (code (codeSucc (codeMul (codeSucc I) (codeUnpair₂ N)))) := + (eval_codeSucc_iff _ _ _).mpr ⟨_, hmul, rfl⟩ + simp only [codeBeta] + exact eval_codeRem _ _ _ _ v h1 hsucc + +end ArithmeticCode +end CategoricalRiceShapiro + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/Pairing.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/Pairing.lean new file mode 100644 index 000000000..865107f74 --- /dev/null +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/Pairing.lean @@ -0,0 +1,45 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.Conditional + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# Cantor pairing + +The pairing construction inverted by `codeUnpair₁` and `codeUnpair₂` in +`CategoricalRiceShapiro.ArithmeticCode.Arithmetic`. It needs only the +conditional, not minimization, and so does not depend on that module. + +Only the code construction is given here. The standard computation theorem +over the natural numbers is not part of this migration. +-/ + +@[expose] public section + +open _root_.Nat Nat Nat.ArithPart₁ + +namespace CategoricalRiceShapiro +namespace ArithmeticCode + +/-- Cantor pairing of `d₀` and `d₁`. -/ +def codePair {n : ℕ} (d₀ d₁ : Code n) : Code n := + codeIfPos (codeLt d₀ d₁) (codeAdd (codeMul d₁ d₁) d₀) + (codeAdd (codeAdd (codeMul d₀ d₀) d₀) d₁) + +end ArithmeticCode +end CategoricalRiceShapiro + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/PartialRecursive.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/PartialRecursive.lean new file mode 100644 index 000000000..5051cfb63 --- /dev/null +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/PartialRecursive.lean @@ -0,0 +1,135 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.Recursion + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# Decoding a partial-recursive index + +Mathlib's `Nat.Partrec.Code` encoding sends the four base constructors to `0`–`3` +and encodes a compound code as `2 * (2 * payload + b₀) + b₁ + 4`, where the two +bits `b₀` and `b₁` name the constructor: `4` pairing, `5` composition, `6` +primitive recursion, `7` minimization. + +`codePartrecTag` recovers the constructor number and `codePartrecPayload` the +payload, whose Cantor components `codePartrecPayload₁` and `codePartrecPayload₂` +are the two subcodes of a binary constructor. The bit extraction needs parity +and halving, which are defined here from remainder and primitive recursion. + +Each construction is accompanied by the theorem that it realizes the intended +function over the natural numbers. Those `Computes` theorems are the input of +the standard-model bridge, which turns a computation over `ℕ` into evaluation at +standard numerals in an arbitrary model. +-/ + +@[expose] public section + +open _root_.Nat Nat Nat.ArithPart₁ + +namespace CategoricalRiceShapiro +namespace ArithmeticCode + +/-! +### The numeric view + +The functions the codes below realize. The constructor numbers are `0 zero`, +`1 succ`, `2 left`, `3 right`, `4 pair`, `5 comp`, `6 prec`, `7 rfind'`. For +`q = r + 4` the payload is `r.div2.div2`; a binary constructor reads its Cantor +components and minimization reads the payload itself. -/ + +/-- The constructor number of a partial-recursive index. -/ +def partrecCodeTag (q : ℕ) : ℕ := + if q < 4 then q + else + let r := q - 4 + 4 + 2 * r.bodd.toNat + r.div2.bodd.toNat + +/-- The payload of a compound partial-recursive index. -/ +def partrecCodePayload (q : ℕ) : ℕ := + (q - 4).div2.div2 + +/-- The first subcode of a binary partial-recursive constructor. -/ +def partrecCodePayload₁ (q : ℕ) : ℕ := + (partrecCodePayload q).unpair.1 + +/-- The second subcode of a binary partial-recursive constructor. -/ +def partrecCodePayload₂ (q : ℕ) : ℕ := + (partrecCodePayload q).unpair.2 + +/-! +### The realizing codes -/ + +/-- The parity bit of `d`. -/ +def codeBodd {n : ℕ} (d : Code n) : Code n := + codeRem d (codeConst 2) + +/-- Halving, as a unary code, by primitive recursion on the argument. -/ +def codeDiv2Unary : Code 1 := + codePrec (Code.zero 0) + (codeIfPos (codeBodd (Code.proj 0)) (codeSucc (Code.proj 1)) (Code.proj 1)) + +/-- Halving of `d`, rounding down. -/ +def codeDiv2 {n : ℕ} (d : Code n) : Code n := + codeDiv2Unary.comp ![d] + +/-- The constructor number of the partial-recursive index `d`: the index itself +below `4`, and otherwise `4` plus the two bits of `d - 4`. -/ +def codePartrecTag {n : ℕ} (d : Code n) : Code n := + let r := codeSub d (codeConst 4) + codeIfPos (codeLt d (codeConst 4)) d + (codeAdd (codeAdd (codeConst 4) (codeMul (codeConst 2) (codeBodd r))) + (codeBodd (codeDiv2 r))) + +/-- The payload of a compound partial-recursive index. -/ +def codePartrecPayload {n : ℕ} (d : Code n) : Code n := + codeDiv2 (codeDiv2 (codeSub d (codeConst 4))) + +/-- The first subcode of a binary partial-recursive constructor. -/ +def codePartrecPayload₁ {n : ℕ} (d : Code n) : Code n := + codeUnpair₁ (codePartrecPayload d) + +/-- The second subcode of a binary partial-recursive constructor. -/ +def codePartrecPayload₂ {n : ℕ} (d : Code n) : Code n := + codeUnpair₂ (codePartrecPayload d) + +/-! +### Standard computations over the natural numbers -/ + +theorem computes_codeBodd {n : ℕ} {d : Code n} {g : List.Vector ℕ n → ℕ} (h : Computes d g) : + Computes (codeBodd d) (fun v => (Nat.bodd (g v)).toNat) := + (computes_codeRem h (computes_codeConst 2)).of_eq (fun v => Nat.mod_two_of_bodd (g v)) + +theorem computes_codeDiv2Unary : Computes codeDiv2Unary (fun v => Nat.div2 v.head) := + by + refine + (computes_codePrec computes_zero + (computes_codeIfPos (computes_codeBodd (computes_proj 0)) + (computes_codeSucc (computes_proj 1)) (computes_proj 1))).of_eq + ?_ + intro v + simp only [List.Vector.get_zero, List.Vector.get_one, List.Vector.head_cons, + List.Vector.tail_cons] + generalize v.head = m + induction m with + | zero => exact Nat.div2_zero.symm + | succ y IH => + rw [Nat.div2_succ] + cases hb : Nat.bodd y <;> simp [hb, IH] + +end ArithmeticCode +end CategoricalRiceShapiro + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/PartialRecursiveEvaluation.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/PartialRecursiveEvaluation.lean new file mode 100644 index 000000000..ff266e3fd --- /dev/null +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/PartialRecursiveEvaluation.lean @@ -0,0 +1,135 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.PartialRecursive +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.RecursionEvaluation + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# Evaluation existence for the partial-recursive index decoders + +`PartialRecursive` defines the four codes that read a partial-recursive index: +its constructor tag, its payload, and the two components of that payload. This +file proves that each has a value in an arbitrary model of `𝐏𝐀`, given a value +for the index. + +Nothing here decodes an index or asserts what the value is. For an arbitrary +element of the model the constructions still terminate, and only that is +proved; no witness is identified with a quotient, a remainder or a Cantor +component of an external number. + +The tag is an eager conditional, so both of its branches are evaluated before +the test selects one: the index itself, and the compound tag built from the two +parity bits of the shifted index. +-/ + +@[expose] public section + +open _root_.Nat Nat Nat.ArithPart₁ + +namespace CategoricalRiceShapiro +namespace ArithmeticCode + +open Encodable FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +open scoped FFL.FirstOrder.Arithmetic + +/-- The payload of a partial-recursive index has a value at any value of the +index: the shifted index is a truncated difference, and halving it twice has a +value by `eval_codeDiv2_exists_of_value`. -/ +theorem eval_codePartrecPayload_exists_of_value {M : Type*} [ORingStructure M] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] + {k : ℕ} (d : Code k) (q : M) (v : Fin k → M) (hd : Semiformula.Evalb (q :> v) (code d)) : + ∃ z : M, Semiformula.Evalb (z :> v) (code (codePartrecPayload d)) := + by + let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + have hfour : Semiformula.Evalb ((4 : M) :> v) (code (codeConst (n := k) 4)) := by + rw [eval_codeConst_iff]; simp + obtain ⟨w, hw⟩ := + eval_codeDiv2_exists_of_value (codeSub d (codeConst 4)) (q - 4) v + (eval_codeSub d (codeConst 4) q 4 v hd hfour) + exact eval_codeDiv2_exists_of_value (codeDiv2 (codeSub d (codeConst 4))) w v hw + +/-- The first payload component has a value at any value of the index. -/ +theorem eval_codePartrecPayload₁_exists_of_value {M : Type*} [ORingStructure M] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] + {k : ℕ} (d : Code k) (q : M) (v : Fin k → M) (hd : Semiformula.Evalb (q :> v) (code d)) : + ∃ z : M, Semiformula.Evalb (z :> v) (code (codePartrecPayload₁ d)) := + by + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + obtain ⟨w, hw⟩ := eval_codePartrecPayload_exists_of_value d q v hd + exact ⟨_, eval_codeUnpair₁ (codePartrecPayload d) w v hw⟩ + +/-- The second payload component has a value at any value of the index. -/ +theorem eval_codePartrecPayload₂_exists_of_value {M : Type*} [ORingStructure M] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] + {k : ℕ} (d : Code k) (q : M) (v : Fin k → M) (hd : Semiformula.Evalb (q :> v) (code d)) : + ∃ z : M, Semiformula.Evalb (z :> v) (code (codePartrecPayload₂ d)) := + by + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + obtain ⟨w, hw⟩ := eval_codePartrecPayload_exists_of_value d q v hd + exact ⟨_, eval_codeUnpair₂ (codePartrecPayload d) w v hw⟩ + +/-- The constructor tag of a partial-recursive index has a value at any value of +the index. + +`codeIfPos` is eager, so both branches are evaluated whatever the test does: the +index itself, and the compound tag `4 + 2 * (r % 2) + (h % 2)`, where `r` is the +shifted index and `h` is some value of its half. The comparison against `4` +then selects one of the two. -/ +theorem eval_codePartrecTag_exists_of_value {M : Type*} [ORingStructure M] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] + {k : ℕ} (d : Code k) (q : M) (v : Fin k → M) (hd : Semiformula.Evalb (q :> v) (code d)) : + ∃ z : M, Semiformula.Evalb (z :> v) (code (codePartrecTag d)) := + by + let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + have hfour : Semiformula.Evalb ((4 : M) :> v) (code (codeConst (n := k) 4)) := by + rw [eval_codeConst_iff]; simp + have htwo : Semiformula.Evalb ((2 : M) :> v) (code (codeConst (n := k) 2)) := by + rw [eval_codeConst_iff]; simp + have hshift := eval_codeSub d (codeConst 4) q 4 v hd hfour + have hbodd : + Semiformula.Evalb (((q - 4) % 2) :> v) (code (codeBodd (codeSub d (codeConst 4)))) := + eval_codeRem (codeSub d (codeConst 4)) (codeConst 2) (q - 4) 2 v hshift htwo + obtain ⟨h, hh⟩ := eval_codeDiv2_exists_of_value (codeSub d (codeConst 4)) (q - 4) v hshift + have hbodd2 : + Semiformula.Evalb ((h % 2) :> v) (code (codeBodd (codeDiv2 (codeSub d (codeConst 4))))) := + eval_codeRem (codeDiv2 (codeSub d (codeConst 4))) (codeConst 2) h 2 v hh htwo + have hcompound : + Semiformula.Evalb ((4 + 2 * ((q - 4) % 2) + h % 2) :> v) + (code + (codeAdd + (codeAdd (codeConst 4) (codeMul (codeConst 2) (codeBodd (codeSub d (codeConst 4))))) + (codeBodd (codeDiv2 (codeSub d (codeConst 4)))))) := + (eval_codeAdd_iff _ _ _ _).mpr + ⟨4 + 2 * ((q - 4) % 2), h % 2, + (eval_codeAdd_iff _ _ _ _).mpr + ⟨4, 2 * ((q - 4) % 2), hfour, + (eval_codeMul_iff _ _ _ _).mpr ⟨2, (q - 4) % 2, htwo, hbodd, rfl⟩, rfl⟩, + hbodd2, rfl⟩ + by_cases hq : q < 4 + · exact + ⟨q, + eval_codeIfPos_of _ _ _ 1 q (4 + 2 * ((q - 4) % 2) + h % 2) q v + ((eval_codeLt_iff _ _ _ _).mpr ⟨q, 4, hd, hfour, Or.inl ⟨hq, rfl⟩⟩) hd hcompound + (Or.inl ⟨by simp, rfl⟩)⟩ + · exact + ⟨4 + 2 * ((q - 4) % 2) + h % 2, + eval_codeIfPos_of _ _ _ 0 q (4 + 2 * ((q - 4) % 2) + h % 2) + (4 + 2 * ((q - 4) % 2) + h % 2) v + ((eval_codeLt_iff _ _ _ _).mpr ⟨q, 4, hd, hfour, Or.inr ⟨hq, rfl⟩⟩) hd hcompound + (Or.inr ⟨rfl, rfl⟩)⟩ + +end ArithmeticCode +end CategoricalRiceShapiro + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/Recursion.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/Recursion.lean new file mode 100644 index 000000000..2bf126c1d --- /dev/null +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/Recursion.lean @@ -0,0 +1,276 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.Arithmetic + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# Bounded search and primitive recursion + +`codeBall` decides a bounded universal statement by minimizing the first +counterexample. The primitive-recursion constructor `codePrec` minimizes a +Gödel-beta code of the whole computation history: `codePrecPredicate` states +that a candidate history has the right initial entry and satisfies the step +relation `codePrecStep` at every index below the argument, and `codePrec` +reads the final entry out of the least such history. + +Each construction is accompanied by the theorem that it realizes the intended +function over the natural numbers. Those `Computes` theorems are the input of +the standard-model bridge, which turns a computation over `ℕ` into evaluation at +standard numerals in an arbitrary model. +-/ + +@[expose] public section + +open _root_.Nat Nat Nat.ArithPart₁ + +namespace CategoricalRiceShapiro +namespace ArithmeticCode + +/-- The characteristic value of `∀ j ≤ v i, dφ j`, decided by minimizing the +first index at which `dφ` fails or the bound is passed. -/ +def codeBall {n : ℕ} (dφ : Code (n + 1)) (i : Fin n) : Code n := + codeBind (codeRfindPos (codeOr (codeInv dφ) (codeLe (codeLift (Code.proj i)) codeHead))) + (codeEq codeHead (codeLift (Code.proj i))) + +/-- The arguments at which the step function is applied inside a history: the +history index, the entry recorded at that index, and the ambient arguments. -/ +def precStepArgs {n : ℕ} : Fin (n + 2) → Code (n + 3) := + Fin.cases (Code.proj 0) + (Fin.cases (codeBeta (Code.proj 1) (Code.proj 0)) (fun j => Code.proj j.succ.succ.succ)) + +/-- The step relation between consecutive entries of a history. -/ +def codePrecStep {n : ℕ} (dg : Code (n + 2)) : Code (n + 3) := + codeEq (codeBeta (Code.proj 1) (codeSucc (Code.proj 0))) (dg.comp precStepArgs) + +/-- Reindex a code past the history and index arguments. -/ +def codeTailTail {n : ℕ} (df : Code n) : Code (n + 2) := + df.comp (fun j => Code.proj j.succ.succ) + +/-- A candidate history is correct: its initial entry is the base value, and +every step below the argument agrees with the step function. -/ +def codePrecPredicate {n : ℕ} (df : Code n) (dg : Code (n + 2)) : Code (n + 2) := + codeAnd (codeEq (codeBeta (Code.proj 0) (codeConst 0)) (codeTailTail df)) + (codeBall (codePrecStep dg) 1) + +/-- Primitive recursion with base `df` and step `dg`, read from the least +correct history. -/ +def codePrec {n : ℕ} (df : Code n) (dg : Code (n + 2)) : Code (n + 1) := + codeBind (codeRfindPos (codePrecPredicate df dg)) (codeBeta codeHead (codeLift codeHead)) + +/-! +### Standard computations over the natural numbers -/ + +theorem computes_codeBall {n : ℕ} {dφ : Code (n + 1)} {φ : List.Vector ℕ n → ℕ → ℕ} + (hφ : Computes dφ (fun w => φ w.tail w.head)) (i : Fin n) : + Computes (codeBall dφ i) (fun v => Nat.ball (v.get i) (φ v)) := + by + have hF : + Computes (codeOr (codeInv dφ) (codeLe (codeLift (Code.proj i)) codeHead)) + (fun w => Nat.or (Nat.inv (φ w.tail w.head)) (isLeNat (w.tail.get i) w.head)) := + computes_codeOr (computes_codeInv hφ) + (computes_codeLe (computes_codeLift (computes_proj i)) computes_codeHead) + have hb := + eval_codeBind (eval_codeRfindPos hF) + (computes_codeEq computes_codeHead (computes_codeLift (computes_proj i))) + refine eval_of_eq hb ?_ + funext v + have key : + ∀ x : ℕ, (0 < Nat.or (Nat.inv (φ v x)) (isLeNat (v.get i) x)) ↔ (φ v x = 0 ∨ v.get i ≤ x) := + by + intro x + simp only [Nat.orNat_pos_iff, Nat.inv_pos_iff, isLeNat_pos_iff] + omega + simp only [List.Vector.head_cons, List.Vector.tail_cons, Part.coe_some] + rw [Part.eq_some_iff, Part.mem_bind_iff] + by_cases H : ∀ m < v.get i, 0 < φ v m + · refine ⟨v.get i, ?_, ?_⟩ + · refine Nat.mem_rfind.mpr ?_ + refine ⟨?_, ?_⟩ + · rw [Part.mem_some_iff, eq_comm, decide_eq_true_eq] + exact (key (v.get i)).mpr (Or.inr (le_refl _)) + · intro m hm + rw [Part.mem_some_iff, eq_comm, decide_eq_false_iff_not] + intro hcon + rcases (key m).mp hcon with h0 | hle + · have := H m hm; omega + · omega + · have hb1 : Nat.ball (v.get i) (φ v) = 1 := + Nat.ball_pos_iff_eq_one.mpr (Nat.ball_pos_iff.mpr H) + simp [isEqNat, hb1] + · have Hex : ∃ m, m < v.get i ∧ φ v m = 0 := + by + by_contra hc + refine H (fun m hm => ?_) + rcases Nat.eq_zero_or_pos (φ v m) with h0 | hp + · exact absurd ⟨m, hm, h0⟩ hc + · exact hp + obtain ⟨hx, hpx⟩ := Nat.find_spec Hex + have hlx : ∀ y, y < Nat.find Hex → ¬(y < v.get i ∧ φ v y = 0) := fun y hy => + Nat.find_min Hex hy + refine ⟨Nat.find Hex, ?_, ?_⟩ + · refine Nat.mem_rfind.mpr ?_ + refine ⟨?_, ?_⟩ + · rw [Part.mem_some_iff, eq_comm, decide_eq_true_eq] + exact (key (Nat.find Hex)).mpr (Or.inl hpx) + · intro m hm + rw [Part.mem_some_iff, eq_comm, decide_eq_false_iff_not] + intro hcon + rcases (key m).mp hcon with h0 | hle + · exact hlx m hm ⟨by omega, h0⟩ + · omega + · have hb0 : Nat.ball (v.get i) (φ v) = 0 := + Nat.ball_eq_zero_iff.mpr ⟨Nat.find Hex, hx, hpx⟩ + have hne : Nat.find Hex ≠ v.get i := by omega + simp [isEqNat, hb0, hne] + +private def precStepVals {n : ℕ} : Fin (n + 2) → List.Vector ℕ (n + 3) → ℕ := + Fin.cases (fun w => w.get 0) + (Fin.cases (fun w => Nat.beta (w.get 1) (w.get 0)) (fun j w => w.get j.succ.succ.succ)) + +private lemma computes_precStepArgs {n : ℕ} (k : Fin (n + 2)) : + Computes (precStepArgs (n := n) k) (precStepVals k) := + by + refine Fin.cases ?_ ?_ k + · exact computes_proj 0 + · intro j + refine Fin.cases ?_ ?_ j + · exact eval_codeBeta (computes_proj 1) (computes_proj 0) + · intro l; exact computes_proj _ + +private lemma ofFn_precStepVals {n : ℕ} (w : List.Vector ℕ (n + 3)) : + (List.Vector.ofFn fun k => precStepVals k w) = + w.head ::ᵥ Nat.beta w.tail.head w.head ::ᵥ w.tail.tail.tail := + by + refine List.Vector.ext ?_ + intro k + refine Fin.cases ?_ ?_ k + · simp [precStepVals] + · intro j + refine Fin.cases ?_ ?_ j + · simp [precStepVals, List.Vector.get_one] + · intro l + simp only [precStepVals, Fin.cases_succ, List.Vector.get_ofFn] + exact + (((List.Vector.get_tail_succ w.tail.tail l).trans + (List.Vector.get_tail_succ w.tail l.succ)).trans + (List.Vector.get_tail_succ w l.succ.succ)).symm + +theorem computes_codePrecStep {n : ℕ} {dg : Code (n + 2)} {g : List.Vector ℕ (n + 2) → ℕ} + (hg : Computes dg g) : + Computes (codePrecStep dg) + (fun w => + isEqNat (Nat.beta w.tail.head (w.head + 1)) + (g (w.head ::ᵥ Nat.beta w.tail.head w.head ::ᵥ w.tail.tail.tail))) := + by + refine + (computes_codeEq (eval_codeBeta (computes_proj 1) (computes_codeSucc (computes_proj 0))) + (computes_comp hg computes_precStepArgs)).of_eq + ?_ + intro w + rw [ofFn_precStepVals] + simp [List.Vector.get_one] + +private lemma computes_codeTailTail {n : ℕ} {df : Code n} {f : List.Vector ℕ n → ℕ} + (hf : Computes df f) : Computes (codeTailTail df) (fun w => f w.tail.tail) := + by + refine + (computes_comp (g := fun j w => w.get j.succ.succ) hf + (fun j => computes_proj j.succ.succ)).of_eq + ?_ + intro w + congr 1 + refine List.Vector.ext ?_ + intro j + simp only [List.Vector.get_ofFn] + exact ((List.Vector.get_tail_succ w.tail j).trans (List.Vector.get_tail_succ w j.succ)).symm + +theorem computes_codePrecPredicate {n : ℕ} {df : Code n} {dg : Code (n + 2)} + {f : List.Vector ℕ n → ℕ} {g : List.Vector ℕ (n + 2) → ℕ} (hf : Computes df f) + (hg : Computes dg g) : + Computes (codePrecPredicate df dg) + (fun w => + Nat.and (isEqNat (Nat.beta w.head 0) (f w.tail.tail)) + (Nat.ball w.tail.head + (fun i => + isEqNat (Nat.beta w.head (i + 1)) + (g (i ::ᵥ Nat.beta w.head i ::ᵥ w.tail.tail))))) := + by + have hball := + computes_codeBall (φ := fun (v : List.Vector ℕ (n + 2)) (i : ℕ) => + isEqNat (Nat.beta v.head (i + 1)) (g (i ::ᵥ Nat.beta v.head i ::ᵥ v.tail.tail))) + (computes_codePrecStep hg) (1 : Fin (n + 2)) + refine + (computes_codeAnd + (computes_codeEq (eval_codeBeta (computes_proj 0) (computes_codeConst 0)) + (computes_codeTailTail hf)) + hball).of_eq + ?_ + intro w + simp [List.Vector.get_one] + +theorem computes_codePrec {n : ℕ} {df : Code n} {dg : Code (n + 2)} {f : List.Vector ℕ n → ℕ} + {g : List.Vector ℕ (n + 2) → ℕ} (hf : Computes df f) (hg : Computes dg g) : + Computes (codePrec df dg) + (fun v => v.head.rec (f v.tail) (fun y IH => g (y ::ᵥ IH ::ᵥ v.tail))) := + by + have hb := + eval_codeBind (eval_codeRfindPos (computes_codePrecPredicate hf hg)) + (eval_codeBeta computes_codeHead (computes_codeLift computes_codeHead)) + refine eval_of_eq hb ?_ + funext v + have key : + ∀ m : ℕ, + (0 < + Nat.and (isEqNat (Nat.beta m 0) (f v.tail)) + (Nat.ball v.head + (fun i => isEqNat (Nat.beta m (i + 1)) (g (i ::ᵥ Nat.beta m i ::ᵥ v.tail))))) ↔ + (Nat.beta m 0 = f v.tail ∧ + ∀ i < v.head, Nat.beta m (i + 1) = g (i ::ᵥ Nat.beta m i ::ᵥ v.tail)) := + by + intro m + simp only [Nat.and_pos_iff, isEqNat_pos_iff, Nat.ball_pos_iff] + have hex : + ∃ z : ℕ, + Nat.beta z 0 = f v.tail ∧ + ∀ i < v.head, Nat.beta z (i + 1) = g (i ::ᵥ Nat.beta z i ::ᵥ v.tail) := + ⟨Nat.unbeta (Nat.Arithmetic₁.recSequence f g v.head v.tail), + Nat.Arithmetic₁.beta_unbeta_recSequence_zero f g v.head v.tail, fun i hi => + Nat.Arithmetic₁.beta_unbeta_recSequence_succ f g v.head v.tail hi⟩ + obtain ⟨hz0, hzs⟩ := Nat.find_spec hex + have hzm : + ∀ m, + m < Nat.find hex → + ¬(Nat.beta m 0 = f v.tail ∧ + ∀ i < v.head, Nat.beta m (i + 1) = g (i ::ᵥ Nat.beta m i ::ᵥ v.tail)) := + fun m hm => Nat.find_min hex hm + simp only [List.Vector.head_cons, List.Vector.tail_cons, Part.coe_some] + rw [Part.eq_some_iff, Part.mem_bind_iff] + refine ⟨Nat.find hex, ?_, ?_⟩ + · refine Nat.mem_rfind.mpr ?_ + refine ⟨?_, ?_⟩ + · rw [Part.mem_some_iff, eq_comm, decide_eq_true_eq] + exact (key (Nat.find hex)).mpr ⟨hz0, hzs⟩ + · intro m hm + rw [Part.mem_some_iff, eq_comm, decide_eq_false_iff_not] + intro hcon + exact hzm m hm ((key m).mp hcon) + · rw [Part.mem_some_iff] + exact (Nat.Arithmetic₁.beta_eq_rec f g hz0 hzs).symm + +end ArithmeticCode +end CategoricalRiceShapiro + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/RecursionEvaluation.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/RecursionEvaluation.lean new file mode 100644 index 000000000..b882f7b6e --- /dev/null +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/RecursionEvaluation.lean @@ -0,0 +1,1974 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.Recursion +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.Evaluation +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.EvaluationCongruence +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.NumeralEvaluation +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.BetaCoding +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Schemata + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# Evaluation properties of primitive-recursion codes + +`codePrecStep dg` is the step relation of `codePrec`. It has `n + 3` +arguments: the history index, the history code, the recursion argument, and the +`n` outer arguments. It never reads argument `2`, the recursion argument: +`precStepArgs` supplies `Code.proj 0`, `codeBeta (Code.proj 1) (Code.proj 0)`, +and the outer projections, none of which is `Code.proj 2`. + +`eval_codePrecStep_bound_irrel_iff` records that, so a caller may change the +recursion argument without disturbing the step relation. The proof is +structural: `InputsAgree` is a conservative dependency relation on the nine +`Code` constructors, and `eval_iff_of_inputsAgree` turns it into an equivalence +of evaluations. + +The proof of `eval_codePrecStep_bound_irrel_iff` does not evaluate `codeBeta` +or any other derived constructor in the model. It inspects those codes only as +syntax trees and assumes no arithmetic theory: `ORingStructure M` alone. The +existence theorem below instead uses arithmetic evaluation and beta extension +under `𝐏𝐀`. +-/ + +@[expose] public section + +open _root_.Nat Nat Nat.ArithPart₁ + +namespace CategoricalRiceShapiro +namespace ArithmeticCode + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +section Syntactic + +variable {M : Type*} + +/-! +### A conservative dependency relation -/ + +/-- `InputsAgree c v v'` is a sufficient syntactic condition for `c` to evaluate the +same way under the two assignments. + +The `comp` clause is the delicate one. `Code.comp c d` evaluates **every** +argument code `d i`, and an argument may be partial, so an argument may not be +ignored merely because the outer code does not read its position. Each argument +is therefore classified by `src`: + +* `src i = some s` records that `d i` is the projection `Code.proj s`. + Projections are total, so this argument contributes `v s` on one side and + `v' s` on the other, and the two intermediate vectors may genuinely differ + there. +* `src i = none` requires `d i` to agree outright, so it contributes one shared + value to both intermediate vectors. + +The outer code must then agree under the two assembled vectors, for every choice +of the shared values. Both alternatives are needed: +`codeLift d = d.comp (fun i => Code.proj i.succ)` is all projections, and +`codeBind dg dc = dc.comp (Fin.cases dg fun i => Code.proj i)` mixes one +agreeing argument with projections. +-/ +private noncomputable def InputsAgree : {k : ℕ} → Code k → (Fin k → M) → (Fin k → M) → Prop + | _, .zero _, _, _ => True + | _, .one _, _, _ => True + | _, .add i j, v, v' => v i = v' i ∧ v j = v' j + | _, .mul i j, v, v' => v i = v' i ∧ v j = v' j + | _, .proj i, v, v' => v i = v' i + | _, .equal i j, v, v' => v i = v' i ∧ v j = v' j + | _, .lt i j, v, v' => v i = v' i ∧ v j = v' j + | m, @Code.comp _ n c d, v, v' => + ∃ src : Fin n → Option (Fin m), + (∀ i s, src i = some s → d i = Code.proj s) ∧ + (∀ i, src i = none → InputsAgree (d i) v v') ∧ + ∀ u : Fin n → M, + InputsAgree c (fun i => (src i).elim (u i) v) (fun i => (src i).elim (u i) v') + | _, .rfind body, v, v' => ∀ t : M, InputsAgree body (t :> v) (t :> v') + +end Syntactic + +section Semantic + +variable {M : Type*} [ORingStructure M] + +/-! +### Evaluation respects the dependency relation -/ + +/-- `code` differs from `codeAux` by a renaming that evaluation absorbs. -/ +private theorem evalb_iff_evalf {k : ℕ} (c : Code k) (z : M) (w : Fin k → M) : + Semiformula.Evalb (z :> w) (code c) ↔ Semiformula.Evalf (M := M) (z :> w) (codeAux c) := by + simp [code, Semiformula.eval_rew, Matrix.empty_eq, Function.comp_def] + +/-- Evaluation of a search for a zero. Kept private: an identical +characterisation is already private to +`CategoricalRiceShapiro.ArithmeticCode.EvaluationCongruence`, which this module +cannot see. -/ +private theorem eval_rfind_iff' {k : ℕ} (c : Code (k + 1)) (z : M) (v : Fin k → M) : + Semiformula.Evalb (z :> v) (code (Code.rfind c)) ↔ + (Semiformula.Evalb ((0 : M) :> z :> v) (code c) ∧ + ∀ t : M, t < z → ∃ x : M, x ≠ 0 ∧ Semiformula.Evalb (x :> t :> v) (code c)) := + by + simp only [evalb_iff_evalf] + simp [codeAux, Semiformula.eval_rew, Function.comp_def, Matrix.empty_eq, Matrix.comp_vecCons'] + +/-- Agreeing inputs give equivalent evaluations. -/ +private theorem eval_iff_of_inputsAgree : + ∀ {k : ℕ} (c : Code k) (z : M) (v v' : Fin k → M), + InputsAgree c v v' → + (Semiformula.Evalb (z :> v) (code c) ↔ Semiformula.Evalb (z :> v') (code c)) := + by + intro k c + induction c with + | zero m => intro z v v' _; rw [eval_zero_iff, eval_zero_iff] + | one m => intro z v v' _; rw [eval_one_iff, eval_one_iff] + | add i j => + intro z v v' h + rw [InputsAgree] at h + rw [eval_add_iff, eval_add_iff, h.1, h.2] + | mul i j => + intro z v v' h + rw [InputsAgree] at h + rw [eval_mul_iff, eval_mul_iff, h.1, h.2] + | proj i => + intro z v v' h + rw [InputsAgree] at h + rw [eval_proj_iff, eval_proj_iff, h] + | equal i j => + intro z v v' h + rw [InputsAgree] at h + rw [eval_equal_iff, eval_equal_iff, h.1, h.2] + | lt i j => + intro z v v' h + rw [InputsAgree] at h + rw [eval_lt_iff, eval_lt_iff, h.1, h.2] + | comp c d ihc ihd => + intro z v v' h + rw [InputsAgree] at h + obtain ⟨src, hproj, hagree, houter⟩ := h + rw [eval_comp_iff, eval_comp_iff] + constructor + · rintro ⟨w, hw, hi⟩ + have hwv : w = fun i => (src i).elim (w i) v := + by + funext i + cases hsi : src i with + | none => simp + | some t => + have hd := hi i + rw [hproj i t hsi, eval_proj_iff] at hd + simp [hd] + refine ⟨fun i => (src i).elim (w i) v', ?_, ?_⟩ + · rw [hwv] at hw + exact (ihc z _ _ (houter w)).mp hw + · intro i + cases hsi : src i with + | none => + simp only [hsi, Option.elim] + exact (ihd i (w i) v v' (hagree i hsi)).mp (hi i) + | some t => + rw [hproj i t hsi, eval_proj_iff] + simp [hsi] + · rintro ⟨w, hw, hi⟩ + have hwv : w = fun i => (src i).elim (w i) v' := + by + funext i + cases hsi : src i with + | none => simp + | some t => + have hd := hi i + rw [hproj i t hsi, eval_proj_iff] at hd + simp [hd] + refine ⟨fun i => (src i).elim (w i) v, ?_, ?_⟩ + · rw [hwv] at hw + exact (ihc z _ _ (houter w)).mpr hw + · intro i + cases hsi : src i with + | none => + simp only [hsi, Option.elim] + exact (ihd i (w i) v v' (hagree i hsi)).mpr (hi i) + | some t => + rw [hproj i t hsi, eval_proj_iff] + simp [hsi] + | rfind body ih => + intro z v v' h + rw [InputsAgree] at h + rw [eval_rfind_iff', eval_rfind_iff'] + refine and_congr (ih 0 (z :> v) (z :> v') (h z)) ?_ + refine forall_congr' fun t => imp_congr Iff.rfl ?_ + exact exists_congr fun x => and_congr Iff.rfl (ih x (t :> v) (t :> v') (h t)) + +end Semantic + +section Closure + +variable {M : Type*} + +/-! +### Closure of the dependency relation under the derived constructors + +Each lemma below inspects a code as a syntax tree only. No arithmetic meaning +is attached to any of them, and `codeBeta` in particular is delta-reduced but +never evaluated. -/ + +/-- Every code agrees with itself. -/ +private theorem inputsAgree_refl : ∀ {k : ℕ} (c : Code k) (v : Fin k → M), InputsAgree c v v := + by + intro k c + induction c with + | zero m => intro v; rw [InputsAgree]; trivial + | one m => intro v; rw [InputsAgree]; trivial + | add i j => intro v; rw [InputsAgree]; exact ⟨rfl, rfl⟩ + | mul i j => intro v; rw [InputsAgree]; exact ⟨rfl, rfl⟩ + | proj i => intro v; rw [InputsAgree] + | equal i j => intro v; rw [InputsAgree]; exact ⟨rfl, rfl⟩ + | lt i j => intro v; rw [InputsAgree]; exact ⟨rfl, rfl⟩ + | comp c d ihc ihd => + intro v + rw [InputsAgree] + exact ⟨fun _ => none, by simp, fun i _ => ihd i v, fun u => by simpa using ihc u⟩ + | rfind body ih => intro v; rw [InputsAgree]; exact fun t => ih (t :> v) + +/-- A composition all of whose arguments agree. -/ +private theorem inputsAgree_comp_of_all {m n : ℕ} (c : Code n) (d : Fin n → Code m) + (v v' : Fin m → M) (hd : ∀ i, InputsAgree (d i) v v') : InputsAgree (Code.comp c d) v v' := + by + rw [InputsAgree] + exact ⟨fun _ => none, by simp, fun i _ => hd i, fun u => by simpa using inputsAgree_refl c u⟩ + +private theorem inputsAgree_comp₂ {k : ℕ} (c : Code 2) (d₀ d₁ : Code k) (v v' : Fin k → M) + (h₀ : InputsAgree d₀ v v') (h₁ : InputsAgree d₁ v v') : + InputsAgree (Code.comp c ![d₀, d₁]) v v' := + by + refine inputsAgree_comp_of_all c _ v v' ?_ + intro i + refine Fin.cases ?_ (fun j => ?_) i + · simpa using h₀ + · refine Fin.cases ?_ (fun j' => j'.elim0) j + simpa using h₁ + +private theorem inputsAgree_zero {k : ℕ} (v v' : Fin k → M) : InputsAgree (Code.zero k) v v' := + by rw [InputsAgree]; trivial + +private theorem inputsAgree_one {k : ℕ} (v v' : Fin k → M) : InputsAgree (Code.one k) v v' := by + rw [InputsAgree]; trivial + +private theorem inputsAgree_proj {k : ℕ} (i : Fin k) (v v' : Fin k → M) (h : v i = v' i) : + InputsAgree (Code.proj i) v v' := by rw [InputsAgree]; exact h + +private theorem inputsAgree_codeHead {k : ℕ} (t : M) (v v' : Fin k → M) : + InputsAgree (codeHead (n := k)) (t :> v) (t :> v') := + inputsAgree_proj 0 _ _ rfl + +private theorem inputsAgree_codeAdd {k : ℕ} (d₀ d₁ : Code k) (v v' : Fin k → M) + (h₀ : InputsAgree d₀ v v') (h₁ : InputsAgree d₁ v v') : InputsAgree (codeAdd d₀ d₁) v v' := + inputsAgree_comp₂ _ _ _ v v' h₀ h₁ + +private theorem inputsAgree_codeMul {k : ℕ} (d₀ d₁ : Code k) (v v' : Fin k → M) + (h₀ : InputsAgree d₀ v v') (h₁ : InputsAgree d₁ v v') : InputsAgree (codeMul d₀ d₁) v v' := + inputsAgree_comp₂ _ _ _ v v' h₀ h₁ + +private theorem inputsAgree_codeEq {k : ℕ} (d₀ d₁ : Code k) (v v' : Fin k → M) + (h₀ : InputsAgree d₀ v v') (h₁ : InputsAgree d₁ v v') : InputsAgree (codeEq d₀ d₁) v v' := + inputsAgree_comp₂ _ _ _ v v' h₀ h₁ + +private theorem inputsAgree_codeLt {k : ℕ} (d₀ d₁ : Code k) (v v' : Fin k → M) + (h₀ : InputsAgree d₀ v v') (h₁ : InputsAgree d₁ v v') : InputsAgree (codeLt d₀ d₁) v v' := + inputsAgree_comp₂ _ _ _ v v' h₀ h₁ + +private theorem inputsAgree_codeSucc {k : ℕ} (d : Code k) (v v' : Fin k → M) + (h : InputsAgree d v v') : InputsAgree (codeSucc d) v v' := + inputsAgree_comp₂ _ _ _ v v' h (inputsAgree_one v v') + +private theorem inputsAgree_codeInv {k : ℕ} (d : Code k) (v v' : Fin k → M) + (h : InputsAgree d v v') : InputsAgree (codeInv d) v v' := + inputsAgree_comp₂ _ _ _ v v' h (inputsAgree_zero v v') + +private theorem inputsAgree_codePos {k : ℕ} (d : Code k) (v v' : Fin k → M) + (h : InputsAgree d v v') : InputsAgree (codePos d) v v' := + inputsAgree_comp₂ _ _ _ v v' (inputsAgree_zero v v') h + +private theorem inputsAgree_codeAnd {k : ℕ} (d₀ d₁ : Code k) (v v' : Fin k → M) + (h₀ : InputsAgree d₀ v v') (h₁ : InputsAgree d₁ v v') : InputsAgree (codeAnd d₀ d₁) v v' := + inputsAgree_comp₂ _ _ _ v v' (inputsAgree_zero v v') (inputsAgree_comp₂ _ _ _ v v' h₀ h₁) + +private theorem inputsAgree_codeOr {k : ℕ} (d₀ d₁ : Code k) (v v' : Fin k → M) + (h₀ : InputsAgree d₀ v v') (h₁ : InputsAgree d₁ v v') : InputsAgree (codeOr d₀ d₁) v v' := + inputsAgree_comp₂ _ _ _ v v' (inputsAgree_zero v v') (inputsAgree_comp₂ _ _ _ v v' h₀ h₁) + +private theorem inputsAgree_codeConst {k : ℕ} (m : ℕ) (v v' : Fin k → M) : + InputsAgree (codeConst (n := k) m) v v' := by + induction m with + | zero => exact inputsAgree_zero v v' + | succ p ih => exact inputsAgree_codeSucc _ v v' ih + +/-- A lift is a renaming, so it transports without demanding agreement at the +head. -/ +private theorem inputsAgree_codeLift {k : ℕ} (d : Code k) (t : M) (v v' : Fin k → M) + (h : InputsAgree d v v') : InputsAgree (codeLift d) (t :> v) (t :> v') := + by + rw [codeLift, InputsAgree] + refine ⟨fun i => some i.succ, fun i s hs => ?_, fun i hs => by simp at hs, fun u => ?_⟩ + · cases hs; rfl + · have e : (fun i => Option.elim (some i.succ) (u i) (t :> v)) = v := by funext i; simp + have e' : (fun i => Option.elim (some i.succ) (u i) (t :> v')) = v' := by funext i; simp + rw [e, e'] + exact h + +private theorem inputsAgree_codeRfindPos {k : ℕ} (d : Code (k + 1)) (v v' : Fin k → M) + (h : ∀ t : M, InputsAgree d (t :> v) (t :> v')) : InputsAgree (codeRfindPos d) v v' := + by + rw [codeRfindPos, InputsAgree] + intro t + exact inputsAgree_codeInv _ _ _ (inputsAgree_codePos _ _ _ (h t)) + +/-- Substitution keeps one shared value and renames the rest. -/ +private theorem inputsAgree_codeBind {k : ℕ} (dg : Code k) (dc : Code (k + 1)) + (v v' : Fin k → M) (hg : InputsAgree dg v v') + (hc : ∀ x : M, InputsAgree dc (x :> v) (x :> v')) : InputsAgree (codeBind dg dc) v v' := + by + rw [codeBind, InputsAgree] + refine ⟨Fin.cases none (fun i => some i), ?_, ?_, ?_⟩ + · intro i + refine Fin.cases ?_ (fun j => ?_) i + · intro s hs; simp at hs + · intro s hs + simp only [Fin.cases_succ] at hs ⊢ + injection hs with hs' + subst hs' + rfl + · intro i + refine Fin.cases ?_ (fun j => ?_) i + · intro _; simpa using hg + · intro hs + simp only [Fin.cases_succ] at hs + cases hs + · intro u + have e : + ∀ w : Fin k → M, + (fun i => Option.elim (Fin.cases none (fun j => some j) i) (u i) w) = (u 0 :> w) := + by + intro w + funext i + refine Fin.cases ?_ (fun j => ?_) i <;> simp + rw [e v, e v'] + exact hc (u 0) + +private theorem inputsAgree_codeSub {k : ℕ} (d₀ d₁ : Code k) (v v' : Fin k → M) + (h₀ : InputsAgree d₀ v v') (h₁ : InputsAgree d₁ v v') : InputsAgree (codeSub d₀ d₁) v v' := + by + rw [codeSub] + refine inputsAgree_codeRfindPos _ v v' (fun t => ?_) + exact + inputsAgree_codeOr _ _ _ _ + (inputsAgree_codeEq _ _ _ _ + (inputsAgree_codeAdd _ _ _ _ (inputsAgree_codeHead t v v') + (inputsAgree_codeLift _ t v v' h₁)) + (inputsAgree_codeLift _ t v v' h₀)) + (inputsAgree_codeAnd _ _ _ _ + (inputsAgree_codeLt _ _ _ _ (inputsAgree_codeLift _ t v v' h₀) + (inputsAgree_codeLift _ t v v' h₁)) + (inputsAgree_codeEq _ _ _ _ (inputsAgree_codeHead t v v') (inputsAgree_zero _ _))) + +private theorem inputsAgree_codeSqrt {k : ℕ} (d : Code k) (v v' : Fin k → M) + (h : InputsAgree d v v') : InputsAgree (codeSqrt d) v v' := + by + rw [codeSqrt] + refine inputsAgree_codeRfindPos _ v v' (fun t => ?_) + exact + inputsAgree_codeAnd _ _ _ _ + (inputsAgree_codeOr _ _ _ _ + (inputsAgree_codeLt _ _ _ _ + (inputsAgree_codeMul _ _ _ _ (inputsAgree_codeHead t v v') + (inputsAgree_codeHead t v v')) + (inputsAgree_codeLift _ t v v' h)) + (inputsAgree_codeEq _ _ _ _ + (inputsAgree_codeMul _ _ _ _ (inputsAgree_codeHead t v v') + (inputsAgree_codeHead t v v')) + (inputsAgree_codeLift _ t v v' h))) + (inputsAgree_codeLt _ _ _ _ (inputsAgree_codeLift _ t v v' h) + (inputsAgree_codeMul _ _ _ _ (inputsAgree_codeSucc _ _ _ (inputsAgree_codeHead t v v')) + (inputsAgree_codeSucc _ _ _ (inputsAgree_codeHead t v v')))) + +private theorem inputsAgree_codeIfPos {k : ℕ} (df dg dh : Code k) (v v' : Fin k → M) + (hf : InputsAgree df v v') (hg : InputsAgree dg v v') (hh : InputsAgree dh v v') : + InputsAgree (codeIfPos df dg dh) v v' := + by + rw [codeIfPos] + exact + inputsAgree_codeAdd _ _ _ _ (inputsAgree_codeMul _ _ _ _ (inputsAgree_codePos _ _ _ hf) hg) + (inputsAgree_codeMul _ _ _ _ (inputsAgree_codeInv _ _ _ hf) hh) + +private theorem inputsAgree_codeLe {k : ℕ} (d₀ d₁ : Code k) (v v' : Fin k → M) + (h₀ : InputsAgree d₀ v v') (h₁ : InputsAgree d₁ v v') : InputsAgree (codeLe d₀ d₁) v v' := + by + rw [codeLe] + exact + inputsAgree_codeOr _ _ _ _ (inputsAgree_codeLt _ _ _ _ h₀ h₁) + (inputsAgree_codeEq _ _ _ _ h₀ h₁) + +private theorem inputsAgree_codeUnpair₁ {k : ℕ} (d : Code k) (v v' : Fin k → M) + (h : InputsAgree d v v') : InputsAgree (codeUnpair₁ d) v v' := + by + rw [codeUnpair₁] + have hsq := inputsAgree_codeSqrt d v v' h + have hdiff := inputsAgree_codeSub _ _ v v' h (inputsAgree_codeMul _ _ _ _ hsq hsq) + exact inputsAgree_codeIfPos _ _ _ v v' (inputsAgree_codeLt _ _ _ _ hdiff hsq) hdiff hsq + +private theorem inputsAgree_codeUnpair₂ {k : ℕ} (d : Code k) (v v' : Fin k → M) + (h : InputsAgree d v v') : InputsAgree (codeUnpair₂ d) v v' := + by + rw [codeUnpair₂] + have hsq := inputsAgree_codeSqrt d v v' h + have hdiff := inputsAgree_codeSub _ _ v v' h (inputsAgree_codeMul _ _ _ _ hsq hsq) + exact + inputsAgree_codeIfPos _ _ _ v v' (inputsAgree_codeLt _ _ _ _ hdiff hsq) hsq + (inputsAgree_codeSub _ _ v v' hdiff hsq) + +private theorem inputsAgree_codeDvd {k : ℕ} (d₀ d₁ : Code k) (v v' : Fin k → M) + (h₀ : InputsAgree d₀ v v') (h₁ : InputsAgree d₁ v v') : InputsAgree (codeDvd d₀ d₁) v v' := + by + rw [codeDvd] + refine inputsAgree_codeBind _ _ v v' ?_ (fun x => ?_) + · refine inputsAgree_codeRfindPos _ v v' (fun t => ?_) + exact + inputsAgree_codeOr _ _ _ _ + (inputsAgree_codeEq _ _ _ _ + (inputsAgree_codeMul _ _ _ _ (inputsAgree_codeHead t v v') + (inputsAgree_codeLift _ t v v' h₀)) + (inputsAgree_codeLift _ t v v' h₁)) + (inputsAgree_codeLt _ _ _ _ (inputsAgree_codeLift _ t v v' h₁) + (inputsAgree_codeHead t v v')) + · exact + inputsAgree_codeLe _ _ _ _ (inputsAgree_codeHead x v v') + (inputsAgree_codeLift _ x v v' h₁) + +private theorem inputsAgree_codeRem {k : ℕ} (d₀ d₁ : Code k) (v v' : Fin k → M) + (h₀ : InputsAgree d₀ v v') (h₁ : InputsAgree d₁ v v') : InputsAgree (codeRem d₀ d₁) v v' := + by + rw [codeRem] + refine inputsAgree_codeRfindPos _ v v' (fun t => ?_) + exact + inputsAgree_codeDvd _ _ _ _ (inputsAgree_codeLift _ t v v' h₁) + (inputsAgree_codeSub _ _ _ _ (inputsAgree_codeLift _ t v v' h₀) + (inputsAgree_codeHead t v v')) + +/-- `codeBeta` is delta-reduced here as a syntax tree; nothing evaluates it. -/ +private theorem inputsAgree_codeBeta {k : ℕ} (dn di : Code k) (v v' : Fin k → M) + (hn : InputsAgree dn v v') (hi : InputsAgree di v v') : InputsAgree (codeBeta dn di) v v' := + by + rw [codeBeta] + exact + inputsAgree_codeRem _ _ v v' (inputsAgree_codeUnpair₁ _ _ _ hn) + (inputsAgree_codeSucc _ _ _ + (inputsAgree_codeMul _ _ _ _ (inputsAgree_codeSucc _ _ _ hi) + (inputsAgree_codeUnpair₂ _ _ _ hn))) + +/-! +### The recursion argument is unused by the step relation -/ + +/-- Every argument `precStepArgs` supplies to `dg` ignores input slot `2`: the +first and the outer ones are projections away from it, and the second is a +`codeBeta` whose own two arguments are `Code.proj 1` and `Code.proj 0`. The +outer `dg` is never inspected; it is applied to two assembled vectors that are +equal. -/ +private theorem inputsAgree_codePrecStep_bound {n : ℕ} (dg : Code (n + 2)) (j hc c c' : M) + (v : Fin n → M) : InputsAgree (codePrecStep dg) (j :> hc :> c :> v) (j :> hc :> c' :> v) := + by + have hstep : + codePrecStep dg = + codeEq (codeBeta (Code.proj 1) (codeSucc (Code.proj 0))) + (dg.comp + (Fin.cases (Code.proj 0) + (Fin.cases (codeBeta (Code.proj 1) (Code.proj 0)) + (fun i => Code.proj i.succ.succ.succ)))) := + rfl + rw [hstep] + refine inputsAgree_codeEq _ _ _ _ ?_ ?_ + · exact + inputsAgree_codeBeta _ _ _ _ (inputsAgree_proj 1 _ _ rfl) + (inputsAgree_codeSucc _ _ _ (inputsAgree_proj 0 _ _ rfl)) + · rw [InputsAgree] + refine ⟨Fin.cases (some 0) (Fin.cases none (fun i => some i.succ.succ.succ)), ?_, ?_, ?_⟩ + · intro i + refine Fin.cases ?_ (fun k => ?_) i + · intro s hs + simp only [Fin.cases_zero] at hs + injection hs with hs' + subst hs' + rfl + · refine Fin.cases ?_ (fun l => ?_) k + · intro s hs + simp only [Fin.cases_succ, Fin.cases_zero] at hs + cases hs + · intro s hs + simp only [Fin.cases_succ] at hs ⊢ + injection hs with hs' + subst hs' + rfl + · intro i + refine Fin.cases ?_ (fun k => ?_) i + · intro hs + simp only [Fin.cases_zero] at hs + cases hs + · refine Fin.cases ?_ (fun l => ?_) k + · intro _ + simp only [Fin.cases_succ, Fin.cases_zero] + exact + inputsAgree_codeBeta _ _ _ _ (inputsAgree_proj 1 _ _ rfl) + (inputsAgree_proj 0 _ _ rfl) + · intro hs + simp only [Fin.cases_succ] at hs + cases hs + · intro u + have e : + (fun i => + Option.elim (Fin.cases (some 0) (Fin.cases none (fun i => some i.succ.succ.succ)) i) + (u i) (j :> hc :> c :> v)) = + (fun i => + Option.elim (Fin.cases (some 0) (Fin.cases none (fun i => some i.succ.succ.succ)) i) + (u i) (j :> hc :> c' :> v)) := + by + funext i + refine Fin.cases ?_ (fun k => ?_) i + · rfl + · refine Fin.cases ?_ (fun l => ?_) k + · rfl + · rfl + rw [e] + exact inputsAgree_refl dg _ + +/-! +### Bound irrelevance for the base conjunct of the recursion predicate -/ + +/-- The base equation of `codePrecPredicate` reads the history code and the +outer arguments, never the recursion argument. -/ +private theorem inputsAgree_precBase_bound {k : ℕ} (df : Code k) (hc c c' : M) (v : Fin k → M) : + InputsAgree + (codeEq (codeBeta (Code.proj 0) (codeConst 0)) (df.comp (fun j => Code.proj j.succ.succ))) + (hc :> c :> v) (hc :> c' :> v) := + by + refine inputsAgree_codeEq _ _ _ _ ?_ ?_ + · exact + inputsAgree_codeBeta _ _ _ _ (inputsAgree_proj 0 _ _ rfl) (inputsAgree_codeConst 0 _ _) + · rw [InputsAgree] + refine ⟨fun j => some j.succ.succ, ?_, ?_, ?_⟩ + · intro i s hs + cases hs + rfl + · intro i hs + cases hs + · intro u + have e : + ∀ w : Fin k → M, (fun j => Option.elim (some j.succ.succ) (u j) (hc :> c :> w)) = w := + by intro w; funext j; simp + have e' : (fun j => Option.elim (some j.succ.succ) (u j) (hc :> c' :> v)) = v := by + funext j; simp + rw [e v, e'] + exact inputsAgree_refl df v + +end Closure + +section Endpoint + +variable {M : Type*} [ORingStructure M] + +/-- The step relation of `codePrec` does not read the recursion argument. + +The arguments of `codePrecStep dg` are the history index, the history code, the +recursion argument, and the outer arguments. Argument `2`, the recursion +argument, is supplied to nothing: `precStepArgs` hands `dg` only +`Code.proj 0`, `codeBeta (Code.proj 1) (Code.proj 0)`, and the outer +projections. A caller may therefore change it freely. + +No arithmetic theory is assumed, and no code is evaluated in the model. -/ +theorem eval_codePrecStep_bound_irrel_iff {n : ℕ} (dg : Code (n + 2)) (p j hc c c' : M) + (v : Fin n → M) : + Semiformula.Evalb (p :> j :> hc :> c :> v) (code (codePrecStep dg)) ↔ + Semiformula.Evalb (p :> j :> hc :> c' :> v) (code (codePrecStep dg)) := + eval_iff_of_inputsAgree _ p _ _ (inputsAgree_codePrecStep_bound dg j hc c c' v) + +end Endpoint + +section Restriction + +variable {M : Type*} [ORingStructure M] + +open scoped FFL.FirstOrder.Arithmetic + +open HierarchySymbol + +/-- The base equation of `codePrecPredicate`, at two recursion arguments. -/ +private theorem eval_precBase_bound_irrel_iff {k : ℕ} (df : Code k) (p hc c c' : M) + (v : Fin k → M) : + Semiformula.Evalb (p :> hc :> c :> v) + (code + (codeEq (codeBeta (Code.proj 0) (codeConst 0)) + (df.comp (fun j => Code.proj j.succ.succ)))) ↔ + Semiformula.Evalb (p :> hc :> c' :> v) + (code + (codeEq (codeBeta (Code.proj 0) (codeConst 0)) + (df.comp (fun j => Code.proj j.succ.succ)))) := + eval_iff_of_inputsAgree _ p _ _ (inputsAgree_precBase_bound df hc c c' v) + +/-- `codePrecStep` written out, with the argument codes of the step displayed +explicitly rather than through the private abbreviation of `Recursion`. -/ +private theorem codePrecStep_eq {n : ℕ} (dg : Code (n + 2)) : + codePrecStep dg = + codeEq (codeBeta (Code.proj 1) (codeSucc (Code.proj 0))) + (dg.comp + (Fin.cases (Code.proj 0) + (Fin.cases (codeBeta (Code.proj 1) (Code.proj 0)) + (fun j => Code.proj j.succ.succ.succ)))) := + rfl + +/-- `codePrecPredicate` written out, with the base conjunct in the explicit form +the bound-irrelevance lemma above uses. -/ +private theorem codePrecPredicate_eq {k : ℕ} (df : Code k) (dg : Code (k + 2)) : + codePrecPredicate df dg = + codeAnd + (codeEq (codeBeta (Code.proj 0) (codeConst 0)) + (df.comp (fun j => Code.proj j.succ.succ))) + (codeBall (codePrecStep dg) (1 : Fin (k + 2))) := + rfl + +private theorem eq_zero_of_not_pos_add [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {x y : M} (h : ¬(0 : M) < x + y) : + x = 0 := by + have hsum : x + y = 0 := le_antisymm (not_lt.mp h) (by simp) + have hx : x ≤ 0 := hsum ▸ le_self_add + exact le_antisymm hx (by simp) + +private theorem pos_of_pos_mul_left [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {x y : M} (h : 0 < x * y) : 0 < x := + by + rcases eq_or_lt_of_le (show (0 : M) ≤ x from by simp) with h0 | hpos + · rw [← h0, zero_mul] at h; exact absurd h (_root_.lt_irrefl 0) + · exact hpos + +private theorem pos_of_pos_mul_right [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {x y : M} (h : 0 < x * y) : 0 < y := + by + rcases eq_or_lt_of_le (show (0 : M) ≤ y from by simp) with h0 | hpos + · rw [← h0, mul_zero] at h; exact absurd h (_root_.lt_irrefl 0) + · exact hpos + +/-- Elimination for the non-strict comparison. -/ +private theorem le_val_cases [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {m : ℕ} (A B : Code m) (x y zz : M) + (vv : Fin m → M) (hA : Semiformula.Evalb (x :> vv) (code A)) + (hB : Semiformula.Evalb (y :> vv) (code B)) + (hz : Semiformula.Evalb (zz :> vv) (code (codeLe A B))) : + (x ≤ y ∧ zz = 1) ∨ (¬x ≤ y ∧ zz = 0) := + by + rw [codeLe, eval_codeOr_iff] at hz + obtain ⟨p, q, hp, hq, hcase⟩ := hz + rw [eval_codeLt_iff] at hp + obtain ⟨x1, y1, hx1, hy1, hlt⟩ := hp + rw [eval_codeEq_iff] at hq + obtain ⟨x2, y2, hx2, hy2, heq⟩ := hq + rw [eval_unique hx1 hA, eval_unique hy1 hB] at hlt + rw [eval_unique hx2 hA, eval_unique hy2 hB] at heq + by_cases hxy : x ≤ y + · refine Or.inl ⟨hxy, ?_⟩ + have hpos : 0 < p + q := by + rcases lt_or_eq_of_le hxy with hx | hx + · rcases hlt with ⟨-, rfl⟩ | ⟨hn, -⟩ + · rcases heq with ⟨-, rfl⟩ | ⟨-, rfl⟩ <;> simp + · exact absurd hx hn + · rcases heq with ⟨-, rfl⟩ | ⟨hn, -⟩ + · rcases hlt with ⟨-, rfl⟩ | ⟨-, rfl⟩ <;> simp + · exact absurd hx hn + rcases hcase with ⟨-, hz1⟩ | ⟨hn, -⟩ + · exact hz1 + · exact absurd hpos hn + · refine Or.inr ⟨hxy, ?_⟩ + have hp0 : p = 0 := by + rcases hlt with ⟨hx, -⟩ | ⟨-, hp0⟩ + · exact absurd (le_of_lt hx) hxy + · exact hp0 + have hq0 : q = 0 := by + rcases heq with ⟨hx, -⟩ | ⟨-, hq0⟩ + · exact absurd (le_of_eq hx) hxy + · exact hq0 + rcases hcase with ⟨hpos, -⟩ | ⟨-, hz0⟩ + · rw [hp0, hq0] at hpos; exact absurd hpos (by simp) + · exact hz0 + +/-- A zero disjunction hands back the body. -/ +private theorem body_of_or_zero [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : ℕ} (dg : Code (k + 2)) (t hc arg : M) + (v : Fin k → M) + (h : + Semiformula.Evalb ((0 : M) :> t :> hc :> arg :> v) + (code + (codeOr (codeInv (codePrecStep dg)) + (codeLe (codeLift (Code.proj (1 : Fin (k + 2)))) (codeHead (n := k + 2)))))) : + ∃ e : M, e ≠ 0 ∧ Semiformula.Evalb (e :> t :> hc :> arg :> v) (code (codePrecStep dg)) := + by + rw [eval_codeOr_iff] at h + obtain ⟨p', q', hp', hq', hc'⟩ := h + have hp'0 : p' = 0 := by + rcases hc' with ⟨-, h01⟩ | ⟨hnp, -⟩ + · exact absurd h01.symm _root_.one_ne_zero + · exact eq_zero_of_not_pos_add hnp + rw [hp'0, eval_codeInv_iff] at hp' + obtain ⟨e, he, hecase⟩ := hp' + rcases hecase with ⟨-, h01⟩ | ⟨hne, -⟩ + · exact absurd h01.symm _root_.one_ne_zero + · exact ⟨e, hne, he⟩ + +/-- A successful bounded search hands back the body at every earlier index. -/ +private theorem ball_body_of_pos [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : ℕ} (dg : Code (k + 2)) (y hc arg : M) + (v : Fin k → M) (hy : 0 < y) + (h : + Semiformula.Evalb (y :> hc :> arg :> v) + (code (codeBall (codePrecStep dg) (1 : Fin (k + 2))))) : + ∀ t : M, + t < arg → + ∃ e : M, + e ≠ 0 ∧ Semiformula.Evalb (e :> t :> hc :> arg :> v) (code (codePrecStep dg)) := + by + rw [codeBall, eval_codeBind_iff] at h + obtain ⟨j, hsearch, heq⟩ := h + rw [eval_codeEq_iff] at heq + obtain ⟨p, q, hp, hq, hcase⟩ := heq + rw [eval_codeHead_iff] at hp + rw [eval_codeLift_iff, eval_proj_iff] at hq + have hja : j = arg := by + rcases hcase with ⟨hpq, -⟩ | ⟨-, hy0⟩ + · exact hp.symm.trans (hpq.trans hq) + · exact absurd hy0 (ne_of_gt hy) + rw [eval_codeRfindPos_iff] at hsearch + obtain ⟨-, hmin⟩ := hsearch + intro t ht + exact body_of_or_zero dg t hc arg v (hmin t (by rw [hja]; exact ht)) + +/-- Conversely, a body holding at every index up to the bound makes the bounded +search succeed, with the bound itself as the witness. -/ +private theorem ball_pos_of_body [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : ℕ} (dg : Code (k + 2)) (hc arg : M) + (v : Fin k → M) + (hbody : + ∀ t : M, + t ≤ arg → + ∃ e : M, + e ≠ 0 ∧ Semiformula.Evalb (e :> t :> hc :> arg :> v) (code (codePrecStep dg))) : + Semiformula.Evalb ((1 : M) :> hc :> arg :> v) + (code (codeBall (codePrecStep dg) (1 : Fin (k + 2)))) := + by + have hlift : + ∀ t : M, + Semiformula.Evalb (arg :> t :> hc :> arg :> v) + (code (codeLift (Code.proj (1 : Fin (k + 2))))) := + fun t => (eval_codeLift_iff _ _ _ _).mpr ((eval_proj_iff _ _ _).mpr rfl) + have hhead : + ∀ t : M, Semiformula.Evalb (t :> t :> hc :> arg :> v) (code (codeHead (n := k + 2))) := + fun t => (eval_codeHead_iff _ _).mpr rfl + rw [codeBall, eval_codeBind_iff] + refine ⟨arg, ?_, ?_⟩ + · rw [eval_codeRfindPos_iff] + constructor + · obtain ⟨e, hne, he⟩ := hbody arg le_rfl + refine ⟨1, by simp, (eval_codeOr_iff _ _ _ _).mpr ⟨0, 1, ?_, ?_, Or.inl ⟨by simp, rfl⟩⟩⟩ + · exact (eval_codeInv_iff _ _ _).mpr ⟨e, he, Or.inr ⟨hne, rfl⟩⟩ + · exact eval_codeLe_of _ _ arg arg 1 _ (hlift arg) (hhead arg) (Or.inl ⟨le_rfl, rfl⟩) + · intro t ht + obtain ⟨e, hne, he⟩ := hbody t (le_of_lt ht) + refine (eval_codeOr_iff _ _ _ _).mpr ⟨0, 0, ?_, ?_, Or.inr ⟨by simp, rfl⟩⟩ + · exact (eval_codeInv_iff _ _ _).mpr ⟨e, he, Or.inr ⟨hne, rfl⟩⟩ + · exact eval_codeLe_of _ _ arg t 0 _ (hlift t) (hhead t) (Or.inr ⟨not_le.mpr ht, rfl⟩) + · exact (eval_codeEq_iff _ _ _ _).mpr ⟨arg, arg, hhead arg, hlift arg, Or.inl ⟨rfl, rfl⟩⟩ + +/-- Once the bounded search has a witness the bounded quantifier has a value. -/ +private theorem ball_val_of_rfind [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : ℕ} (dg : Code (k + 2)) (hc arg j : M) + (v : Fin k → M) + (hj : + Semiformula.Evalb (j :> hc :> arg :> v) + (code + (codeRfindPos + (codeOr (codeInv (codePrecStep dg)) + (codeLe (codeLift (Code.proj (1 : Fin (k + 2)))) (codeHead (n := k + 2))))))) : + ∃ y : M, + Semiformula.Evalb (y :> hc :> arg :> v) + (code (codeBall (codePrecStep dg) (1 : Fin (k + 2)))) := + by + have hhead : Semiformula.Evalb (j :> j :> hc :> arg :> v) (code (codeHead (n := k + 2))) := + (eval_codeHead_iff _ _).mpr rfl + have hlift : + Semiformula.Evalb (arg :> j :> hc :> arg :> v) + (code (codeLift (Code.proj (1 : Fin (k + 2))))) := + (eval_codeLift_iff _ _ _ _).mpr ((eval_proj_iff _ _ _).mpr rfl) + by_cases hja : j = arg + · exact + ⟨1, by + rw [codeBall, eval_codeBind_iff] + exact ⟨j, hj, (eval_codeEq_iff _ _ _ _).mpr ⟨j, arg, hhead, hlift, Or.inl ⟨hja, rfl⟩⟩⟩⟩ + · exact + ⟨0, by + rw [codeBall, eval_codeBind_iff] + exact ⟨j, hj, (eval_codeEq_iff _ _ _ _).mpr ⟨j, arg, hhead, hlift, Or.inr ⟨hja, rfl⟩⟩⟩⟩ + +/-- The body of the bounded search inside `codeBall (codePrecStep dg) 1`, at +value zero: the step holds and the index is below the recursion argument. -/ +private theorem eval_precSearch_zero_iff [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : ℕ} (dg : Code (k + 2)) + (t hc arg : M) (v : Fin k → M) : + Semiformula.Evalb ((0 : M) :> t :> hc :> arg :> v) + (code + (codeOr (codeInv (codePrecStep dg)) + (codeLe (codeLift (Code.proj (1 : Fin (k + 2)))) (codeHead (n := k + 2))))) ↔ + (∃ e : M, e ≠ 0 ∧ Semiformula.Evalb (e :> t :> hc :> arg :> v) (code (codePrecStep dg))) ∧ + t < arg := + by + have hlift : + Semiformula.Evalb (arg :> t :> hc :> arg :> v) + (code (codeLift (Code.proj (1 : Fin (k + 2))))) := + (eval_codeLift_iff _ _ _ _).mpr ((eval_proj_iff _ _ _).mpr rfl) + have hhead : Semiformula.Evalb (t :> t :> hc :> arg :> v) (code (codeHead (n := k + 2))) := + (eval_codeHead_iff _ _).mpr rfl + constructor + · intro h + rw [eval_codeOr_iff] at h + obtain ⟨p, q, hp, hq, hcase⟩ := h + have hp0 : p = 0 := by + rcases hcase with ⟨-, h01⟩ | ⟨hnp, -⟩ + · exact absurd h01.symm _root_.one_ne_zero + · exact eq_zero_of_not_pos_add hnp + have hq0 : q = 0 := by + rcases hcase with ⟨-, h01⟩ | ⟨hnp, -⟩ + · exact absurd h01.symm _root_.one_ne_zero + · exact eq_zero_of_not_pos_add (by rwa [add_comm] at hnp) + rw [hp0, eval_codeInv_iff] at hp + obtain ⟨e, he, hecase⟩ := hp + have hstep : + ∃ e : M, e ≠ 0 ∧ Semiformula.Evalb (e :> t :> hc :> arg :> v) (code (codePrecStep dg)) := + by + rcases hecase with ⟨-, h01⟩ | ⟨hne, -⟩ + · exact absurd h01.symm _root_.one_ne_zero + · exact ⟨e, hne, he⟩ + rw [hq0] at hq + rcases le_val_cases _ _ arg t 0 _ hlift hhead hq with ⟨-, h01⟩ | ⟨hn, -⟩ + · exact absurd h01 _root_.zero_ne_one + · exact ⟨hstep, not_le.mp hn⟩ + · rintro ⟨⟨e, hne, he⟩, hta⟩ + refine (eval_codeOr_iff _ _ _ _).mpr ⟨0, 0, ?_, ?_, Or.inr ⟨by simp, rfl⟩⟩ + · exact (eval_codeInv_iff _ _ _).mpr ⟨e, he, Or.inr ⟨hne, rfl⟩⟩ + · exact eval_codeLe_of _ _ arg t 0 _ hlift hhead (Or.inr ⟨not_le.mpr hta, rfl⟩) + +/-- The search body is positive as soon as the step fails, or as soon as the +index has reached the recursion argument and the step has a value. -/ +private theorem eval_precSearch_one [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : ℕ} (dg : Code (k + 2)) + (t hc arg e : M) (v : Fin k → M) + (he : Semiformula.Evalb (e :> t :> hc :> arg :> v) (code (codePrecStep dg))) + (hfail : e = 0 ∨ arg ≤ t) : + Semiformula.Evalb ((1 : M) :> t :> hc :> arg :> v) + (code + (codeOr (codeInv (codePrecStep dg)) + (codeLe (codeLift (Code.proj (1 : Fin (k + 2)))) (codeHead (n := k + 2))))) := + by + have hlift : + Semiformula.Evalb (arg :> t :> hc :> arg :> v) + (code (codeLift (Code.proj (1 : Fin (k + 2))))) := + (eval_codeLift_iff _ _ _ _).mpr ((eval_proj_iff _ _ _).mpr rfl) + have hhead : Semiformula.Evalb (t :> t :> hc :> arg :> v) (code (codeHead (n := k + 2))) := + (eval_codeHead_iff _ _).mpr rfl + by_cases hle : arg ≤ t + · refine + (eval_codeOr_iff _ _ _ _).mpr ⟨if e = 0 then 1 else 0, 1, ?_, ?_, Or.inl ⟨by simp, rfl⟩⟩ + · refine (eval_codeInv_iff _ _ _).mpr ⟨e, he, ?_⟩ + by_cases h0 : e = 0 + · exact Or.inl ⟨h0, by simp [h0]⟩ + · exact Or.inr ⟨h0, by simp [h0]⟩ + · exact eval_codeLe_of _ _ arg t 1 _ hlift hhead (Or.inl ⟨hle, rfl⟩) + · have h0 : e = 0 := hfail.resolve_right hle + refine (eval_codeOr_iff _ _ _ _).mpr ⟨1, 0, ?_, ?_, Or.inl ⟨by simp, rfl⟩⟩ + · exact (eval_codeInv_iff _ _ _).mpr ⟨e, he, Or.inl ⟨h0, rfl⟩⟩ + · exact eval_codeLe_of _ _ arg t 0 _ hlift hhead (Or.inr ⟨hle, rfl⟩) + +/-- The bounded search inside `codeBall (codePrecStep dg) 1` still terminates +when the recursion argument is lowered by one. -/ +private theorem rfind_at_lower_bound [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : ℕ} (dg : Code (k + 2)) (hc a j : M) + (v : Fin k → M) + (hj : + Semiformula.Evalb (j :> hc :> (a + 1) :> v) + (code + (codeRfindPos + (codeOr (codeInv (codePrecStep dg)) + (codeLe (codeLift (Code.proj (1 : Fin (k + 2)))) (codeHead (n := k + 2))))))) : + ∃ j' : M, + Semiformula.Evalb (j' :> hc :> a :> v) + (code + (codeRfindPos + (codeOr (codeInv (codePrecStep dg)) + (codeLe (codeLift (Code.proj (1 : Fin (k + 2)))) (codeHead (n := k + 2)))))) := by + rw [eval_codeRfindPos_iff] at hj + obtain ⟨⟨y, hy, hFy⟩, hmin⟩ := hj + have hbelow : + ∀ t : M, + t < j → + ∃ e : M, e ≠ 0 ∧ Semiformula.Evalb (e :> t :> hc :> a :> v) (code (codePrecStep dg)) := + by + intro t ht + obtain ⟨⟨e, hne, he⟩, -⟩ := (eval_precSearch_zero_iff dg t hc (a + 1) v).mp (hmin t ht) + exact ⟨e, hne, (eval_codePrecStep_bound_irrel_iff dg e t hc (a + 1) a v).mp he⟩ + by_cases hja : j ≤ a + · refine ⟨j, (eval_codeRfindPos_iff _ _ _).mpr ⟨⟨1, by simp, ?_⟩, ?_⟩⟩ + · -- at `j` the search body is positive, and the comparison disjunct is zero + rw [eval_codeOr_iff] at hFy + obtain ⟨p, q, hp, hq, hcase⟩ := hFy + have hlift : + Semiformula.Evalb ((a + 1) :> j :> hc :> (a + 1) :> v) + (code (codeLift (Code.proj (1 : Fin (k + 2))))) := + (eval_codeLift_iff _ _ _ _).mpr ((eval_proj_iff _ _ _).mpr rfl) + have hhead : + Semiformula.Evalb (j :> j :> hc :> (a + 1) :> v) (code (codeHead (n := k + 2))) := + (eval_codeHead_iff _ _).mpr rfl + have hq0 : q = 0 := + by + rcases le_val_cases _ _ (a + 1) j q _ hlift hhead hq with ⟨hle, -⟩ | ⟨-, h0⟩ + · exact absurd (le_trans hle hja) (by simp) + · exact h0 + have hppos : 0 < p := by + rcases hcase with ⟨hpq, -⟩ | ⟨-, h0⟩ + · rwa [hq0, add_zero] at hpq + · exact absurd h0 (ne_of_gt hy) + rw [eval_codeInv_iff] at hp + obtain ⟨e, he, hecase⟩ := hp + have he0 : e = 0 := by + rcases hecase with ⟨h0, -⟩ | ⟨-, hp0⟩ + · exact h0 + · exact absurd hppos (by rw [hp0]; simp) + exact + eval_precSearch_one dg j hc a e v + ((eval_codePrecStep_bound_irrel_iff dg e j hc (a + 1) a v).mp he) (Or.inl he0) + · intro t ht + exact (eval_precSearch_zero_iff dg t hc a v).mpr ⟨hbelow t ht, lt_of_lt_of_le ht hja⟩ + · have haj : a < j := not_le.mp hja + refine ⟨a, (eval_codeRfindPos_iff _ _ _).mpr ⟨⟨1, by simp, ?_⟩, ?_⟩⟩ + · obtain ⟨e, -, he⟩ := hbelow a haj + exact eval_precSearch_one dg a hc a e v he (Or.inr le_rfl) + · intro t ht + exact (eval_precSearch_zero_iff dg t hc a v).mpr ⟨hbelow t (lt_trans ht haj), ht⟩ + +/-- Lowering the recursion argument by one preserves a positive value of the +correctness predicate: the same history is still correct for the shorter run. -/ +private theorem precPredicate_pos_step_down [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : ℕ} (df : Code k) + (dg : Code (k + 2)) (hc a q : M) (v : Fin k → M) (hq : 0 < q) + (h : Semiformula.Evalb (q :> hc :> (a + 1) :> v) (code (codePrecPredicate df dg))) : + Semiformula.Evalb ((1 : M) :> hc :> a :> v) (code (codePrecPredicate df dg)) := + by + rw [codePrecPredicate_eq, eval_codeAnd_iff] at h + obtain ⟨p, r, hp, hr, hcase⟩ := h + have hpr : 0 < p * r := by + rcases hcase with ⟨hpos, -⟩ | ⟨-, h0⟩ + · exact hpos + · exact absurd h0 (ne_of_gt hq) + have hbody : + ∀ t : M, + t ≤ a → + ∃ e : M, e ≠ 0 ∧ Semiformula.Evalb (e :> t :> hc :> a :> v) (code (codePrecStep dg)) := + by + intro t ht + obtain ⟨e, hne, he⟩ := + ball_body_of_pos dg r hc (a + 1) v (pos_of_pos_mul_right hpr) hr t + (lt_of_le_of_lt ht (by simp)) + exact ⟨e, hne, (eval_codePrecStep_bound_irrel_iff dg e t hc (a + 1) a v).mp he⟩ + rw [codePrecPredicate_eq, eval_codeAnd_iff] + exact + ⟨p, 1, (eval_precBase_bound_irrel_iff df p hc (a + 1) a v).mp hp, + ball_pos_of_body dg hc a v hbody, + Or.inl ⟨by rw [mul_one]; exact pos_of_pos_mul_left hpr, rfl⟩⟩ + +/-- Lowering the recursion argument by one preserves having a value: the +correctness predicate is still decided at the shorter run. -/ +private theorem precPredicate_val_step_down [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : ℕ} (df : Code k) + (dg : Code (k + 2)) (hc a q : M) (v : Fin k → M) + (h : Semiformula.Evalb (q :> hc :> (a + 1) :> v) (code (codePrecPredicate df dg))) : + ∃ q' : M, Semiformula.Evalb (q' :> hc :> a :> v) (code (codePrecPredicate df dg)) := + by + rw [codePrecPredicate_eq, eval_codeAnd_iff] at h + obtain ⟨p, r, hp, hr, -⟩ := h + rw [codeBall, eval_codeBind_iff] at hr + obtain ⟨j, hjs, -⟩ := hr + obtain ⟨j', hj'⟩ := rfind_at_lower_bound dg hc a j v hjs + obtain ⟨r', hr'⟩ := ball_val_of_rfind dg hc a j' v hj' + have hbase := (eval_precBase_bound_irrel_iff df p hc (a + 1) a v).mp hp + by_cases hpr : 0 < p * r' + · exact + ⟨1, by + rw [codePrecPredicate_eq, eval_codeAnd_iff] + exact ⟨p, r', hbase, hr', Or.inl ⟨hpr, rfl⟩⟩⟩ + · exact + ⟨0, by + rw [codePrecPredicate_eq, eval_codeAnd_iff] + exact ⟨p, r', hbase, hr', Or.inr ⟨hpr, rfl⟩⟩⟩ + +/-! +### Sigma-one definability of one argument slot of a literal code graph -/ + +open HierarchySymbol in +/-- Varying one argument of the graph formula of a code, with the output and the +remaining arguments fixed as parameters, is a Sigma-one condition. -/ +private theorem definable_code_slot {m : ℕ} (A : Code m) (out : M) (target : Fin m) + (par : Fin m → M) : + Σ-[1].DefinablePred + (fun i : M => + Semiformula.Evalb (out :> fun j => if j = target then i else par j) (code A)) := + by + refine + ⟨HierarchySymbol.Semiformula.mkSigma + ((Rew.embSubsts + (&out :> fun j => if j = target then (#0 : Semiterm ℒₒᵣ M 1) else &(par j))) ▹ + (code A)) + (Hierarchy.rew _ (code_sigma_one A)), + ?_⟩ + intro w + simp only [HierarchySymbol.Semiformula.val_mkSigma, Semiformula.eval_embSubsts] + have hv : + (Semiterm.val w id ∘ + (&out :> fun j => if j = target then (#0 : Semiterm ℒₒᵣ M 1) else &(par j))) = + (out :> fun j => if j = target then w 0 else par j) := + by + funext j + refine Fin.cases ?_ ?_ j + · simp + · intro j; by_cases h : j = target <;> simp [h] + rw [hv] + +open HierarchySymbol in +/-- The special case in which the varying argument is the first one. -/ +private theorem definable_code_head_slot {m : ℕ} (A : Code (m + 1)) (out : M) + (par : Fin m → M) : + Σ-[1].DefinablePred (fun c : M => Semiformula.Evalb (out :> c :> par) (code A)) := + by + have h := definable_code_slot A out (0 : Fin (m + 1)) ((0 : M) :> par) + have he : + (fun c : M => Semiformula.Evalb (out :> c :> par) (code A)) = + (fun c : M => + Semiformula.Evalb + (out :> fun j => if j = (0 : Fin (m + 1)) then c else ((0 : M) :> par) j) (code A)) := + by + funext c + have hv : + ((c :> par) : Fin (m + 1) → M) = + (fun j => if j = (0 : Fin (m + 1)) then c else ((0 : M) :> par) j) := + by + funext j + refine Fin.cases ?_ ?_ j + · simp + · intro j; simp + rw [hv] + rw [he] + exact h + +/-! +### Reading one history entry through different argument codes -/ + +/-- Two `codeBeta` applications whose argument codes evaluate to the same +history code and the same index have the same value, at whatever arities and +assignments they are written. -/ +private theorem beta_align [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k l : ℕ} (N I : Code k) (N' I' : Code l) + (x n idx : M) (v : Fin k → M) (v' : Fin l → M) (hN : Semiformula.Evalb (n :> v) (code N)) + (hN' : Semiformula.Evalb (n :> v') (code N')) (hI : Semiformula.Evalb (idx :> v) (code I)) + (hI' : Semiformula.Evalb (idx :> v') (code I')) + (h : Semiformula.Evalb (x :> v) (code (codeBeta N I))) : + Semiformula.Evalb (x :> v') (code (codeBeta N' I')) := + by + refine (eval_codeBeta_congr_at N I N' I' x v v' ?_ ?_).mp h + · intro y + constructor + · intro hy; rw [eval_unique hy hN]; exact hN' + · intro hy; rw [eval_unique hy hN']; exact hN + · intro y + constructor + · intro hy; rw [eval_unique hy hI]; exact hI' + · intro hy; rw [eval_unique hy hI']; exact hI + +/-! +### Reading a correct history -/ + +/-- The initial entry of a correct history is the base value. -/ +private theorem prec_base_of_pos [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : ℕ} (df : Code k) (dg : Code (k + 2)) + (hc arg : M) (v : Fin k → M) + (h : Semiformula.Evalb ((1 : M) :> hc :> arg :> v) (code (codePrecPredicate df dg))) : + ∃ x : M, + Semiformula.Evalb (x :> hc :> arg :> v) (code (codeBeta (Code.proj 0) (codeConst 0))) ∧ + Semiformula.Evalb (x :> v) (code df) := + by + rw [codePrecPredicate_eq, eval_codeAnd_iff] at h + obtain ⟨p, r, hp, -, hcase⟩ := h + have hppos : 0 < p := by + rcases hcase with ⟨hpos, -⟩ | ⟨-, h0⟩ + · exact pos_of_pos_mul_left hpos + · exact absurd h0 _root_.one_ne_zero + rw [eval_codeEq_iff] at hp + obtain ⟨x, d, hx, hd, hdec⟩ := hp + have hxd : x = d := by + rcases hdec with ⟨heq, -⟩ | ⟨-, h0⟩ + · exact heq + · exact absurd hppos (by rw [h0]; simp) + rw [eval_comp_iff] at hd + obtain ⟨w, hw, hwi⟩ := hd + have hwv : w = v := by + funext j + exact eval_unique (hwi j) ((eval_proj_iff _ _ _).mpr rfl) + rw [hwv] at hw + exact ⟨x, hx, hxd ▸ hw⟩ + +/-- Below the recursion argument, consecutive entries of a correct history are +related by the step code. -/ +private theorem prec_step_of_pos [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : ℕ} (df : Code k) (dg : Code (k + 2)) + (hc arg t : M) (v : Fin k → M) (ht : t < arg) + (h : Semiformula.Evalb ((1 : M) :> hc :> arg :> v) (code (codePrecPredicate df dg))) : + ∃ u b : M, + Semiformula.Evalb (b :> t :> hc :> arg :> v) + (code (codeBeta (Code.proj 1) (Code.proj 0))) ∧ + Semiformula.Evalb (u :> t :> hc :> arg :> v) + (code (codeBeta (Code.proj 1) (codeSucc (Code.proj 0)))) ∧ + Semiformula.Evalb (u :> t :> b :> v) (code dg) := + by + rw [codePrecPredicate_eq, eval_codeAnd_iff] at h + obtain ⟨p, r, -, hr, hcase⟩ := h + have hrpos : 0 < r := by + rcases hcase with ⟨hpos, -⟩ | ⟨-, h0⟩ + · exact pos_of_pos_mul_right hpos + · exact absurd h0 _root_.one_ne_zero + obtain ⟨e, hne, he⟩ := ball_body_of_pos dg r hc arg v hrpos hr t ht + rw [codePrecStep_eq, eval_codeEq_iff] at he + obtain ⟨u, d, hu, hd, hdec⟩ := he + have hud : u = d := by + rcases hdec with ⟨heq, -⟩ | ⟨-, h0⟩ + · exact heq + · exact absurd h0 hne + rw [eval_comp_iff] at hd + obtain ⟨w, hw, hwi⟩ := hd + have hentry := hwi (Fin.succ 0) + simp only [Fin.cases_succ, Fin.cases_zero] at hentry + refine ⟨u, w (Fin.succ 0), hentry, hu, ?_⟩ + have hw0 : w 0 = t := by + have h0 := hwi 0 + simp only [Fin.cases_zero] at h0 + exact eval_unique h0 ((eval_proj_iff _ _ _).mpr rfl) + have hwv : ∀ j : Fin k, w j.succ.succ = v j := + by + intro j + have hj := hwi j.succ.succ + simp only [Fin.cases_succ] at hj + exact eval_unique hj ((eval_proj_iff _ _ _).mpr rfl) + have hshape : w = (t :> w (Fin.succ 0) :> v) := + by + funext j + refine Fin.cases ?_ ?_ j + · exact hw0 + · intro j' + refine Fin.cases ?_ ?_ j' + · rfl + · intro j''; exact hwv j'' + rw [hshape] at hw + exact hud ▸ hw + +/-! +### Correct histories agree below the recursion argument -/ + +open HierarchySymbol in +/-- Two correct histories, one for `a` and one for `a + 1`, record the same +entry at every index up to `a`. The induction is on a literal code graph and +uses Sigma-one induction. -/ +private theorem histories_agree [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] {k : ℕ} (df : Code k) (dg : Code (k + 2)) + (hc₀ hc₁ a : M) (v : Fin k → M) + (h₀ : Semiformula.Evalb ((1 : M) :> hc₀ :> a :> v) (code (codePrecPredicate df dg))) + (h₁ : Semiformula.Evalb ((1 : M) :> hc₁ :> (a + 1) :> v) (code (codePrecPredicate df dg))) + (i : M) (hia : i ≤ a) : + ∃ x : M, + Semiformula.Evalb (x :> i :> hc₀ :> hc₁ :> v) + (code (codeBeta (Code.proj 1) (Code.proj (0 : Fin (k + 3))))) ∧ + Semiformula.Evalb (x :> i :> hc₀ :> hc₁ :> v) + (code (codeBeta (Code.proj 2) (Code.proj (0 : Fin (k + 3))))) := by + let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + have hdef : + Σ-[1].DefinablePred + (fun c : M => + Semiformula.Evalb ((1 : M) :> c :> hc₀ :> hc₁ :> v) + (code + (codeEq (codeBeta (Code.proj 1) (Code.proj (0 : Fin (k + 3)))) + (codeBeta (Code.proj 2) (Code.proj (0 : Fin (k + 3)))))) ∨ + a < c) := + HierarchySymbol.Definable.or (definable_code_head_slot _ (1 : M) (hc₀ :> hc₁ :> v)) + (by definability) + have key : + ∀ c : M, + Semiformula.Evalb ((1 : M) :> c :> hc₀ :> hc₁ :> v) + (code + (codeEq (codeBeta (Code.proj 1) (Code.proj (0 : Fin (k + 3)))) + (codeBeta (Code.proj 2) (Code.proj (0 : Fin (k + 3)))))) ∨ + a < c := + by + refine InductionOnHierarchy.succ_induction Σ 1 hdef ?_ ?_ + · -- the initial entries are both the base value + obtain ⟨x₀, hx₀, hd₀⟩ := prec_base_of_pos df dg hc₀ a v h₀ + obtain ⟨x₁, hx₁, hd₁⟩ := prec_base_of_pos df dg hc₁ (a + 1) v h₁ + have hzero₀ : + Semiformula.Evalb ((0 : M) :> hc₀ :> a :> v) (code (codeConst (n := k + 2) 0)) := by + rw [eval_codeConst_iff]; simp + have hzero₁ : + Semiformula.Evalb ((0 : M) :> hc₁ :> (a + 1) :> v) (code (codeConst (n := k + 2) 0)) := + by rw [eval_codeConst_iff]; simp + refine + Or.inl + ((eval_codeEq_iff _ _ _ _).mpr ⟨x₀, x₁, ?_, ?_, Or.inl ⟨eval_unique hd₀ hd₁, rfl⟩⟩) + · exact + beta_align _ _ _ _ x₀ hc₀ 0 _ _ ((eval_proj_iff _ _ _).mpr rfl) + ((eval_proj_iff _ _ _).mpr rfl) hzero₀ ((eval_proj_iff _ _ _).mpr rfl) hx₀ + · exact + beta_align _ _ _ _ x₁ hc₁ 0 _ _ ((eval_proj_iff _ _ _).mpr rfl) + ((eval_proj_iff _ _ _).mpr rfl) hzero₁ ((eval_proj_iff _ _ _).mpr rfl) hx₁ + · intro c IH + by_cases hac : a < c + 1 + · exact Or.inr hac + · have hca : c < a := lt_of_lt_of_le (by simp) (not_lt.mp hac) + have hagree := IH.resolve_right (not_lt.mpr (le_of_lt hca)) + obtain ⟨y₀, y₁, hy₀, hy₁, hdec⟩ := (eval_codeEq_iff _ _ _ _).mp hagree + have hyy : y₀ = y₁ := by + rcases hdec with ⟨heq, -⟩ | ⟨-, h0⟩ + · exact heq + · exact absurd h0 _root_.one_ne_zero + obtain ⟨u₀, b₀, hb₀, hu₀, hdg₀⟩ := prec_step_of_pos df dg hc₀ a c v hca h₀ + obtain ⟨u₁, b₁, hb₁, hu₁, hdg₁⟩ := + prec_step_of_pos df dg hc₁ (a + 1) c v (lt_trans hca (by simp)) h₁ + have hb : b₀ = b₁ := + by + have e₀ : y₀ = b₀ := + eval_unique + (beta_align _ _ _ _ y₀ hc₀ c _ _ ((eval_proj_iff _ _ _).mpr rfl) + ((eval_proj_iff _ _ _).mpr rfl) ((eval_proj_iff _ _ _).mpr rfl) + ((eval_proj_iff _ _ _).mpr rfl) hy₀) + hb₀ + have e₁ : y₁ = b₁ := + eval_unique + (beta_align _ _ _ _ y₁ hc₁ c _ _ ((eval_proj_iff _ _ _).mpr rfl) + ((eval_proj_iff _ _ _).mpr rfl) ((eval_proj_iff _ _ _).mpr rfl) + ((eval_proj_iff _ _ _).mpr rfl) hy₁) + hb₁ + rw [← e₀, ← e₁, hyy] + have hu : u₀ = u₁ := by + rw [hb] at hdg₀ + exact eval_unique hdg₀ hdg₁ + have hsucc₀ : + Semiformula.Evalb ((c + 1) :> c :> hc₀ :> a :> v) + (code (codeSucc (Code.proj (0 : Fin (k + 3))))) := + (eval_codeSucc_iff _ _ _).mpr ⟨c, (eval_proj_iff _ _ _).mpr rfl, rfl⟩ + have hsucc₁ : + Semiformula.Evalb ((c + 1) :> c :> hc₁ :> (a + 1) :> v) + (code (codeSucc (Code.proj (0 : Fin (k + 3))))) := + (eval_codeSucc_iff _ _ _).mpr ⟨c, (eval_proj_iff _ _ _).mpr rfl, rfl⟩ + refine Or.inl ((eval_codeEq_iff _ _ _ _).mpr ⟨u₀, u₁, ?_, ?_, Or.inl ⟨hu, rfl⟩⟩) + · exact + beta_align _ _ _ _ u₀ hc₀ (c + 1) _ _ ((eval_proj_iff _ _ _).mpr rfl) + ((eval_proj_iff _ _ _).mpr rfl) hsucc₀ ((eval_proj_iff _ _ _).mpr rfl) hu₀ + · exact + beta_align _ _ _ _ u₁ hc₁ (c + 1) _ _ ((eval_proj_iff _ _ _).mpr rfl) + ((eval_proj_iff _ _ _).mpr rfl) hsucc₁ ((eval_proj_iff _ _ _).mpr rfl) hu₁ + obtain ⟨y₀, y₁, hy₀, hy₁, hdec⟩ := + (eval_codeEq_iff _ _ _ _).mp ((key i).resolve_right (not_lt.mpr hia)) + have hyy : y₀ = y₁ := by + rcases hdec with ⟨heq, -⟩ | ⟨-, h0⟩ + · exact heq + · exact absurd h0 _root_.one_ne_zero + exact ⟨y₀, hy₀, hyy ▸ hy₁⟩ + +end Restriction + +section Successor + +variable {M : Type*} [ORingStructure M] + +open scoped FFL.FirstOrder.Arithmetic + +open HierarchySymbol + +/-! +### The successor step of primitive recursion -/ + +open HierarchySymbol in +/-- Evaluating `codePrec df dg` at `a + 1` gives the value at `a` together with +one application of the step code. + +The two evaluations read different correct histories, so the proof aligns their +entries by Sigma-one induction before reading the predecessor value. -/ +theorem eval_codePrec_succ [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] {k : ℕ} (df : Code k) (dg : Code (k + 2)) (a z : M) + (v : Fin k → M) (h : Semiformula.Evalb (z :> (a + 1) :> v) (code (codePrec df dg))) : + ∃ w : M, + Semiformula.Evalb (w :> a :> v) (code (codePrec df dg)) ∧ + Semiformula.Evalb (z :> a :> w :> v) (code dg) := + by + let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + rw [codePrec, eval_codeBind_iff] at h + obtain ⟨hc₁, hsearch, hread⟩ := h + rw [eval_codeRfindPos_iff] at hsearch + obtain ⟨⟨q, hq, hP⟩, hmin⟩ := hsearch + have hq1 : q = 1 := by + rw [codePrecPredicate_eq, eval_codeAnd_iff] at hP + obtain ⟨p, r, -, -, hcase⟩ := hP + rcases hcase with ⟨-, h1⟩ | ⟨-, h0⟩ + · exact h1 + · exact absurd h0 (ne_of_gt hq) + rw [hq1] at hP + have hPa := precPredicate_pos_step_down df dg hc₁ a 1 v (by simp) hP + have hdefQ : + Σ-[1].DefinablePred + (fun c : M => + Semiformula.Evalb ((1 : M) :> c :> a :> v) (code (codePrecPredicate df dg))) := + definable_code_head_slot _ (1 : M) (a :> v) + obtain ⟨hc₀, hQ₀, hleast⟩ := InductionOnHierarchy.least_number Σ 1 hdefQ hPa + have hle : hc₀ ≤ hc₁ := not_lt.mp fun hlt => hleast hc₁ hlt hPa + have hsearch₀ : + Semiformula.Evalb (hc₀ :> a :> v) (code (codeRfindPos (codePrecPredicate df dg))) := + by + refine (eval_codeRfindPos_iff _ _ _).mpr ⟨⟨1, by simp, hQ₀⟩, ?_⟩ + intro t ht + obtain ⟨q', hq'⟩ := + precPredicate_val_step_down df dg t a 0 v (hmin t (lt_of_lt_of_le ht hle)) + have hq'0 : q' = 0 := + by + rw [codePrecPredicate_eq, eval_codeAnd_iff] at hq' + obtain ⟨p, r, hp, hr, hcase⟩ := hq' + rcases hcase with ⟨hpos, h1⟩ | ⟨-, h0⟩ + · refine absurd ?_ (hleast t ht) + rw [codePrecPredicate_eq, eval_codeAnd_iff] + exact ⟨p, r, hp, hr, Or.inl ⟨hpos, rfl⟩⟩ + · exact h0 + rwa [hq'0] at hq' + obtain ⟨u, b, hb, hu, hdg⟩ := prec_step_of_pos df dg hc₁ (a + 1) a v (by simp) hP + have huz : u = z := + eval_unique + (beta_align _ _ _ _ u hc₁ (a + 1) _ _ ((eval_proj_iff _ _ _).mpr rfl) + ((eval_codeHead_iff _ _).mpr rfl) + ((eval_codeSucc_iff _ _ _).mpr ⟨a, (eval_proj_iff _ _ _).mpr rfl, rfl⟩) + ((eval_codeLift_iff _ _ _ _).mpr ((eval_codeHead_iff _ _).mpr rfl)) hu) + hread + obtain ⟨x, hx₀, hx₁⟩ := histories_agree df dg hc₀ hc₁ a v hQ₀ hP a le_rfl + have hxb : x = b := + eval_unique + (beta_align _ _ _ _ x hc₁ a _ _ ((eval_proj_iff _ _ _).mpr rfl) + ((eval_proj_iff _ _ _).mpr rfl) ((eval_proj_iff _ _ _).mpr rfl) + ((eval_proj_iff _ _ _).mpr rfl) hx₁) + hb + refine ⟨b, ?_, huz ▸ hdg⟩ + rw [codePrec, eval_codeBind_iff] + refine ⟨hc₀, hsearch₀, ?_⟩ + refine + hxb ▸ + beta_align _ _ _ _ x hc₀ a _ _ ((eval_proj_iff _ _ _).mpr rfl) + ((eval_codeHead_iff _ _).mpr rfl) ((eval_proj_iff _ _ _).mpr rfl) + ((eval_codeLift_iff _ _ _ _).mpr ((eval_codeHead_iff _ _).mpr rfl)) hx₀ + +/-- Evaluating `codePrec df dg` at zero gives the same value for the base code. + +This is the forward direction only: a successful evaluation of the recursion at +zero yields a successful evaluation of `df` with the same output. Nothing here +asserts the converse. -/ +theorem eval_codePrec_zero [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : ℕ} (df : Code k) (dg : Code (k + 2)) (z : M) + (v : Fin k → M) (h : Semiformula.Evalb (z :> (0 : M) :> v) (code (codePrec df dg))) : + Semiformula.Evalb (z :> v) (code df) := + by + rw [codePrec, eval_codeBind_iff] at h + obtain ⟨hc, hsearch, hread⟩ := h + rw [eval_codeRfindPos_iff] at hsearch + obtain ⟨⟨q, hq, hP⟩, -⟩ := hsearch + have hq1 : q = 1 := by + rw [codePrecPredicate_eq, eval_codeAnd_iff] at hP + obtain ⟨p, r, -, -, hcase⟩ := hP + rcases hcase with ⟨-, h1⟩ | ⟨-, h0⟩ + · exact h1 + · exact absurd h0 (ne_of_gt hq) + rw [hq1] at hP + obtain ⟨x, hx, hdf⟩ := prec_base_of_pos df dg hc 0 v hP + have hzero : + Semiformula.Evalb ((0 : M) :> hc :> (0 : M) :> v) (code (codeConst (n := k + 2) 0)) := by + rw [eval_codeConst_iff]; simp + have hxz : x = z := + eval_unique + (beta_align _ _ _ _ x hc 0 _ _ ((eval_proj_iff _ _ _).mpr rfl) + ((eval_codeHead_iff _ _).mpr rfl) hzero + ((eval_codeLift_iff _ _ _ _).mpr ((eval_codeHead_iff _ _).mpr rfl)) hx) + hread + exact hxz ▸ hdf + +end Successor + +section Existence + +variable {M : Type*} [ORingStructure M] + +open scoped FFL.FirstOrder.Arithmetic + +open HierarchySymbol + +/-! +### Totality of the step relation -/ + +/-- The step code applied to the history entry at an index, read inside the +assignment of `codePrecStep`. -/ +private theorem prec_step_comp_of {k : ℕ} (dg : Code (k + 2)) (i hc arg z w : M) (v : Fin k → M) + (hz : + Semiformula.Evalb (z :> i :> hc :> arg :> v) + (code (codeBeta (Code.proj 1) (Code.proj (0 : Fin (k + 3)))))) + (hw : Semiformula.Evalb (w :> i :> z :> v) (code dg)) : + Semiformula.Evalb (w :> i :> hc :> arg :> v) + (code + (dg.comp + (Fin.cases (Code.proj 0) + (Fin.cases (codeBeta (Code.proj 1) (Code.proj 0)) + (fun j => Code.proj j.succ.succ.succ))))) := + by + rw [eval_comp_iff] + refine ⟨i :> z :> v, hw, ?_⟩ + intro j + refine Fin.cases ?_ ?_ j + · simp only [Fin.cases_zero, Matrix.cons_val_zero] + exact (eval_proj_iff (0 : Fin (k + 3)) i (i :> hc :> arg :> v)).mpr rfl + · intro j1 + refine Fin.cases ?_ ?_ j1 + · simp only [Fin.cases_succ, Fin.cases_zero] + exact hz + · intro j2 + simp only [Fin.cases_succ] + exact (eval_proj_iff j2.succ.succ.succ _ (i :> hc :> arg :> v)).mpr (by simp) + +/-- A step evaluation with output one, from the two history entries it relates +and the step value between them. -/ +private theorem prec_step_pos_of {k : ℕ} (dg : Code (k + 2)) (i hc arg z w : M) (v : Fin k → M) + (hz : + Semiformula.Evalb (z :> i :> hc :> arg :> v) + (code (codeBeta (Code.proj 1) (Code.proj (0 : Fin (k + 3)))))) + (hu : + Semiformula.Evalb (w :> i :> hc :> arg :> v) + (code (codeBeta (Code.proj 1) (codeSucc (Code.proj (0 : Fin (k + 3))))))) + (hw : Semiformula.Evalb (w :> i :> z :> v) (code dg)) : + Semiformula.Evalb ((1 : M) :> i :> hc :> arg :> v) (code (codePrecStep dg)) := + by + rw [codePrecStep_eq] + exact + (eval_codeEq_iff _ _ _ _).mpr + ⟨w, w, hu, prec_step_comp_of dg i hc arg z w v hz hw, Or.inl ⟨rfl, rfl⟩⟩ + +/-- The step relation has a value at every index the step code is total at, +whatever history code and recursion argument accompany it. -/ +private theorem prec_step_total [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] {k : ℕ} (dg : Code (k + 2)) (a : M) + (v : Fin k → M) + (hdg : ∀ i : M, i ≤ a → ∀ z : M, ∃ w : M, Semiformula.Evalb (w :> i :> z :> v) (code dg)) + (i hc arg : M) (hi : i ≤ a) : + ∃ e : M, Semiformula.Evalb (e :> i :> hc :> arg :> v) (code (codePrecStep dg)) := + by + let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + have hhc : + Semiformula.Evalb (hc :> i :> hc :> arg :> v) (code (Code.proj (1 : Fin (k + 3)))) := + (eval_proj_iff _ _ _).mpr (by simp) + have hidx : + Semiformula.Evalb (i :> i :> hc :> arg :> v) (code (Code.proj (0 : Fin (k + 3)))) := + (eval_proj_iff _ _ _).mpr rfl + have hsucc : + Semiformula.Evalb ((i + 1) :> i :> hc :> arg :> v) + (code (codeSucc (Code.proj (0 : Fin (k + 3))))) := + (eval_codeSucc_iff _ _ _).mpr ⟨i, hidx, rfl⟩ + have hbeta := + eval_codeBeta_of_values (Code.proj (1 : Fin (k + 3))) (Code.proj (0 : Fin (k + 3))) hc i + (i :> hc :> arg :> v) hhc hidx + have hnext := + eval_codeBeta_of_values (Code.proj (1 : Fin (k + 3))) + (codeSucc (Code.proj (0 : Fin (k + 3)))) hc (i + 1) (i :> hc :> arg :> v) hhc hsucc + obtain ⟨w, hw⟩ := hdg i hi _ + have hcomp := prec_step_comp_of dg i hc arg _ w v hbeta hw + rw [codePrecStep_eq] + by_cases heq : + (FFL.FirstOrder.Arithmetic.pi₁ hc % ((i + 1 + 1) * FFL.FirstOrder.Arithmetic.pi₂ hc + 1)) = + w + · exact ⟨1, (eval_codeEq_iff _ _ _ _).mpr ⟨_, w, hnext, hcomp, Or.inl ⟨heq, rfl⟩⟩⟩ + · exact ⟨0, (eval_codeEq_iff _ _ _ _).mpr ⟨_, w, hnext, hcomp, Or.inr ⟨heq, rfl⟩⟩⟩ + +/-! +### Introducing the bounded quantifier without a positive terminal step -/ + +/-- The bounded quantifier takes the value one as soon as the step is positive +strictly below the recursion argument and merely has a value at it. + +`ball_pos_of_body` demands a positive step at the recursion argument as well. +The eager search only needs a value there, because the comparison disjunct is +already positive at that index. -/ +private theorem ball_pos_of_body_weak [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : ℕ} (dg : Code (k + 2)) (hc arg : M) + (v : Fin k → M) + (hbelow : + ∀ t : M, + t < arg → + ∃ e : M, + e ≠ 0 ∧ Semiformula.Evalb (e :> t :> hc :> arg :> v) (code (codePrecStep dg))) + (hterm : ∃ e : M, Semiformula.Evalb (e :> arg :> hc :> arg :> v) (code (codePrecStep dg))) : + Semiformula.Evalb ((1 : M) :> hc :> arg :> v) + (code (codeBall (codePrecStep dg) (1 : Fin (k + 2)))) := + by + have hlift : + Semiformula.Evalb (arg :> arg :> hc :> arg :> v) + (code (codeLift (Code.proj (1 : Fin (k + 2))))) := + (eval_codeLift_iff _ _ _ _).mpr ((eval_proj_iff _ _ _).mpr rfl) + have hhead : + Semiformula.Evalb (arg :> arg :> hc :> arg :> v) (code (codeHead (n := k + 2))) := + (eval_codeHead_iff _ _).mpr rfl + rw [codeBall, eval_codeBind_iff] + refine ⟨arg, ?_, (eval_codeEq_iff _ _ _ _).mpr ⟨arg, arg, hhead, hlift, Or.inl ⟨rfl, rfl⟩⟩⟩ + rw [eval_codeRfindPos_iff] + refine ⟨⟨1, by simp, ?_⟩, ?_⟩ + · obtain ⟨e, he⟩ := hterm + exact eval_precSearch_one dg arg hc arg e v he (Or.inr le_rfl) + · intro t ht + exact (eval_precSearch_zero_iff dg t hc arg v).mpr ⟨hbelow t ht, ht⟩ + +/-! +### Totality of the correctness predicate at an arbitrary history -/ + +/-- The bounded quantifier has a value at every history code, correct or not. -/ +private theorem ball_total [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] {k : ℕ} (dg : Code (k + 2)) (a : M) (v : Fin k → M) + (hdg : ∀ i : M, i ≤ a → ∀ z : M, ∃ w : M, Semiformula.Evalb (w :> i :> z :> v) (code dg)) + (hc : M) : + ∃ y : M, + Semiformula.Evalb (y :> hc :> a :> v) + (code (codeBall (codePrecStep dg) (1 : Fin (k + 2)))) := + by + let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + have hposA : + Semiformula.Evalb ((1 : M) :> a :> hc :> a :> v) + (code + (codeOr (codeInv (codePrecStep dg)) + (codeLe (codeLift (Code.proj (1 : Fin (k + 2)))) (codeHead (n := k + 2))))) := + by + obtain ⟨e, he⟩ := prec_step_total dg a v hdg a hc a le_rfl + exact eval_precSearch_one dg a hc a e v he (Or.inr le_rfl) + have hnotA : + ¬Semiformula.Evalb ((0 : M) :> a :> hc :> a :> v) + (code + (codeOr (codeInv (codePrecStep dg)) + (codeLe (codeLift (Code.proj (1 : Fin (k + 2)))) (codeHead (n := k + 2))))) := + by + intro h0 + exact absurd (eval_unique h0 hposA) (by simp) + have hdef : + Π-[1].DefinablePred + (fun t : M => + ¬Semiformula.Evalb ((0 : M) :> t :> hc :> a :> v) + (code + (codeOr (codeInv (codePrecStep dg)) + (codeLe (codeLift (Code.proj (1 : Fin (k + 2)))) (codeHead (n := k + 2)))))) := + HierarchySymbol.Definable.not (definable_code_head_slot _ (0 : M) (hc :> a :> v)) + obtain ⟨j, hjnot, hjmin⟩ := InductionOnHierarchy.least_number Π 1 hdef hnotA + have hja : j ≤ a := not_lt.mp fun hlt => hjmin a hlt hnotA + have hbelow : + ∀ t : M, + t < j → + Semiformula.Evalb ((0 : M) :> t :> hc :> a :> v) + (code + (codeOr (codeInv (codePrecStep dg)) + (codeLe (codeLift (Code.proj (1 : Fin (k + 2)))) (codeHead (n := k + 2))))) := + fun t ht => not_not.mp (hjmin t ht) + have hposJ : + Semiformula.Evalb ((1 : M) :> j :> hc :> a :> v) + (code + (codeOr (codeInv (codePrecStep dg)) + (codeLe (codeLift (Code.proj (1 : Fin (k + 2)))) (codeHead (n := k + 2))))) := + by + obtain ⟨e, he⟩ := prec_step_total dg a v hdg j hc a hja + by_cases he0 : e = 0 + · exact eval_precSearch_one dg j hc a e v he (Or.inl he0) + · by_cases hlt : j < a + · exact absurd ((eval_precSearch_zero_iff dg j hc a v).mpr ⟨⟨e, he0, he⟩, hlt⟩) hjnot + · exact eval_precSearch_one dg j hc a e v he (Or.inr (not_lt.mp hlt)) + exact + ball_val_of_rfind dg hc a j v + ((eval_codeRfindPos_iff _ _ _).mpr ⟨⟨1, by simp, hposJ⟩, hbelow⟩) + +/-- The correctness predicate has a value at every history code. The outer +minimization inside `codePrec` needs this at incorrect histories too. -/ +private theorem prec_predicate_total [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] {k : ℕ} (df : Code k) (dg : Code (k + 2)) + (a : M) (v : Fin k → M) (hdf : ∃ z : M, Semiformula.Evalb (z :> v) (code df)) + (hdg : ∀ i : M, i ≤ a → ∀ z : M, ∃ w : M, Semiformula.Evalb (w :> i :> z :> v) (code dg)) + (hc : M) : + ∃ q : M, Semiformula.Evalb (q :> hc :> a :> v) (code (codePrecPredicate df dg)) := + by + let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + have hhc : Semiformula.Evalb (hc :> hc :> a :> v) (code (Code.proj (0 : Fin (k + 2)))) := + (eval_proj_iff _ _ _).mpr rfl + have hzero : Semiformula.Evalb ((0 : M) :> hc :> a :> v) (code (codeConst (n := k + 2) 0)) := + by rw [eval_codeConst_iff]; simp + have hb := + eval_codeBeta_of_values (Code.proj (0 : Fin (k + 2))) (codeConst (n := k + 2) 0) hc 0 + (hc :> a :> v) hhc hzero + obtain ⟨x, hx⟩ := hdf + have hcomp : + Semiformula.Evalb (x :> hc :> a :> v) (code (df.comp (fun j => Code.proj j.succ.succ))) := + by + rw [eval_comp_iff] + exact ⟨v, hx, fun j => (eval_proj_iff _ _ _).mpr (by simp)⟩ + have hbase : + ∃ p : M, + Semiformula.Evalb (p :> hc :> a :> v) + (code + (codeEq (codeBeta (Code.proj 0) (codeConst 0)) + (df.comp (fun j => Code.proj j.succ.succ)))) := + by + by_cases heq : + (FFL.FirstOrder.Arithmetic.pi₁ hc % ((0 + 1) * FFL.FirstOrder.Arithmetic.pi₂ hc + 1)) = x + · exact ⟨1, (eval_codeEq_iff _ _ _ _).mpr ⟨_, x, hb, hcomp, Or.inl ⟨heq, rfl⟩⟩⟩ + · exact ⟨0, (eval_codeEq_iff _ _ _ _).mpr ⟨_, x, hb, hcomp, Or.inr ⟨heq, rfl⟩⟩⟩ + obtain ⟨p, hp⟩ := hbase + obtain ⟨y, hy⟩ := ball_total dg a v hdg hc + rw [codePrecPredicate_eq] + by_cases hpos : 0 < p * y + · exact ⟨1, (eval_codeAnd_iff _ _ _ _).mpr ⟨p, y, hp, hy, Or.inl ⟨hpos, rfl⟩⟩⟩ + · exact ⟨0, (eval_codeAnd_iff _ _ _ _).mpr ⟨p, y, hp, hy, Or.inr ⟨hpos, rfl⟩⟩⟩ + +/-! +### Moving a history entry between the two-argument beta code and the +assignments of `codePrecPredicate` -/ + +/-- Read a two-argument beta evaluation at a wider assignment. -/ +private theorem beta_of_pair [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {l : ℕ} (N' I' : Code l) (x n idx : M) + (v' : Fin l → M) (hN' : Semiformula.Evalb (n :> v') (code N')) + (hI' : Semiformula.Evalb (idx :> v') (code I')) + (h : + Semiformula.Evalb (x :> ![n, idx]) + (code (codeBeta (Code.proj (0 : Fin 2)) (Code.proj (1 : Fin 2))))) : + Semiformula.Evalb (x :> v') (code (codeBeta N' I')) := + beta_align _ _ N' I' x n idx ![n, idx] v' ((eval_proj_iff _ _ _).mpr (by simp)) hN' + ((eval_proj_iff _ _ _).mpr (by simp)) hI' h + +/-- Read a beta evaluation at a wider assignment as a two-argument one. -/ +private theorem beta_to_pair [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {l : ℕ} (N' I' : Code l) (x n idx : M) + (v' : Fin l → M) (hN' : Semiformula.Evalb (n :> v') (code N')) + (hI' : Semiformula.Evalb (idx :> v') (code I')) + (h : Semiformula.Evalb (x :> v') (code (codeBeta N' I'))) : + Semiformula.Evalb (x :> ![n, idx]) + (code (codeBeta (Code.proj (0 : Fin 2)) (Code.proj (1 : Fin 2)))) := + beta_align N' I' _ _ x n idx v' ![n, idx] hN' ((eval_proj_iff _ _ _).mpr (by simp)) hI' + ((eval_proj_iff _ _ _).mpr (by simp)) h + +/-! +### Sigma-one definability of a literal code graph in two argument slots -/ + +open HierarchySymbol in +/-- Varying the first two arguments of the graph formula of a code, with the +output and the remaining arguments fixed as parameters, is a Sigma-one +condition. -/ +private theorem definable_code_two_slots {m : ℕ} (A : Code (m + 2)) (out : M) + (par : Fin m → M) : + Σ-[1].Definable + (fun w : Fin 2 → M => Semiformula.Evalb (out :> w 0 :> w 1 :> par) (code A)) := + by + refine + ⟨HierarchySymbol.Semiformula.mkSigma + ((Rew.embSubsts + ((&out : Semiterm ℒₒᵣ M 2) :> + (#0 : Semiterm ℒₒᵣ M 2) :> + (#1 : Semiterm ℒₒᵣ M 2) :> fun j => (&(par j) : Semiterm ℒₒᵣ M 2))) ▹ + (code A)) + (Hierarchy.rew _ (code_sigma_one A)), + ?_⟩ + intro w + simp only [HierarchySymbol.Semiformula.val_mkSigma, Semiformula.eval_embSubsts] + have hv : + (Semiterm.val w id ∘ + ((&out : Semiterm ℒₒᵣ M 2) :> + (#0 : Semiterm ℒₒᵣ M 2) :> + (#1 : Semiterm ℒₒᵣ M 2) :> fun j => (&(par j) : Semiterm ℒₒᵣ M 2))) = + (out :> w 0 :> w 1 :> par) := + by + funext j + refine Fin.cases ?_ ?_ j + · simp + · intro j1 + refine Fin.cases ?_ ?_ j1 + · simp + · intro j2 + refine Fin.cases ?_ ?_ j2 + · simp + · intro j3; simp + rw [hv] + +open HierarchySymbol in +/-- Existence of a history at which a literal code graph holds is a Sigma-one +condition on the remaining head argument. -/ +private theorem definable_exists_history {k : ℕ} (A : Code (k + 2)) (out : M) + (par : Fin k → M) : + Σ-[1].DefinablePred + (fun c : M => ∃ hc : M, Semiformula.Evalb (out :> hc :> c :> par) (code A)) := + by + refine HierarchySymbol.Definable.exs ?_ + refine (definable_code_two_slots A out par).of_iff ?_ + intro w + simp + +/-! +### Building a correct history -/ + +/-- A history code whose correctness predicate takes the value one at the +recursion argument, built by Sigma-one induction on the argument. + +The disjunct `a < c` lets the induction run past the range in which the step +code is assumed total. -/ +private theorem exists_pos_history [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] {k : ℕ} (df : Code k) (dg : Code (k + 2)) + (a : M) (v : Fin k → M) (hdf : ∃ z : M, Semiformula.Evalb (z :> v) (code df)) + (hdg : ∀ i : M, i ≤ a → ∀ z : M, ∃ w : M, Semiformula.Evalb (w :> i :> z :> v) (code dg)) : + ∃ hc : M, Semiformula.Evalb ((1 : M) :> hc :> a :> v) (code (codePrecPredicate df dg)) := + by + let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + have hdef : + Σ-[1].DefinablePred + (fun c : M => + (∃ hc : M, + Semiformula.Evalb ((1 : M) :> hc :> c :> v) (code (codePrecPredicate df dg))) ∨ + a < c) := + HierarchySymbol.Definable.or (definable_exists_history _ (1 : M) v) (by definability) + have key : + ∀ c : M, + (∃ hc : M, Semiformula.Evalb ((1 : M) :> hc :> c :> v) (code (codePrecPredicate df dg))) ∨ + a < c := + by + refine InductionOnHierarchy.succ_induction Σ 1 hdef ?_ ?_ + · obtain ⟨x, hx⟩ := hdf + obtain ⟨hc, -, hxpair⟩ := exists_codeBeta_extension (0 : M) (0 : M) x + refine Or.inl ⟨hc, ?_⟩ + have hhc : + Semiformula.Evalb (hc :> hc :> (0 : M) :> v) (code (Code.proj (0 : Fin (k + 2)))) := + (eval_proj_iff _ _ _).mpr rfl + have hzero : + Semiformula.Evalb ((0 : M) :> hc :> (0 : M) :> v) (code (codeConst (n := k + 2) 0)) := + by rw [eval_codeConst_iff]; simp + have hb : + Semiformula.Evalb (x :> hc :> (0 : M) :> v) + (code (codeBeta (Code.proj 0) (codeConst 0))) := + beta_of_pair _ _ x hc 0 _ hhc hzero hxpair + have hcomp : + Semiformula.Evalb (x :> hc :> (0 : M) :> v) + (code (df.comp (fun j => Code.proj j.succ.succ))) := + by + rw [eval_comp_iff] + exact ⟨v, hx, fun j => (eval_proj_iff _ _ _).mpr (by simp)⟩ + rw [codePrecPredicate_eq] + refine (eval_codeAnd_iff _ _ _ _).mpr ⟨1, 1, ?_, ?_, Or.inl ⟨by simp, rfl⟩⟩ + · exact (eval_codeEq_iff _ _ _ _).mpr ⟨x, x, hb, hcomp, Or.inl ⟨rfl, rfl⟩⟩ + · exact + ball_pos_of_body_weak dg hc 0 v (fun t ht => absurd ht (by simp)) + (prec_step_total dg a v hdg 0 hc 0 (by simp)) + · intro c IH + by_cases hac : a < c + 1 + · exact Or.inr hac + · have hca1 : c + 1 ≤ a := not_lt.mp hac + have hca : c < a := lt_of_lt_of_le (by simp) hca1 + obtain ⟨hc, hP⟩ := IH.resolve_right (not_lt.mpr (le_of_lt hca)) + have hpair : + ∀ i : M, + Semiformula.Evalb + ((FFL.FirstOrder.Arithmetic.pi₁ hc % + ((i + 1) * FFL.FirstOrder.Arithmetic.pi₂ hc + 1)) :> + ![hc, i]) + (code (codeBeta (Code.proj (0 : Fin 2)) (Code.proj (1 : Fin 2)))) := + fun i => + eval_codeBeta_of_values _ _ hc i ![hc, i] ((eval_proj_iff _ _ _).mpr (by simp)) + ((eval_proj_iff _ _ _).mpr (by simp)) + obtain ⟨w, hw⟩ := hdg c (le_of_lt hca) _ + obtain ⟨hc', htr, hnew⟩ := exists_codeBeta_extension hc (c + 1) w + refine Or.inl ⟨hc', ?_⟩ + have hhc' : + Semiformula.Evalb (hc' :> hc' :> (c + 1) :> v) (code (Code.proj (0 : Fin (k + 2)))) := + (eval_proj_iff _ _ _).mpr rfl + have hzero' : + Semiformula.Evalb ((0 : M) :> hc' :> (c + 1) :> v) + (code (codeConst (n := k + 2) 0)) := + by rw [eval_codeConst_iff]; simp + obtain ⟨x, hx0, hxdf⟩ := prec_base_of_pos df dg hc c v hP + have hhc0 : + Semiformula.Evalb (hc :> hc :> c :> v) (code (Code.proj (0 : Fin (k + 2)))) := + (eval_proj_iff _ _ _).mpr rfl + have hzero0 : + Semiformula.Evalb ((0 : M) :> hc :> c :> v) (code (codeConst (n := k + 2) 0)) := by + rw [eval_codeConst_iff]; simp + have hx0' : + Semiformula.Evalb (x :> hc' :> (c + 1) :> v) + (code (codeBeta (Code.proj 0) (codeConst 0))) := + beta_of_pair _ _ x hc' 0 _ hhc' hzero' + (htr 0 x (by simp) (beta_to_pair _ _ x hc 0 _ hhc0 hzero0 hx0)) + have hcomp : + Semiformula.Evalb (x :> hc' :> (c + 1) :> v) + (code (df.comp (fun j => Code.proj j.succ.succ))) := + by + rw [eval_comp_iff] + exact ⟨v, hxdf, fun j => (eval_proj_iff _ _ _).mpr (by simp)⟩ + have hbelow : + ∀ t : M, + t < c + 1 → + ∃ e : M, + e ≠ 0 ∧ + Semiformula.Evalb (e :> t :> hc' :> (c + 1) :> v) (code (codePrecStep dg)) := + by + intro t ht + have hidx' : + Semiformula.Evalb (t :> t :> hc' :> (c + 1) :> v) + (code (Code.proj (0 : Fin (k + 3)))) := + (eval_proj_iff _ _ _).mpr rfl + have hhist' : + Semiformula.Evalb (hc' :> t :> hc' :> (c + 1) :> v) + (code (Code.proj (1 : Fin (k + 3)))) := + (eval_proj_iff _ _ _).mpr (by simp) + have hsucc' : + Semiformula.Evalb ((t + 1) :> t :> hc' :> (c + 1) :> v) + (code (codeSucc (Code.proj (0 : Fin (k + 3))))) := + (eval_codeSucc_iff _ _ _).mpr ⟨t, hidx', rfl⟩ + rcases le_iff_lt_or_eq.mp (lt_succ_iff_le.mp ht) with htc | rfl + · obtain ⟨u, b, hb, hu, hdgv⟩ := prec_step_of_pos df dg hc c t v htc hP + have hidx0 : + Semiformula.Evalb (t :> t :> hc :> c :> v) (code (Code.proj (0 : Fin (k + 3)))) := + (eval_proj_iff _ _ _).mpr rfl + have hhist0 : + Semiformula.Evalb (hc :> t :> hc :> c :> v) + (code (Code.proj (1 : Fin (k + 3)))) := + (eval_proj_iff _ _ _).mpr (by simp) + have hsucc0 : + Semiformula.Evalb ((t + 1) :> t :> hc :> c :> v) + (code (codeSucc (Code.proj (0 : Fin (k + 3))))) := + (eval_codeSucc_iff _ _ _).mpr ⟨t, hidx0, rfl⟩ + refine ⟨1, _root_.one_ne_zero, prec_step_pos_of dg t hc' (c + 1) b u v ?_ ?_ hdgv⟩ + · exact + beta_of_pair _ _ b hc' t _ hhist' hidx' + (htr t b ht (beta_to_pair _ _ b hc t _ hhist0 hidx0 hb)) + · exact + beta_of_pair _ _ u hc' (t + 1) _ hhist' hsucc' + (htr (t + 1) u (by simpa using htc) + (beta_to_pair _ _ u hc (t + 1) _ hhist0 hsucc0 hu)) + · refine ⟨1, _root_.one_ne_zero, prec_step_pos_of dg _ hc' _ _ w v ?_ ?_ hw⟩ + · exact beta_of_pair _ _ _ hc' _ _ hhist' hidx' (htr _ _ ht (hpair _)) + · exact beta_of_pair _ _ w hc' _ _ hhist' hsucc' hnew + rw [codePrecPredicate_eq] + refine (eval_codeAnd_iff _ _ _ _).mpr ⟨1, 1, ?_, ?_, Or.inl ⟨by simp, rfl⟩⟩ + · exact (eval_codeEq_iff _ _ _ _).mpr ⟨x, x, hx0', hcomp, Or.inl ⟨rfl, rfl⟩⟩ + · exact + ball_pos_of_body_weak dg hc' (c + 1) v hbelow + (prec_step_total dg a v hdg (c + 1) hc' (c + 1) hca1) + exact (key a).resolve_right (_root_.lt_irrefl a) + +/-! +### Generic existence for the recursion constructor -/ + +open HierarchySymbol in +/-- `codePrec df dg` has a value at every recursion argument at which the base +code has one and the step code is total at every index up to that argument. + +The step premise is uniform in the predecessor value and is required only up to +the recursion argument itself. The index `a` is included because the eager +bounded search of `codeBall` evaluates the step there as well; nothing beyond +`a` is used. -/ +theorem eval_codePrec_exists_of_total [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] {k : ℕ} (df : Code k) (dg : Code (k + 2)) + (a : M) (v : Fin k → M) (hdf : ∃ z : M, Semiformula.Evalb (z :> v) (code df)) + (hdg : ∀ i : M, i ≤ a → ∀ z : M, ∃ w : M, Semiformula.Evalb (w :> i :> z :> v) (code dg)) : + ∃ z : M, Semiformula.Evalb (z :> a :> v) (code (codePrec df dg)) := + by + let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + obtain ⟨hc, hP⟩ := exists_pos_history df dg a v hdf hdg + have hdefQ : + Σ-[1].DefinablePred + (fun c : M => + Semiformula.Evalb ((1 : M) :> c :> a :> v) (code (codePrecPredicate df dg))) := + definable_code_head_slot _ (1 : M) (a :> v) + obtain ⟨hc₀, hQ₀, hleast⟩ := InductionOnHierarchy.least_number Σ 1 hdefQ hP + have hsearch : + Semiformula.Evalb (hc₀ :> a :> v) (code (codeRfindPos (codePrecPredicate df dg))) := + by + refine (eval_codeRfindPos_iff _ _ _).mpr ⟨⟨1, by simp, hQ₀⟩, ?_⟩ + intro t ht + obtain ⟨q, hq⟩ := prec_predicate_total df dg a v hdf hdg t + have hq0 : q = 0 := by + rw [codePrecPredicate_eq, eval_codeAnd_iff] at hq + obtain ⟨p, r, hp, hr, hcase⟩ := hq + rcases hcase with ⟨hpos, -⟩ | ⟨-, h0⟩ + · refine absurd ?_ (hleast t ht) + rw [codePrecPredicate_eq, eval_codeAnd_iff] + exact ⟨p, r, hp, hr, Or.inl ⟨hpos, rfl⟩⟩ + · exact h0 + rwa [hq0] at hq + have hhead : Semiformula.Evalb (hc₀ :> hc₀ :> a :> v) (code (codeHead (n := k + 1))) := + (eval_codeHead_iff _ _).mpr rfl + have hlift : Semiformula.Evalb (a :> hc₀ :> a :> v) (code (codeLift (codeHead (n := k)))) := + (eval_codeLift_iff _ _ _ _).mpr ((eval_codeHead_iff _ _).mpr rfl) + refine + ⟨FFL.FirstOrder.Arithmetic.pi₁ hc₀ % ((a + 1) * FFL.FirstOrder.Arithmetic.pi₂ hc₀ + 1), ?_⟩ + rw [codePrec, eval_codeBind_iff] + exact ⟨hc₀, hsearch, eval_codeBeta_of_values _ _ hc₀ a (hc₀ :> a :> v) hhead hlift⟩ + +/-! +### Halving -/ + +/-- `codeDiv2 A` has a value at any value of `A`. + +`codeDiv2Unary` is `codePrec` with a zero base and an eager conditional on the +parity of the recursion index as step, so `eval_codePrec_exists_of_total` +applies: the step has a value at every index and every predecessor value. Only +existence is asserted; the witness is not identified with any quotient of `a`. -/ +theorem eval_codeDiv2_exists_of_value [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] {k : ℕ} (A : Code k) (a : M) + (v : Fin k → M) (hA : Semiformula.Evalb (a :> v) (code A)) : + ∃ z : M, Semiformula.Evalb (z :> v) (code (codeDiv2 A)) := + by + let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + obtain ⟨w, hw⟩ : + ∃ w : M, Semiformula.Evalb (w :> a :> (![] : Fin 0 → M)) (code codeDiv2Unary) := + by + refine + eval_codePrec_exists_of_total (Code.zero 0) + (codeIfPos (codeBodd (Code.proj 0)) (codeSucc (Code.proj 1)) (Code.proj 1)) a ![] + ⟨0, (eval_zero_iff _ _).mpr rfl⟩ ?_ + intro i _ z + have hidx : + Semiformula.Evalb (i :> i :> z :> (![] : Fin 0 → M)) (code (Code.proj (0 : Fin 2))) := + (eval_proj_iff _ _ _).mpr rfl + have htwo : + Semiformula.Evalb ((2 : M) :> i :> z :> (![] : Fin 0 → M)) + (code (codeConst (n := 2) 2)) := + by rw [eval_codeConst_iff]; simp + have hbodd : + Semiformula.Evalb ((i % 2) :> i :> z :> (![] : Fin 0 → M)) + (code (codeBodd (Code.proj (0 : Fin 2)))) := + eval_codeRem _ _ i 2 _ hidx htwo + have hprev : + Semiformula.Evalb (z :> i :> z :> (![] : Fin 0 → M)) (code (Code.proj (1 : Fin 2))) := + (eval_proj_iff _ _ _).mpr rfl + have hsucc : + Semiformula.Evalb ((z + 1) :> i :> z :> (![] : Fin 0 → M)) + (code (codeSucc (Code.proj (1 : Fin 2)))) := + (eval_codeSucc_iff _ _ _).mpr ⟨z, hprev, rfl⟩ + by_cases hpar : 0 < i % 2 + · exact + ⟨z + 1, + eval_codeIfPos_of _ _ _ (i % 2) (z + 1) z (z + 1) _ hbodd hsucc hprev + (Or.inl ⟨hpar, rfl⟩)⟩ + · exact + ⟨z, + eval_codeIfPos_of _ _ _ (i % 2) (z + 1) z z _ hbodd hsucc hprev + (Or.inr ⟨le_antisymm (not_lt.mp hpar) (by simp), rfl⟩)⟩ + refine ⟨w, (eval_comp_iff codeDiv2Unary ![A] w v).mpr ⟨![a], hw, ?_⟩⟩ + intro j + refine Fin.cases ?_ (fun j1 => Fin.elim0 j1) j + simpa using hA + +end Existence + +end ArithmeticCode +end CategoricalRiceShapiro + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/Cell.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/Cell.lean new file mode 100644 index 000000000..2ecfd9c1b --- /dev/null +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/Cell.lean @@ -0,0 +1,118 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.TableLookup +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.PartialRecursive + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# The evaluator-cell code + +One cell of the evaluation table. The table length names the pair `(k, q)`: +`k` is the fuel and `q` the partial-recursive index under evaluation. For +positive fuel the constructor number of `q` selects a branch — `4` pairing, +`5` composition, `6` primitive recursion, `7` minimization — and every other +constructor number falls through to `codeBaseEvaluatorCell`, which decides the +four base constructors. Branches `6` and `7` receive predecessor fuel and the +whole index `q`; branch `7` reads the entire payload rather than its first +component. No comparison of the argument with the fuel occurs. + +The conditional is arithmetic and eager: `codeIfPos` evaluates both branches. +Only the code constructions are given here. The standard computation theorems +over the natural numbers are not part of this migration. +-/ + +@[expose] public section + +open _root_.Nat Nat Nat.ArithPart₁ + +namespace CategoricalRiceShapiro +namespace Evaluator + +open CategoricalRiceShapiro.ArithmeticCode + +/-- The cell for one of the four base constructors. -/ +def codeBaseEvaluatorCell {r : ℕ} (dtable dn : Code r) : Code r := + let dp := codeListLength dtable + let dk := codeUnpair₁ dp + let dq := codeUnpair₂ dp + let dtag := codePartrecTag dq + codeIfPos dk + (codeIfPos (codeEq dtag (codeConst 0)) (codeConst 1) + (codeIfPos (codeEq dtag (codeConst 1)) (codeSucc (codeSucc dn)) + (codeIfPos (codeEq dtag (codeConst 2)) (codeSucc (codeUnpair₁ dn)) + (codeIfPos (codeEq dtag (codeConst 3)) (codeSucc (codeUnpair₂ dn)) (codeConst 0))))) + (codeConst 0) + +/-- The cell for the pairing constructor. -/ +def codePairEvaluatorCell {r : ℕ} (dtable dk dcf dcg dn : Code r) : Code r := + codeOptionBind (codeTableLookup dtable dk dcf dn) + (codeOptionBind + (codeTableLookup (codeLift dtable) (codeLift dk) (codeLift dcg) (codeLift dn)) + (codeSucc (codePair (Code.proj (1 : Fin (r + 2))) (Code.proj (0 : Fin (r + 2)))))) + +/-- The cell for the composition constructor: the inner index `dcg` is applied +to the argument, and the outer index `dcf` to the result. -/ +def codeCompEvaluatorCell {r : ℕ} (dtable dk dcf dcg dn : Code r) : Code r := + codeOptionBind (codeTableLookup dtable dk dcg dn) + (codeTableLookup (codeLift dtable) (codeLift dk) (codeLift dcf) codeHead) + +/-- The cell for the primitive-recursion constructor. -/ +def codePrecEvaluatorCell {r : ℕ} (dtable dk' dq dcf dcg dn : Code r) : Code r := + let dk := codeSucc dk' + let dz := codeUnpair₁ dn + let dt := codeUnpair₂ dn + let dy := codeSub dt (codeConst 1) + codeIfPos dt + (codeOptionBind (codeTableLookup dtable dk' dq (codePair dz dy)) + (codeTableLookup (codeLift dtable) (codeLift dk) (codeLift dcg) + (codePair (codeLift dz) (codePair (codeLift dy) codeHead)))) + (codeTableLookup dtable dk dcf dz) + +/-- The cell for the minimization constructor. -/ +def codeRfindEvaluatorCell {r : ℕ} (dtable dk' dq dcf dn : Code r) : Code r := + let dk := codeSucc dk' + let dz := codeUnpair₁ dn + let dm := codeUnpair₂ dn + codeOptionBind (codeTableLookup dtable dk dcf (codePair dz dm)) + (codeIfPos codeHead + (codeTableLookup (codeLift dtable) (codeLift dk') (codeLift dq) + (codePair (codeLift dz) (codeSucc (codeLift dm)))) + (codeSucc (codeLift dm))) + +/-- One evaluator cell: fuel and index are read from the table length, and the +constructor number of the index selects the branch. -/ +def codeEvaluatorCell {r : ℕ} (dtable dn : Code r) : Code r := + let dp := codeListLength dtable + let dk := codeUnpair₁ dp + let dk' := codeSub dk (codeConst 1) + let dq := codeUnpair₂ dp + let dtag := codePartrecTag dq + let dcf := codePartrecPayload₁ dq + let dcg := codePartrecPayload₂ dq + let drfind := codePartrecPayload dq + codeIfPos dk + (codeIfPos (codeEq dtag (codeConst 4)) (codePairEvaluatorCell dtable dk dcf dcg dn) + (codeIfPos (codeEq dtag (codeConst 5)) (codeCompEvaluatorCell dtable dk dcf dcg dn) + (codeIfPos (codeEq dtag (codeConst 6)) (codePrecEvaluatorCell dtable dk' dq dcf dcg dn) + (codeIfPos (codeEq dtag (codeConst 7)) + (codeRfindEvaluatorCell dtable dk' dq drfind dn) + (codeBaseEvaluatorCell dtable dn))))) + (codeConst 0) + +end Evaluator +end CategoricalRiceShapiro + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/CellCongruence.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/CellCongruence.lean new file mode 100644 index 000000000..3d26837f7 --- /dev/null +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/CellCongruence.lean @@ -0,0 +1,607 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.Cell +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.EvaluationCongruence + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# Heterogeneous congruence for the evaluator cell + +`eval_codeEvaluatorCell_congr_at` compares two evaluator cells written at +different arities and read under different assignments. It is the analogue for +`codeEvaluatorCell` of `eval_codeBeta_congr_at`, and is proved the same way: a +relation saying that two codes have the same graph, each under its own +assignment, is propagated through every constructor the cell is built from. + +Every branch of the eager conditional is treated; none is discarded because its +tag is unused. The derived constructors are delta-reduced as syntax trees only. +No arithmetic meaning is attached to any of them, no totality is asserted, and +the results hold in an arbitrary `ORingStructure`. +-/ + +@[expose] public section + +open _root_.Nat Nat Nat.ArithPart₁ + +namespace CategoricalRiceShapiro +namespace Evaluator + +open CategoricalRiceShapiro.ArithmeticCode + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +variable {M : Type*} [ORingStructure M] + +/-- Two codes have the same graph, each under its own assignment. -/ +private abbrev EvalEq {k l : ℕ} (A : Code k) (v : Fin k → M) (A' : Code l) (v' : Fin l → M) : + Prop := + ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v') (code A') + +/-! +### Primitives -/ + +private theorem evalEq_proj {k l : ℕ} (i : Fin k) (j : Fin l) (v : Fin k → M) (v' : Fin l → M) + (h : v i = v' j) : EvalEq (Code.proj i) v (Code.proj j) v' := by + intro x; + rw [eval_proj_iff, eval_proj_iff, h] + +private theorem evalEq_zero {k l : ℕ} (v : Fin k → M) (v' : Fin l → M) : + EvalEq (Code.zero k) v (Code.zero l) v' := by intro x; rw [eval_zero_iff, eval_zero_iff] + +private theorem evalEq_one {k l : ℕ} (v : Fin k → M) (v' : Fin l → M) : + EvalEq (Code.one k) v (Code.one l) v' := by intro x; rw [eval_one_iff, eval_one_iff] + +private theorem evalEq_codeHead {k l : ℕ} (t : M) (v : Fin k → M) (v' : Fin l → M) : + EvalEq (codeHead (n := k)) (t :> v) (codeHead (n := l)) (t :> v') := + evalEq_proj 0 0 _ _ rfl + +/-- A lift ignores its head, so the two heads need not agree. -/ +private theorem evalEq_codeLift {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} + {v' : Fin l → M} (t t' : M) (hA : EvalEq A v A' v') : + EvalEq (codeLift A) (t :> v) (codeLift A') (t' :> v') := by + intro x; + rw [eval_codeLift_iff, eval_codeLift_iff]; exact hA x + +/-- Composition with a shared outer code. -/ +private theorem evalEq_comp {k l m : ℕ} (c : Code m) (ds : Fin m → Code k) + (ds' : Fin m → Code l) {v : Fin k → M} {v' : Fin l → M} + (h : ∀ i, EvalEq (ds i) v (ds' i) v') : EvalEq (c.comp ds) v (c.comp ds') v' := + by + intro x + rw [eval_comp_iff, eval_comp_iff] + constructor + · rintro ⟨w, hw, hwi⟩; exact ⟨w, hw, fun i => (h i (w i)).mp (hwi i)⟩ + · rintro ⟨w, hw, hwi⟩; exact ⟨w, hw, fun i => (h i (w i)).mpr (hwi i)⟩ + +/-! +### Arithmetic and boolean constructors -/ + +private theorem evalEq_codeSucc {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') : EvalEq (codeSucc A) v (codeSucc A') v' := + by + intro x + rw [eval_codeSucc_iff, eval_codeSucc_iff] + exact exists_congr fun a => and_congr (hA a) Iff.rfl + +private theorem evalEq_codePos {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') : EvalEq (codePos A) v (codePos A') v' := + by + intro x + rw [eval_codePos_iff, eval_codePos_iff] + exact exists_congr fun a => and_congr (hA a) Iff.rfl + +private theorem evalEq_codeInv {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') : EvalEq (codeInv A) v (codeInv A') v' := + by + intro x + rw [eval_codeInv_iff, eval_codeInv_iff] + exact exists_congr fun a => and_congr (hA a) Iff.rfl + +private theorem evalEq_codeAdd {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : + EvalEq (codeAdd A B) v (codeAdd A' B') v' := + by + intro x + rw [eval_codeAdd_iff, eval_codeAdd_iff] + exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) + +private theorem evalEq_codeMul {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : + EvalEq (codeMul A B) v (codeMul A' B') v' := + by + intro x + rw [eval_codeMul_iff, eval_codeMul_iff] + exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) + +private theorem evalEq_codeEq {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : + EvalEq (codeEq A B) v (codeEq A' B') v' := + by + intro x + rw [eval_codeEq_iff, eval_codeEq_iff] + exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) + +private theorem evalEq_codeLt {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : + EvalEq (codeLt A B) v (codeLt A' B') v' := + by + intro x + rw [eval_codeLt_iff, eval_codeLt_iff] + exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) + +private theorem evalEq_codeAnd {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : + EvalEq (codeAnd A B) v (codeAnd A' B') v' := + by + intro x + rw [eval_codeAnd_iff, eval_codeAnd_iff] + exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) + +private theorem evalEq_codeOr {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : + EvalEq (codeOr A B) v (codeOr A' B') v' := + by + intro x + rw [eval_codeOr_iff, eval_codeOr_iff] + exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) + +private theorem evalEq_codeIfPos {k l : ℕ} {A B C : Code k} {A' B' C' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') (hC : EvalEq C v C' v') : + EvalEq (codeIfPos A B C) v (codeIfPos A' B' C') v' := + by + simp only [codeIfPos] + exact + evalEq_codeAdd (evalEq_codeMul (evalEq_codePos hA) hB) + (evalEq_codeMul (evalEq_codeInv hA) hC) + +private theorem evalEq_codeConst {k l : ℕ} (m : ℕ) (v : Fin k → M) (v' : Fin l → M) : + EvalEq (codeConst (n := k) m) v (codeConst (n := l) m) v' := by + induction m with + | zero => exact evalEq_zero v v' + | succ m ih => exact evalEq_codeSucc ih + +/-! +### Minimization contexts -/ + +/-- `code` differs from `codeAux` by a renaming that evaluation absorbs. -/ +private theorem evalb_iff_evalf {k : ℕ} (c : Code k) (z : M) (w : Fin k → M) : + Semiformula.Evalb (z :> w) (code c) ↔ Semiformula.Evalf (M := M) (z :> w) (codeAux c) := by + simp [code, Semiformula.eval_rew, Matrix.empty_eq, Function.comp_def] + +/-- Evaluation of a search for a zero, without an arithmetic theory. -/ +private theorem eval_rfind_iff {k : ℕ} (c : Code (k + 1)) (z : M) (v : Fin k → M) : + Semiformula.Evalb (z :> v) (code (Code.rfind c)) ↔ + (Semiformula.Evalb ((0 : M) :> z :> v) (code c) ∧ + ∀ t : M, t < z → ∃ x : M, x ≠ 0 ∧ Semiformula.Evalb (x :> t :> v) (code c)) := + by + simp only [evalb_iff_evalf] + simp [codeAux, Semiformula.eval_rew, Function.comp_def, Matrix.empty_eq, Matrix.comp_vecCons'] + +private theorem evalEq_rfind {k l : ℕ} {A : Code (k + 1)} {A' : Code (l + 1)} {v : Fin k → M} + {v' : Fin l → M} (hA : ∀ t : M, EvalEq A (t :> v) A' (t :> v')) : + EvalEq (Code.rfind A) v (Code.rfind A') v' := + by + intro x + rw [eval_rfind_iff, eval_rfind_iff] + exact + and_congr (hA x 0) + (forall_congr' fun t => + imp_congr Iff.rfl (exists_congr fun y => and_congr Iff.rfl (hA t y))) + +private theorem evalEq_codeRfindPos {k l : ℕ} {A : Code (k + 1)} {A' : Code (l + 1)} + {v : Fin k → M} {v' : Fin l → M} (hA : ∀ t : M, EvalEq A (t :> v) A' (t :> v')) : + EvalEq (codeRfindPos A) v (codeRfindPos A') v' := + by + simp only [codeRfindPos] + exact evalEq_rfind (fun t => evalEq_codeInv (evalEq_codePos (hA t))) + +private theorem evalEq_codeBind {k l : ℕ} {dg : Code k} {dc : Code (k + 1)} {dg' : Code l} + {dc' : Code (l + 1)} {v : Fin k → M} {v' : Fin l → M} (hg : EvalEq dg v dg' v') + (hc : ∀ t : M, EvalEq dc (t :> v) dc' (t :> v')) : + EvalEq (codeBind dg dc) v (codeBind dg' dc') v' := + by + intro x + rw [eval_codeBind_iff, eval_codeBind_iff] + exact exists_congr fun t => and_congr (hg t) (hc t x) + +/-! +### Derived arithmetic -/ + +private theorem evalEq_codeSub {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : + EvalEq (codeSub A B) v (codeSub A' B') v' := + by + simp only [codeSub] + refine evalEq_codeRfindPos (fun t => ?_) + exact + evalEq_codeOr + (evalEq_codeEq (evalEq_codeAdd (evalEq_codeHead t v v') (evalEq_codeLift t t hB)) + (evalEq_codeLift t t hA)) + (evalEq_codeAnd (evalEq_codeLt (evalEq_codeLift t t hA) (evalEq_codeLift t t hB)) + (evalEq_codeEq (evalEq_codeHead t v v') (evalEq_zero _ _))) + +private theorem evalEq_codeSqrt {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') : EvalEq (codeSqrt A) v (codeSqrt A') v' := + by + simp only [codeSqrt] + refine evalEq_codeRfindPos (fun t => ?_) + exact + evalEq_codeAnd + (evalEq_codeOr + (evalEq_codeLt (evalEq_codeMul (evalEq_codeHead t v v') (evalEq_codeHead t v v')) + (evalEq_codeLift t t hA)) + (evalEq_codeEq (evalEq_codeMul (evalEq_codeHead t v v') (evalEq_codeHead t v v')) + (evalEq_codeLift t t hA))) + (evalEq_codeLt (evalEq_codeLift t t hA) + (evalEq_codeMul (evalEq_codeSucc (evalEq_codeHead t v v')) + (evalEq_codeSucc (evalEq_codeHead t v v')))) + +private theorem evalEq_codeUnpair₁ {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') : EvalEq (codeUnpair₁ A) v (codeUnpair₁ A') v' := + by + simp only [codeUnpair₁] + exact + evalEq_codeIfPos + (evalEq_codeLt + (evalEq_codeSub hA (evalEq_codeMul (evalEq_codeSqrt hA) (evalEq_codeSqrt hA))) + (evalEq_codeSqrt hA)) + (evalEq_codeSub hA (evalEq_codeMul (evalEq_codeSqrt hA) (evalEq_codeSqrt hA))) + (evalEq_codeSqrt hA) + +private theorem evalEq_codeUnpair₂ {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') : EvalEq (codeUnpair₂ A) v (codeUnpair₂ A') v' := + by + simp only [codeUnpair₂] + exact + evalEq_codeIfPos + (evalEq_codeLt + (evalEq_codeSub hA (evalEq_codeMul (evalEq_codeSqrt hA) (evalEq_codeSqrt hA))) + (evalEq_codeSqrt hA)) + (evalEq_codeSqrt hA) + (evalEq_codeSub + (evalEq_codeSub hA (evalEq_codeMul (evalEq_codeSqrt hA) (evalEq_codeSqrt hA))) + (evalEq_codeSqrt hA)) + +private theorem evalEq_codePair {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : + EvalEq (codePair A B) v (codePair A' B') v' := + by + simp only [codePair] + exact + evalEq_codeIfPos (evalEq_codeLt hA hB) (evalEq_codeAdd (evalEq_codeMul hB hB) hA) + (evalEq_codeAdd (evalEq_codeAdd (evalEq_codeMul hA hA) hA) hB) + +private theorem evalEq_codeLe {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : + EvalEq (codeLe A B) v (codeLe A' B') v' := + by + simp only [codeLe] + exact evalEq_codeOr (evalEq_codeLt hA hB) (evalEq_codeEq hA hB) + +private theorem evalEq_codeDvd {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : + EvalEq (codeDvd A B) v (codeDvd A' B') v' := + by + simp only [codeDvd] + refine evalEq_codeBind (evalEq_codeRfindPos (fun t => ?_)) (fun t => ?_) + · exact + evalEq_codeOr + (evalEq_codeEq (evalEq_codeMul (evalEq_codeHead t v v') (evalEq_codeLift t t hA)) + (evalEq_codeLift t t hB)) + (evalEq_codeLt (evalEq_codeLift t t hB) (evalEq_codeHead t v v')) + · exact evalEq_codeLe (evalEq_codeHead t v v') (evalEq_codeLift t t hB) + +private theorem evalEq_codeRem {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : + EvalEq (codeRem A B) v (codeRem A' B') v' := + by + simp only [codeRem] + refine evalEq_codeRfindPos (fun t => ?_) + exact + evalEq_codeDvd (evalEq_codeLift t t hB) + (evalEq_codeSub (evalEq_codeLift t t hA) (evalEq_codeHead t v v')) + +/-! +### The partial-recursive index layer -/ + +private theorem evalEq_codeBodd {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') : EvalEq (codeBodd A) v (codeBodd A') v' := + by + simp only [codeBodd] + exact evalEq_codeRem hA (evalEq_codeConst 2 v v') + +private theorem evalEq_codeDiv2 {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') : EvalEq (codeDiv2 A) v (codeDiv2 A') v' := + by + simp only [codeDiv2] + refine evalEq_comp _ _ _ (fun i => ?_) + refine Fin.cases ?_ (fun j => Fin.elim0 j) i + simpa using hA + +private theorem evalEq_codePartrecTag {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') : + EvalEq (codePartrecTag A) v (codePartrecTag A') v' := + by + simp only [codePartrecTag] + exact + evalEq_codeIfPos (evalEq_codeLt hA (evalEq_codeConst 4 v v')) hA + (evalEq_codeAdd + (evalEq_codeAdd (evalEq_codeConst 4 v v') + (evalEq_codeMul (evalEq_codeConst 2 v v') + (evalEq_codeBodd (evalEq_codeSub hA (evalEq_codeConst 4 v v'))))) + (evalEq_codeBodd (evalEq_codeDiv2 (evalEq_codeSub hA (evalEq_codeConst 4 v v'))))) + +private theorem evalEq_codePartrecPayload {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') : + EvalEq (codePartrecPayload A) v (codePartrecPayload A') v' := + by + simp only [codePartrecPayload] + exact evalEq_codeDiv2 (evalEq_codeDiv2 (evalEq_codeSub hA (evalEq_codeConst 4 v v'))) + +private theorem evalEq_codePartrecPayload₁ {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') : + EvalEq (codePartrecPayload₁ A) v (codePartrecPayload₁ A') v' := + by + simp only [codePartrecPayload₁] + exact evalEq_codeUnpair₁ (evalEq_codePartrecPayload hA) + +private theorem evalEq_codePartrecPayload₂ {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') : + EvalEq (codePartrecPayload₂ A) v (codePartrecPayload₂ A') v' := + by + simp only [codePartrecPayload₂] + exact evalEq_codeUnpair₂ (evalEq_codePartrecPayload hA) + +/-! +### The encoded-list layer -/ + +private theorem evalEq_codeListDrop {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : + EvalEq (codeListDrop A B) v (codeListDrop A' B') v' := + by + rw [codeListDrop_eq_comp, codeListDrop_eq_comp] + refine evalEq_comp _ _ _ (fun i => ?_) + refine Fin.cases ?_ ?_ i + · simpa using hB + · intro j + refine Fin.cases ?_ (fun j' => Fin.elim0 j') j + simpa using hA + +private theorem evalEq_codeListHeadOptional {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') : + EvalEq (codeListHeadOptional A) v (codeListHeadOptional A') v' := + by + simp only [codeListHeadOptional] + exact + evalEq_codeIfPos hA + (evalEq_codeSucc (evalEq_codeUnpair₁ (evalEq_codeSub hA (evalEq_codeConst 1 v v')))) + (evalEq_zero v v') + +private theorem evalEq_codeListTail {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') : EvalEq (codeListTail A) v (codeListTail A') v' := + by + simp only [codeListTail] + exact evalEq_codeUnpair₂ (evalEq_codeSub hA (evalEq_codeConst 1 v v')) + +private theorem evalEq_codeListGetOptional {k l : ℕ} {A B : Code k} {A' B' : Code l} + {v : Fin k → M} {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : + EvalEq (codeListGetOptional A B) v (codeListGetOptional A' B') v' := + by + simp only [codeListGetOptional] + exact evalEq_codeListHeadOptional (evalEq_codeListDrop hA hB) + +private theorem evalEq_codeListLength {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') : + EvalEq (codeListLength A) v (codeListLength A') v' := + by + simp only [codeListLength] + refine evalEq_codeRfindPos (fun t => ?_) + exact evalEq_codeInv (evalEq_codeListDrop (evalEq_codeLift t t hA) (evalEq_codeHead t v v')) + +private theorem evalEq_codeOptionBind {k l : ℕ} {A : Code k} {B : Code (k + 1)} {A' : Code l} + {B' : Code (l + 1)} {v : Fin k → M} {v' : Fin l → M} (hA : EvalEq A v A' v') + (hB : ∀ t : M, EvalEq B (t :> v) B' (t :> v')) : + EvalEq (codeOptionBind A B) v (codeOptionBind A' B') v' := + by + simp only [codeOptionBind] + exact + evalEq_codeIfPos hA (evalEq_codeBind (evalEq_codeSub hA (evalEq_one v v')) hB) + (evalEq_zero v v') + +private theorem evalEq_codeTableLookup {k l : ℕ} {A B C D : Code k} {A' B' C' D' : Code l} + {v : Fin k → M} {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') + (hC : EvalEq C v C' v') (hD : EvalEq D v D' v') : + EvalEq (codeTableLookup A B C D) v (codeTableLookup A' B' C' D') v' := + by + rw [codeTableLookup_eq, codeTableLookup_eq] + exact + evalEq_codeSub + (evalEq_codeListGetOptional + (evalEq_codeSub (evalEq_codeListGetOptional hA (evalEq_codePair hB hC)) + (evalEq_codeConst 1 v v')) + hD) + (evalEq_codeConst 1 v v') + +/-- Two encoded-list lengths agree whenever their list codes do, even at +different arities and under different assignments. -/ +theorem eval_codeListLength_congr_at {k l : ℕ} (A : Code k) (A' : Code l) (z : M) + (v : Fin k → M) (v' : Fin l → M) + (hA : + ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v') (code A')) : + Semiformula.Evalb (z :> v) (code (codeListLength A)) ↔ + Semiformula.Evalb (z :> v') (code (codeListLength A')) := + evalEq_codeListLength hA z + +/-- Two first Cantor components agree whenever their argument codes do, even at +different arities and under different assignments. -/ +theorem eval_codeUnpair₁_congr_at {k l : ℕ} (A : Code k) (A' : Code l) (z : M) (v : Fin k → M) + (v' : Fin l → M) + (hA : + ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v') (code A')) : + Semiformula.Evalb (z :> v) (code (codeUnpair₁ A)) ↔ + Semiformula.Evalb (z :> v') (code (codeUnpair₁ A')) := + evalEq_codeUnpair₁ hA z + +/-- Two table lookups agree whenever their four argument codes do, even at +different arities and under different assignments. + +This is the public form of the private closure above; the chain is not +duplicated. -/ +theorem eval_codeTableLookup_congr_at {k l : ℕ} (dtable dk dq dn : Code k) + (dtable' dk' dq' dn' : Code l) (z : M) (v : Fin k → M) (v' : Fin l → M) + (hT : + ∀ x : M, + Semiformula.Evalb (x :> v) (code dtable) ↔ Semiformula.Evalb (x :> v') (code dtable')) + (hK : + ∀ x : M, Semiformula.Evalb (x :> v) (code dk) ↔ Semiformula.Evalb (x :> v') (code dk')) + (hQ : + ∀ x : M, Semiformula.Evalb (x :> v) (code dq) ↔ Semiformula.Evalb (x :> v') (code dq')) + (hN : + ∀ x : M, Semiformula.Evalb (x :> v) (code dn) ↔ Semiformula.Evalb (x :> v') (code dn')) : + Semiformula.Evalb (z :> v) (code (codeTableLookup dtable dk dq dn)) ↔ + Semiformula.Evalb (z :> v') (code (codeTableLookup dtable' dk' dq' dn')) := + evalEq_codeTableLookup hT hK hQ hN z + +/-! +### The evaluator-cell branches -/ + +private theorem evalEq_codeBaseEvaluatorCell {k l : ℕ} {T N : Code k} {T' N' : Code l} + {v : Fin k → M} {v' : Fin l → M} (hT : EvalEq T v T' v') (hN : EvalEq N v N' v') : + EvalEq (codeBaseEvaluatorCell T N) v (codeBaseEvaluatorCell T' N') v' := + by + simp only [codeBaseEvaluatorCell] + have hp := evalEq_codeListLength hT + have htag := evalEq_codePartrecTag (evalEq_codeUnpair₂ hp) + exact + evalEq_codeIfPos (evalEq_codeUnpair₁ hp) + (evalEq_codeIfPos (evalEq_codeEq htag (evalEq_codeConst 0 v v')) (evalEq_codeConst 1 v v') + (evalEq_codeIfPos (evalEq_codeEq htag (evalEq_codeConst 1 v v')) + (evalEq_codeSucc (evalEq_codeSucc hN)) + (evalEq_codeIfPos (evalEq_codeEq htag (evalEq_codeConst 2 v v')) + (evalEq_codeSucc (evalEq_codeUnpair₁ hN)) + (evalEq_codeIfPos (evalEq_codeEq htag (evalEq_codeConst 3 v v')) + (evalEq_codeSucc (evalEq_codeUnpair₂ hN)) (evalEq_codeConst 0 v v'))))) + (evalEq_codeConst 0 v v') + +private theorem evalEq_codePairEvaluatorCell {k l : ℕ} {T K F G N : Code k} + {T' K' F' G' N' : Code l} {v : Fin k → M} {v' : Fin l → M} (hT : EvalEq T v T' v') + (hK : EvalEq K v K' v') (hF : EvalEq F v F' v') (hG : EvalEq G v G' v') + (hN : EvalEq N v N' v') : + EvalEq (codePairEvaluatorCell T K F G N) v (codePairEvaluatorCell T' K' F' G' N') v' := + by + simp only [codePairEvaluatorCell] + refine evalEq_codeOptionBind (evalEq_codeTableLookup hT hK hF hN) (fun t => ?_) + refine + evalEq_codeOptionBind + (evalEq_codeTableLookup (evalEq_codeLift t t hT) (evalEq_codeLift t t hK) + (evalEq_codeLift t t hG) (evalEq_codeLift t t hN)) + (fun u => ?_) + exact evalEq_codeSucc (evalEq_codePair (evalEq_proj 1 1 _ _ rfl) (evalEq_proj 0 0 _ _ rfl)) + +private theorem evalEq_codeCompEvaluatorCell {k l : ℕ} {T K F G N : Code k} + {T' K' F' G' N' : Code l} {v : Fin k → M} {v' : Fin l → M} (hT : EvalEq T v T' v') + (hK : EvalEq K v K' v') (hF : EvalEq F v F' v') (hG : EvalEq G v G' v') + (hN : EvalEq N v N' v') : + EvalEq (codeCompEvaluatorCell T K F G N) v (codeCompEvaluatorCell T' K' F' G' N') v' := + by + simp only [codeCompEvaluatorCell] + refine evalEq_codeOptionBind (evalEq_codeTableLookup hT hK hG hN) (fun t => ?_) + exact + evalEq_codeTableLookup (evalEq_codeLift t t hT) (evalEq_codeLift t t hK) + (evalEq_codeLift t t hF) (evalEq_codeHead t v v') + +private theorem evalEq_codePrecEvaluatorCell {k l : ℕ} {T K Q F G N : Code k} + {T' K' Q' F' G' N' : Code l} {v : Fin k → M} {v' : Fin l → M} (hT : EvalEq T v T' v') + (hK : EvalEq K v K' v') (hQ : EvalEq Q v Q' v') (hF : EvalEq F v F' v') + (hG : EvalEq G v G' v') (hN : EvalEq N v N' v') : + EvalEq (codePrecEvaluatorCell T K Q F G N) v (codePrecEvaluatorCell T' K' Q' F' G' N') v' := + by + simp only [codePrecEvaluatorCell] + have hz := evalEq_codeUnpair₁ hN + have ht := evalEq_codeUnpair₂ hN + have hy := evalEq_codeSub ht (evalEq_codeConst 1 v v') + refine evalEq_codeIfPos ht ?_ (evalEq_codeTableLookup hT (evalEq_codeSucc hK) hF hz) + refine + evalEq_codeOptionBind (evalEq_codeTableLookup hT hK hQ (evalEq_codePair hz hy)) + (fun t => ?_) + exact + evalEq_codeTableLookup (evalEq_codeLift t t hT) (evalEq_codeLift t t (evalEq_codeSucc hK)) + (evalEq_codeLift t t hG) + (evalEq_codePair (evalEq_codeLift t t hz) + (evalEq_codePair (evalEq_codeLift t t hy) (evalEq_codeHead t v v'))) + +private theorem evalEq_codeRfindEvaluatorCell {k l : ℕ} {T K Q F N : Code k} + {T' K' Q' F' N' : Code l} {v : Fin k → M} {v' : Fin l → M} (hT : EvalEq T v T' v') + (hK : EvalEq K v K' v') (hQ : EvalEq Q v Q' v') (hF : EvalEq F v F' v') + (hN : EvalEq N v N' v') : + EvalEq (codeRfindEvaluatorCell T K Q F N) v (codeRfindEvaluatorCell T' K' Q' F' N') v' := + by + simp only [codeRfindEvaluatorCell] + have hz := evalEq_codeUnpair₁ hN + have hm := evalEq_codeUnpair₂ hN + refine + evalEq_codeOptionBind + (evalEq_codeTableLookup hT (evalEq_codeSucc hK) hF (evalEq_codePair hz hm)) (fun t => ?_) + exact + evalEq_codeIfPos (evalEq_codeHead t v v') + (evalEq_codeTableLookup (evalEq_codeLift t t hT) (evalEq_codeLift t t hK) + (evalEq_codeLift t t hQ) + (evalEq_codePair (evalEq_codeLift t t hz) (evalEq_codeSucc (evalEq_codeLift t t hm)))) + (evalEq_codeSucc (evalEq_codeLift t t hm)) + +/-- Two evaluator cells agree whenever their table and index codes do, even at +different arities and under different assignments. + +Every branch of the eager conditional is compared; none is discarded. -/ +theorem eval_codeEvaluatorCell_congr_at {k l : ℕ} (dtable dn : Code k) (dtable' dn' : Code l) + (z : M) (v : Fin k → M) (v' : Fin l → M) + (hT : + ∀ x : M, + Semiformula.Evalb (x :> v) (code dtable) ↔ Semiformula.Evalb (x :> v') (code dtable')) + (hN : + ∀ x : M, Semiformula.Evalb (x :> v) (code dn) ↔ Semiformula.Evalb (x :> v') (code dn')) : + Semiformula.Evalb (z :> v) (code (codeEvaluatorCell dtable dn)) ↔ + Semiformula.Evalb (z :> v') (code (codeEvaluatorCell dtable' dn')) := + by + have hcell : EvalEq (codeEvaluatorCell dtable dn) v (codeEvaluatorCell dtable' dn') v' := + by + simp only [codeEvaluatorCell] + have hp := evalEq_codeListLength hT + have hk := evalEq_codeUnpair₁ hp + have hk' := evalEq_codeSub hk (evalEq_codeConst 1 v v') + have hq := evalEq_codeUnpair₂ hp + have htag := evalEq_codePartrecTag hq + exact + evalEq_codeIfPos hk + (evalEq_codeIfPos (evalEq_codeEq htag (evalEq_codeConst 4 v v')) + (evalEq_codePairEvaluatorCell hT hk (evalEq_codePartrecPayload₁ hq) + (evalEq_codePartrecPayload₂ hq) hN) + (evalEq_codeIfPos (evalEq_codeEq htag (evalEq_codeConst 5 v v')) + (evalEq_codeCompEvaluatorCell hT hk (evalEq_codePartrecPayload₁ hq) + (evalEq_codePartrecPayload₂ hq) hN) + (evalEq_codeIfPos (evalEq_codeEq htag (evalEq_codeConst 6 v v')) + (evalEq_codePrecEvaluatorCell hT hk' hq (evalEq_codePartrecPayload₁ hq) + (evalEq_codePartrecPayload₂ hq) hN) + (evalEq_codeIfPos (evalEq_codeEq htag (evalEq_codeConst 7 v v')) + (evalEq_codeRfindEvaluatorCell hT hk' hq (evalEq_codePartrecPayload hq) hN) + (evalEq_codeBaseEvaluatorCell hT hN))))) + (evalEq_codeConst 0 v v') + exact hcell z + +end Evaluator +end CategoricalRiceShapiro + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/CellEvaluation.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/CellEvaluation.lean new file mode 100644 index 000000000..2fd02987b --- /dev/null +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/CellEvaluation.lean @@ -0,0 +1,508 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.Cell +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.NumeralEvaluation +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.PartialRecursiveEvaluation +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.TableLookupEvaluation + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# Success and totality of an evaluator cell + +This module states two kinds of result, with different assumptions. + +The success theorems describe a cell that has already reported a positive +value: the encoded `Option` is `x + 1` when the computation returned `x`. +`eval_codeOptionBind_succ_iff` and `eval_codeCompEvaluatorCell_succ_iff` use +`𝐏𝐀⁻`. `eval_codePairEvaluatorCell_succ_iff` characterises the two successful +lookups and their Cantor-pair result over `𝐈𝐎𝐩𝐞𝐧`; its proof uses the public +`eval_codePair` API at that fragment. None asserts that a cell has a value at +all. + +Over `𝐏𝐀`, `eval_codeEvaluatorCell_exists_of_values` asserts exactly that: from +values for the table and the argument alone, the whole cell has a value. The +cell is a nested eager conditional, so the proof evaluates all five branches — +base, pairing, composition, primitive recursion and minimization — together with +every lookup and every option continuation inside them, whichever branch the tag +comparisons end up selecting. It asserts existence only and identifies no +value. +-/ + +@[expose] public section + +open _root_.Nat Nat Nat.ArithPart₁ + +namespace CategoricalRiceShapiro +namespace Evaluator + +open CategoricalRiceShapiro.ArithmeticCode + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +open scoped FFL.FirstOrder.Arithmetic + +variable {M : Type*} [ORingStructure M] + +/-- A successful bind on an encoded option: the bound code succeeds with some +value, and the body succeeds at that value. -/ +theorem eval_codeOptionBind_succ_iff [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {n : ℕ} (dopt : Code n) + (dk : Code (n + 1)) (y : M) (v : Fin n → M) : + Semiformula.Evalb ((y + 1) :> v) (code (codeOptionBind dopt dk)) ↔ + ∃ x : M, + Semiformula.Evalb ((x + 1) :> v) (code dopt) ∧ + Semiformula.Evalb ((y + 1) :> x :> v) (code dk) := + by + have hposS : ∀ a : M, (0 : M) < a + 1 := fun a => + lt_of_lt_of_le _root_.zero_lt_one le_add_self + have hsubC : + ∀ a : M, + Semiformula.Evalb ((a + 1) :> v) (code dopt) → + Semiformula.Evalb (a :> v) (code (codeSub dopt (Code.one n))) := + by + intro a hdopt + simp only [codeSub] + rw [eval_codeRfindPos_iff] + have hLiftD : ∀ t : M, Semiformula.Evalb ((a + 1) :> t :> v) (code (codeLift dopt)) := + fun t => (eval_codeLift_iff dopt (a + 1) t v).mpr hdopt + have hLiftOne : + ∀ t : M, Semiformula.Evalb ((1 : M) :> t :> v) (code (codeLift (Code.one n))) := fun t => + (eval_codeLift_iff _ 1 t v).mpr ((eval_one_iff 1 v).mpr rfl) + have hHeadv : ∀ t : M, Semiformula.Evalb (t :> t :> v) (code (codeHead (n := n))) := + fun t => (eval_codeHead_iff t (t :> v)).mpr rfl + have hSum : + ∀ t : M, + Semiformula.Evalb ((t + 1) :> t :> v) + (code (codeAdd (codeHead (n := n)) (codeLift (Code.one n)))) := + fun t => (eval_codeAdd_iff _ _ (t + 1) (t :> v)).mpr ⟨t, 1, hHeadv t, hLiftOne t, rfl⟩ + have hNotLtOne : ¬(a + 1 < (1 : M)) := not_lt.mpr le_add_self + have hLtPart : + ∀ t : M, + Semiformula.Evalb ((0 : M) :> t :> v) + (code (codeLt (codeLift dopt) (codeLift (Code.one n)))) := + fun t => + (eval_codeLt_iff _ _ 0 (t :> v)).mpr + ⟨a + 1, 1, hLiftD t, hLiftOne t, Or.inr ⟨hNotLtOne, rfl⟩⟩ + have hBPart : + ∀ t : M, + Semiformula.Evalb ((0 : M) :> t :> v) + (code + (codeAnd (codeLt (codeLift dopt) (codeLift (Code.one n))) + (codeEq (codeHead (n := n)) (Code.zero (n + 1))))) := + by + intro t + by_cases ht : t = (0 : M) + · exact + (eval_codeAnd_iff _ _ 0 (t :> v)).mpr + ⟨0, 1, hLtPart t, + (eval_codeEq_iff _ _ 1 (t :> v)).mpr + ⟨t, 0, hHeadv t, (eval_zero_iff 0 (t :> v)).mpr rfl, Or.inl ⟨ht, rfl⟩⟩, + Or.inr ⟨by simp, rfl⟩⟩ + · exact + (eval_codeAnd_iff _ _ 0 (t :> v)).mpr + ⟨0, 0, hLtPart t, + (eval_codeEq_iff _ _ 0 (t :> v)).mpr + ⟨t, 0, hHeadv t, (eval_zero_iff 0 (t :> v)).mpr rfl, Or.inr ⟨ht, rfl⟩⟩, + Or.inr ⟨by simp, rfl⟩⟩ + have hAPart : + ∀ (t w : M), + ((t + 1 = a + 1 ∧ w = 1) ∨ (¬t + 1 = a + 1 ∧ w = 0)) → + Semiformula.Evalb (w :> t :> v) + (code + (codeEq (codeAdd (codeHead (n := n)) (codeLift (Code.one n))) (codeLift dopt))) := + fun t w hcase => + (eval_codeEq_iff _ _ w (t :> v)).mpr ⟨t + 1, a + 1, hSum t, hLiftD t, hcase⟩ + constructor + · exact + ⟨1, by simp, + (eval_codeOr_iff _ _ 1 (a :> v)).mpr + ⟨1, 0, hAPart a 1 (Or.inl ⟨rfl, rfl⟩), hBPart a, Or.inl ⟨by simp, rfl⟩⟩⟩ + · intro t ht + have hne : ¬t + 1 = a + 1 := fun h => absurd (add_right_cancel h) (ne_of_lt ht) + exact + (eval_codeOr_iff _ _ 0 (t :> v)).mpr + ⟨0, 0, hAPart t 0 (Or.inr ⟨hne, rfl⟩), hBPart t, Or.inr ⟨by simp, rfl⟩⟩ + constructor + · intro hb + rw [codeOptionBind, codeIfPos, eval_codeAdd_iff] at hb + obtain ⟨p, q, hp, hq, hsum⟩ := hb + rw [eval_codeMul_iff] at hp + obtain ⟨pp, gg, hpp, hgg, hpv⟩ := hp + rw [eval_codeMul_iff] at hq + obtain ⟨ii, hh, hii, hhh, hqv⟩ := hq + have hhh0 : hh = 0 := (eval_zero_iff hh v).mp hhh + have hq0 : q = 0 := by rw [hqv, hhh0, mul_zero] + rw [eval_codePos_iff] at hpp + obtain ⟨a, ha, hcase⟩ := hpp + rcases hcase with ⟨hpos, hpp1⟩ | ⟨-, hpp0⟩ + · have hy : y + 1 = gg := by rw [hsum, hq0, add_zero, hpv, hpp1, one_mul] + rw [← hy, eval_codeBind_iff] at hgg + obtain ⟨x, hx, hdk⟩ := hgg + obtain ⟨x', hax⟩ := FFL.FirstOrder.Arithmetic.eq_succ_of_pos hpos + rw [hax] at ha + have hxx : x = x' := eval_unique hx (hsubC x' ha) + rw [hxx] at hdk + exact ⟨x', ha, hdk⟩ + · exfalso + have hz : y + 1 = 0 := by rw [hsum, hq0, add_zero, hpv, hpp0, zero_mul] + exact absurd hz (ne_of_gt (hposS y)) + · rintro ⟨x, hdopt, hdk⟩ + rw [codeOptionBind, codeIfPos, eval_codeAdd_iff] + refine ⟨y + 1, 0, ?_, ?_, by simp⟩ + · rw [eval_codeMul_iff] + refine ⟨1, y + 1, ?_, ?_, by simp⟩ + · exact (eval_codePos_iff _ 1 v).mpr ⟨x + 1, hdopt, Or.inl ⟨hposS x, rfl⟩⟩ + · rw [eval_codeBind_iff] + exact ⟨x, hsubC x hdopt, hdk⟩ + · rw [eval_codeMul_iff] + refine ⟨0, 0, ?_, (eval_zero_iff 0 v).mpr rfl, by simp⟩ + exact (eval_codeInv_iff _ 0 v).mpr ⟨x + 1, hdopt, Or.inr ⟨ne_of_gt (hposS x), rfl⟩⟩ + +/-- Success of the pairing branch: the first index succeeds on the argument, the +second index succeeds on the same argument, and the cell reports the Cantor pair +of the two results. -/ +theorem eval_codePairEvaluatorCell_succ_iff [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] {r : ℕ} + (dtable dk dcf dcg dn : Code r) (y : M) (v : Fin r → M) : + Semiformula.Evalb ((y + 1) :> v) (code (codePairEvaluatorCell dtable dk dcf dcg dn)) ↔ + ∃ a b : M, + Semiformula.Evalb ((a + 1) :> v) (code (codeTableLookup dtable dk dcf dn)) ∧ + Semiformula.Evalb ((b + 1) :> a :> v) + (code + (codeTableLookup (codeLift dtable) (codeLift dk) (codeLift dcg) + (codeLift dn))) ∧ + y = FFL.FirstOrder.Arithmetic.pair a b := + by + rw [codePairEvaluatorCell, eval_codeOptionBind_succ_iff] + constructor + · rintro ⟨a, ha, hbody⟩ + rw [eval_codeOptionBind_succ_iff] at hbody + obtain ⟨b, hb, hsucc⟩ := hbody + rw [eval_codeSucc_iff] at hsucc + obtain ⟨p, hp, hyp⟩ := hsucc + refine ⟨a, b, ha, hb, ?_⟩ + have hpa : Semiformula.Evalb (a :> (b :> a :> v)) (code (Code.proj (1 : Fin (r + 2)))) := + (eval_proj_iff (1 : Fin (r + 2)) a (b :> a :> v)).mpr (by simp) + have hpb : Semiformula.Evalb (b :> (b :> a :> v)) (code (Code.proj (0 : Fin (r + 2)))) := + (eval_proj_iff (0 : Fin (r + 2)) b (b :> a :> v)).mpr (by simp) + have hpair := + eval_codePair (M := M) (Code.proj (1 : Fin (r + 2))) (Code.proj (0 : Fin (r + 2))) a b + (b :> a :> v) hpa hpb + have hpeq : p = FFL.FirstOrder.Arithmetic.pair a b := eval_unique hp hpair + exact add_right_cancel (hyp.trans (by rw [hpeq])) + · rintro ⟨a, b, ha, hb, hy⟩ + refine ⟨a, ha, ?_⟩ + rw [eval_codeOptionBind_succ_iff] + refine ⟨b, hb, ?_⟩ + rw [eval_codeSucc_iff] + have hpa : Semiformula.Evalb (a :> (b :> a :> v)) (code (Code.proj (1 : Fin (r + 2)))) := + (eval_proj_iff (1 : Fin (r + 2)) a (b :> a :> v)).mpr (by simp) + have hpb : Semiformula.Evalb (b :> (b :> a :> v)) (code (Code.proj (0 : Fin (r + 2)))) := + (eval_proj_iff (0 : Fin (r + 2)) b (b :> a :> v)).mpr (by simp) + exact + ⟨FFL.FirstOrder.Arithmetic.pair a b, eval_codePair (M := M) _ _ a b (b :> a :> v) hpa hpb, + by rw [hy]⟩ + +/-- Success of the composition branch: the inner index succeeds on the argument, +and the outer index succeeds on that intermediate value. -/ +theorem eval_codeCompEvaluatorCell_succ_iff [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} + (dtable dk dcf dcg dn : Code r) (y : M) (v : Fin r → M) : + Semiformula.Evalb ((y + 1) :> v) (code (codeCompEvaluatorCell dtable dk dcf dcg dn)) ↔ + ∃ x : M, + Semiformula.Evalb ((x + 1) :> v) (code (codeTableLookup dtable dk dcg dn)) ∧ + Semiformula.Evalb ((y + 1) :> x :> v) + (code + (codeTableLookup (codeLift dtable) (codeLift dk) (codeLift dcf) + (codeHead (n := r)))) := + by + simpa only [codeCompEvaluatorCell] using + eval_codeOptionBind_succ_iff (M := M) (dopt := codeTableLookup dtable dk dcg dn) (dk := + codeTableLookup (codeLift dtable) (codeLift dk) (codeLift dcf) (codeHead (n := r))) y v + +/-! +### Totality of an evaluator cell -/ + +/-- The eager conditional has a value once its test and both of its branches +have one. Both branches are evaluated whichever way the test goes. -/ +private theorem eval_codeIfPos_exists [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {n : ℕ} (df dg dh : Code n) + (v : Fin n → M) (hf : ∃ f : M, Semiformula.Evalb (f :> v) (code df)) + (hg : ∃ g : M, Semiformula.Evalb (g :> v) (code dg)) + (hh : ∃ h : M, Semiformula.Evalb (h :> v) (code dh)) : + ∃ z : M, Semiformula.Evalb (z :> v) (code (codeIfPos df dg dh)) := + by + obtain ⟨f, hf⟩ := hf + obtain ⟨g, hg⟩ := hg + obtain ⟨h, hh⟩ := hh + by_cases hpos : 0 < f + · exact ⟨g, eval_codeIfPos_of _ _ _ f g h g v hf hg hh (Or.inl ⟨hpos, rfl⟩)⟩ + · exact + ⟨h, + eval_codeIfPos_of _ _ _ f g h h v hf hg hh + (Or.inr ⟨le_antisymm (not_lt.mp hpos) (by simp), rfl⟩)⟩ + +/-- The characteristic value of an equality exists once both sides have one. -/ +private theorem eval_codeEq_exists [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {n : ℕ} (A B : Code n) (a b : M) + (v : Fin n → M) (hA : Semiformula.Evalb (a :> v) (code A)) + (hB : Semiformula.Evalb (b :> v) (code B)) : + ∃ z : M, Semiformula.Evalb (z :> v) (code (codeEq A B)) := + by + by_cases hab : a = b + · exact ⟨1, (eval_codeEq_iff _ _ _ _).mpr ⟨a, b, hA, hB, Or.inl ⟨hab, rfl⟩⟩⟩ + · exact ⟨0, (eval_codeEq_iff _ _ _ _).mpr ⟨a, b, hA, hB, Or.inr ⟨hab, rfl⟩⟩⟩ + +/-- The base-constructor cell has a value at any table and argument values. + +Every arm of the nested eager conditional is evaluated: the four successor +readings of the argument and the two constants, together with the four tag +comparisons. -/ +private theorem eval_codeBaseEvaluatorCell_exists [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] {r : ℕ} (dtable dn : Code r) + (table index : M) (v : Fin r → M) (htable : Semiformula.Evalb (table :> v) (code dtable)) + (hindex : Semiformula.Evalb (index :> v) (code dn)) : + ∃ z : M, Semiformula.Evalb (z :> v) (code (codeBaseEvaluatorCell dtable dn)) := + by + let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + obtain ⟨p, hp⟩ := eval_codeListLength_exists_of_value dtable table v htable + have hk := eval_codeUnpair₁ (codeListLength dtable) p v hp + have hq := eval_codeUnpair₂ (codeListLength dtable) p v hp + obtain ⟨tg, htag⟩ := + eval_codePartrecTag_exists_of_value (codeUnpair₂ (codeListLength dtable)) _ v hq + have hsucc2 : Semiformula.Evalb ((index + 1 + 1) :> v) (code (codeSucc (codeSucc dn))) := + (eval_codeSucc_iff _ _ _).mpr + ⟨index + 1, (eval_codeSucc_iff _ _ _).mpr ⟨index, hindex, rfl⟩, rfl⟩ + have hsuccu1 : + Semiformula.Evalb ((FFL.FirstOrder.Arithmetic.pi₁ index + 1) :> v) + (code (codeSucc (codeUnpair₁ dn))) := + (eval_codeSucc_iff _ _ _).mpr ⟨_, eval_codeUnpair₁ dn index v hindex, rfl⟩ + have hsuccu2 : + Semiformula.Evalb ((FFL.FirstOrder.Arithmetic.pi₂ index + 1) :> v) + (code (codeSucc (codeUnpair₂ dn))) := + (eval_codeSucc_iff _ _ _).mpr ⟨_, eval_codeUnpair₂ dn index v hindex, rfl⟩ + have hcmp : + ∀ m : ℕ, + ∃ z : M, + Semiformula.Evalb (z :> v) + (code + (codeEq (codePartrecTag (codeUnpair₂ (codeListLength dtable))) + (codeConst (n := r) m))) := + fun m => eval_codeEq_exists _ _ tg _ v htag (eval_codeConst m v) + refine eval_codeIfPos_exists _ _ _ v ⟨_, hk⟩ ?_ ⟨_, eval_codeConst 0 v⟩ + refine eval_codeIfPos_exists _ _ _ v (hcmp 0) ⟨_, eval_codeConst 1 v⟩ ?_ + refine eval_codeIfPos_exists _ _ _ v (hcmp 1) ⟨_, hsucc2⟩ ?_ + refine eval_codeIfPos_exists _ _ _ v (hcmp 2) ⟨_, hsuccu1⟩ ?_ + exact eval_codeIfPos_exists _ _ _ v (hcmp 3) ⟨_, hsuccu2⟩ ⟨_, eval_codeConst 0 v⟩ + +/-- The pairing cell has a value: the two lookups have values, and the +continuation pairs the two payloads. The inner bind is constructed at the +payload of the outer one, so both option layers are supplied. -/ +private theorem eval_codePairEvaluatorCell_exists [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] {r : ℕ} + (dtable dk dcf dcg dn : Code r) (table kv cf cg index : M) (v : Fin r → M) + (htable : Semiformula.Evalb (table :> v) (code dtable)) + (hk : Semiformula.Evalb (kv :> v) (code dk)) (hcf : Semiformula.Evalb (cf :> v) (code dcf)) + (hcg : Semiformula.Evalb (cg :> v) (code dcg)) + (hn : Semiformula.Evalb (index :> v) (code dn)) : + ∃ z : M, Semiformula.Evalb (z :> v) (code (codePairEvaluatorCell dtable dk dcf dcg dn)) := + by + let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + obtain ⟨o₁, ho₁⟩ := + eval_codeTableLookup_exists_of_values dtable dk dcf dn table kv cf index v htable hk hcf hn + refine eval_codeOptionBind_exists_of_value _ _ o₁ v ho₁ ?_ + have hL : + ∀ (X : Code r) (x : M), + Semiformula.Evalb (x :> v) (code X) → + Semiformula.Evalb (x :> (o₁ - 1) :> v) (code (codeLift X)) := + fun X x hx => (eval_codeLift_iff X x (o₁ - 1) v).mpr hx + obtain ⟨o₂, ho₂⟩ := + eval_codeTableLookup_exists_of_values (codeLift dtable) (codeLift dk) (codeLift dcg) + (codeLift dn) table kv cg index ((o₁ - 1) :> v) (hL _ _ htable) (hL _ _ hk) (hL _ _ hcg) + (hL _ _ hn) + refine eval_codeOptionBind_exists_of_value _ _ o₂ ((o₁ - 1) :> v) ho₂ ?_ + exact + ⟨_, + (eval_codeSucc_iff _ _ _).mpr + ⟨_, + eval_codePair (Code.proj (1 : Fin (r + 2))) (Code.proj (0 : Fin (r + 2))) (o₁ - 1) + (o₂ - 1) ((o₂ - 1) :> (o₁ - 1) :> v) ((eval_proj_iff _ _ _).mpr (by simp)) + ((eval_proj_iff _ _ _).mpr rfl), + rfl⟩⟩ + +/-- The composition cell has a value: the inner lookup has one, and the outer +lookup is constructed at its payload. -/ +private theorem eval_codeCompEvaluatorCell_exists [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] {r : ℕ} + (dtable dk dcf dcg dn : Code r) (table kv cf cg index : M) (v : Fin r → M) + (htable : Semiformula.Evalb (table :> v) (code dtable)) + (hk : Semiformula.Evalb (kv :> v) (code dk)) (hcf : Semiformula.Evalb (cf :> v) (code dcf)) + (hcg : Semiformula.Evalb (cg :> v) (code dcg)) + (hn : Semiformula.Evalb (index :> v) (code dn)) : + ∃ z : M, Semiformula.Evalb (z :> v) (code (codeCompEvaluatorCell dtable dk dcf dcg dn)) := + by + let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + obtain ⟨o₁, ho₁⟩ := + eval_codeTableLookup_exists_of_values dtable dk dcg dn table kv cg index v htable hk hcg hn + refine eval_codeOptionBind_exists_of_value _ _ o₁ v ho₁ ?_ + have hL : + ∀ (X : Code r) (x : M), + Semiformula.Evalb (x :> v) (code X) → + Semiformula.Evalb (x :> (o₁ - 1) :> v) (code (codeLift X)) := + fun X x hx => (eval_codeLift_iff X x (o₁ - 1) v).mpr hx + exact + eval_codeTableLookup_exists_of_values (codeLift dtable) (codeLift dk) (codeLift dcf) + (codeHead (n := r)) table kv cf (o₁ - 1) ((o₁ - 1) :> v) (hL _ _ htable) (hL _ _ hk) + (hL _ _ hcf) ((eval_codeHead_iff _ _).mpr rfl) + +/-- The primitive-recursion cell has a value. Both arms of its eager +conditional are evaluated: the step lookup with its continuation, and the base +lookup. -/ +private theorem eval_codePrecEvaluatorCell_exists [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] {r : ℕ} + (dtable dk' dq dcf dcg dn : Code r) (table k' qv cf cg index : M) (v : Fin r → M) + (htable : Semiformula.Evalb (table :> v) (code dtable)) + (hk' : Semiformula.Evalb (k' :> v) (code dk')) (hq : Semiformula.Evalb (qv :> v) (code dq)) + (hcf : Semiformula.Evalb (cf :> v) (code dcf)) + (hcg : Semiformula.Evalb (cg :> v) (code dcg)) + (hn : Semiformula.Evalb (index :> v) (code dn)) : + ∃ z : M, + Semiformula.Evalb (z :> v) (code (codePrecEvaluatorCell dtable dk' dq dcf dcg dn)) := + by + let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + have hz := eval_codeUnpair₁ dn index v hn + have ht := eval_codeUnpair₂ dn index v hn + have hy := eval_codeSub (codeUnpair₂ dn) (codeConst 1) _ _ v ht (eval_codeConst 1 v) + have hdk : Semiformula.Evalb ((k' + 1) :> v) (code (codeSucc dk')) := + (eval_codeSucc_iff _ _ _).mpr ⟨k', hk', rfl⟩ + have hzy := + eval_codePair (codeUnpair₁ dn) (codeSub (codeUnpair₂ dn) (codeConst 1)) _ _ v hz hy + refine eval_codeIfPos_exists _ _ _ v ⟨_, ht⟩ ?_ ?_ + · obtain ⟨o₁, ho₁⟩ := + eval_codeTableLookup_exists_of_values dtable dk' dq + (codePair (codeUnpair₁ dn) (codeSub (codeUnpair₂ dn) (codeConst 1))) table k' qv _ v + htable hk' hq hzy + refine eval_codeOptionBind_exists_of_value _ _ o₁ v ho₁ ?_ + have hL : + ∀ (X : Code r) (x : M), + Semiformula.Evalb (x :> v) (code X) → + Semiformula.Evalb (x :> (o₁ - 1) :> v) (code (codeLift X)) := + fun X x hx => (eval_codeLift_iff X x (o₁ - 1) v).mpr hx + have hinner := + eval_codePair (codeLift (codeSub (codeUnpair₂ dn) (codeConst 1))) (codeHead (n := r)) _ + (o₁ - 1) ((o₁ - 1) :> v) (hL _ _ hy) ((eval_codeHead_iff _ _).mpr rfl) + exact + eval_codeTableLookup_exists_of_values (codeLift dtable) (codeLift (codeSucc dk')) + (codeLift dcg) + (codePair (codeLift (codeUnpair₁ dn)) + (codePair (codeLift (codeSub (codeUnpair₂ dn) (codeConst 1))) (codeHead (n := r)))) + table (k' + 1) cg _ ((o₁ - 1) :> v) (hL _ _ htable) (hL _ _ hdk) (hL _ _ hcg) + (eval_codePair _ _ _ _ ((o₁ - 1) :> v) (hL _ _ hz) hinner) + · exact + eval_codeTableLookup_exists_of_values dtable (codeSucc dk') dcf (codeUnpair₁ dn) table + (k' + 1) cf _ v htable hdk hcf hz + +/-- The minimization cell has a value. Its continuation is an eager +conditional, so the recursive lookup and the returned successor are both +evaluated. -/ +private theorem eval_codeRfindEvaluatorCell_exists [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] {r : ℕ} + (dtable dk' dq dcf dn : Code r) (table k' qv cf index : M) (v : Fin r → M) + (htable : Semiformula.Evalb (table :> v) (code dtable)) + (hk' : Semiformula.Evalb (k' :> v) (code dk')) (hq : Semiformula.Evalb (qv :> v) (code dq)) + (hcf : Semiformula.Evalb (cf :> v) (code dcf)) + (hn : Semiformula.Evalb (index :> v) (code dn)) : + ∃ z : M, Semiformula.Evalb (z :> v) (code (codeRfindEvaluatorCell dtable dk' dq dcf dn)) := + by + let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + have hz := eval_codeUnpair₁ dn index v hn + have hm := eval_codeUnpair₂ dn index v hn + have hdk : Semiformula.Evalb ((k' + 1) :> v) (code (codeSucc dk')) := + (eval_codeSucc_iff _ _ _).mpr ⟨k', hk', rfl⟩ + have hzm := eval_codePair (codeUnpair₁ dn) (codeUnpair₂ dn) _ _ v hz hm + obtain ⟨o₁, ho₁⟩ := + eval_codeTableLookup_exists_of_values dtable (codeSucc dk') dcf + (codePair (codeUnpair₁ dn) (codeUnpair₂ dn)) table (k' + 1) cf _ v htable hdk hcf hzm + refine eval_codeOptionBind_exists_of_value _ _ o₁ v ho₁ ?_ + have hL : + ∀ (X : Code r) (x : M), + Semiformula.Evalb (x :> v) (code X) → + Semiformula.Evalb (x :> (o₁ - 1) :> v) (code (codeLift X)) := + fun X x hx => (eval_codeLift_iff X x (o₁ - 1) v).mpr hx + have hsuccm : + Semiformula.Evalb ((FFL.FirstOrder.Arithmetic.pi₂ index + 1) :> (o₁ - 1) :> v) + (code (codeSucc (codeLift (codeUnpair₂ dn)))) := + (eval_codeSucc_iff _ _ _).mpr ⟨_, hL _ _ hm, rfl⟩ + refine + eval_codeIfPos_exists _ _ _ ((o₁ - 1) :> v) ⟨_, (eval_codeHead_iff _ _).mpr rfl⟩ ?_ + ⟨_, hsuccm⟩ + exact + eval_codeTableLookup_exists_of_values (codeLift dtable) (codeLift dk') (codeLift dq) + (codePair (codeLift (codeUnpair₁ dn)) (codeSucc (codeLift (codeUnpair₂ dn)))) table k' qv + _ ((o₁ - 1) :> v) (hL _ _ htable) (hL _ _ hk') (hL _ _ hq) + (eval_codePair _ _ _ _ ((o₁ - 1) :> v) (hL _ _ hz) hsuccm) + +/-- An evaluator cell has a value at any table and argument values. + +The cell is a nested eager conditional, so every one of its five branches is +evaluated before the tag comparisons select one, and each branch in turn +supplies every lookup and every option continuation it contains. Only +existence is asserted: nothing here decodes the table, the index, or the +program, and no value is identified. -/ +theorem eval_codeEvaluatorCell_exists_of_values {M : Type*} [ORingStructure M] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] + {r : ℕ} (dtable dn : Code r) (table index : M) (v : Fin r → M) + (htable : Semiformula.Evalb (table :> v) (code dtable)) + (hindex : Semiformula.Evalb (index :> v) (code dn)) : + ∃ z : M, Semiformula.Evalb (z :> v) (code (codeEvaluatorCell dtable dn)) := + by + let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + obtain ⟨p, hp⟩ := eval_codeListLength_exists_of_value dtable table v htable + have hk := eval_codeUnpair₁ (codeListLength dtable) p v hp + have hq := eval_codeUnpair₂ (codeListLength dtable) p v hp + have hk' := + eval_codeSub (codeUnpair₁ (codeListLength dtable)) (codeConst 1) _ _ v hk + (eval_codeConst 1 v) + obtain ⟨tg, htag⟩ := + eval_codePartrecTag_exists_of_value (codeUnpair₂ (codeListLength dtable)) _ v hq + obtain ⟨cf, hcf⟩ := + eval_codePartrecPayload₁_exists_of_value (codeUnpair₂ (codeListLength dtable)) _ v hq + obtain ⟨cg, hcg⟩ := + eval_codePartrecPayload₂_exists_of_value (codeUnpair₂ (codeListLength dtable)) _ v hq + obtain ⟨pl, hpl⟩ := + eval_codePartrecPayload_exists_of_value (codeUnpair₂ (codeListLength dtable)) _ v hq + have hcmp : + ∀ m : ℕ, + ∃ z : M, + Semiformula.Evalb (z :> v) + (code + (codeEq (codePartrecTag (codeUnpair₂ (codeListLength dtable))) + (codeConst (n := r) m))) := + fun m => eval_codeEq_exists _ _ tg _ v htag (eval_codeConst m v) + refine eval_codeIfPos_exists _ _ _ v ⟨_, hk⟩ ?_ ⟨_, eval_codeConst 0 v⟩ + refine + eval_codeIfPos_exists _ _ _ v (hcmp 4) + (eval_codePairEvaluatorCell_exists _ _ _ _ _ _ _ _ _ _ v htable hk hcf hcg hindex) ?_ + refine + eval_codeIfPos_exists _ _ _ v (hcmp 5) + (eval_codeCompEvaluatorCell_exists _ _ _ _ _ _ _ _ _ _ v htable hk hcf hcg hindex) ?_ + refine + eval_codeIfPos_exists _ _ _ v (hcmp 6) + (eval_codePrecEvaluatorCell_exists _ _ _ _ _ _ _ _ _ _ _ _ v htable hk' hq hcf hcg hindex) + ?_ + exact + eval_codeIfPos_exists _ _ _ v (hcmp 7) + (eval_codeRfindEvaluatorCell_exists _ _ _ _ _ _ _ _ _ _ v htable hk' hq hpl hindex) + (eval_codeBaseEvaluatorCell_exists dtable dn table index v htable hindex) + +end Evaluator +end CategoricalRiceShapiro + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/Certificate.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/Certificate.lean new file mode 100644 index 000000000..8403f3c3f --- /dev/null +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/Certificate.lean @@ -0,0 +1,383 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.HistoryEvaluation +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.CompositionDispatch + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# The raw evaluator certificate + +`evalnGraphFormula` names the graph of `codeHistoryEvaluator` as a Sigma-one +semisentence, and `evalnCertificateFormula` reorders and shifts its arguments so +that the four places read `stage`, `index`, `input`, `output`, with the output +recorded as its successor. `evalnCertificateFormula_eval_history_iff` is the +bridge between the two presentations; it is a substitution identity and needs no +arithmetic theory. + +`evalnCertificateFormula_canonicalPartrecCompIndex_forward` decomposes a +certificate for a canonical composition index into a certificate for the inner +index followed by one for the outer index, at the same stage. +`evalnCertificateFormula_canonicalPartrecCompIndex_reverse` reconstructs the +certificate for the composition index from two component certificates that are +already at one supplied stage. +`evalnCertificateFormula_canonicalPartrecCompIndex_iff` packages these two +directions as an equivalence at one supplied stage. None of these theorems +brings certificates supplied at unrelated stages to a common stage, and none +concerns first-success minimality or standard-model semantics. +-/ + +@[expose] public section + +open _root_.Nat Nat Nat.ArithPart₁ + +namespace CategoricalRiceShapiro +namespace Evaluator + +open CategoricalRiceShapiro.ArithmeticCode + +open CategoricalRiceShapiro.PartialRecursive + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +open scoped FFL.FirstOrder.Arithmetic + +/-- The graph of `codeHistoryEvaluator`, as a Sigma-one semisentence. -/ +def evalnGraphFormula : Σ₁.Semisentence 4 := + .mkSigma (FFL.FirstOrder.Arithmetic.code codeHistoryEvaluator) + (code_sigma_one codeHistoryEvaluator) + +/-- The raw evaluator certificate: the graph formula with its places reordered +to `stage`, `index`, `input`, `output`, the output shifted by one. -/ +def evalnCertificateFormula : Σ₁.Semisentence 4 := + evalnGraphFormula.rew + (Rew.subst + ![(‘#3 + 1’ : ArithmeticSemiterm Empty 4), (#0 : ArithmeticSemiterm Empty 4), + (#1 : ArithmeticSemiterm Empty 4), (#2 : ArithmeticSemiterm Empty 4)]) + +/-- The certificate formula is the graph of `codeHistoryEvaluator` with the +places reordered. This is a substitution identity: it holds in an arbitrary +structure and needs no arithmetic theory. -/ +theorem evalnCertificateFormula_eval_history_iff {M : Type*} [ORingStructure M] + (s qCode u y : M) : + Semiformula.Evalb ![s, qCode, u, y] (evalnCertificateFormula : ArithmeticSemisentence 4) ↔ + Semiformula.Evalb ![y + 1, s, qCode, u] + (FFL.FirstOrder.Arithmetic.code codeHistoryEvaluator) := + by + have hb : + (fun x : Fin 4 => + Semiterm.val ![s, qCode, u, y] (Empty.elim : Empty → M) + ((Rew.subst ![(‘#3 + 1’ : ArithmeticSemiterm Empty 4), #0, #1, #2]) + (#x : Semiterm ℒₒᵣ Empty 4))) = + ![y + 1, s, qCode, u] := + by + funext x + refine Fin.cases ?_ ?_ x + · simp + · intro i1 + refine Fin.cases ?_ ?_ i1 + · simp + · intro i2 + refine Fin.cases ?_ ?_ i2 + · simp + · intro i3 + refine Fin.cases ?_ (fun i4 => Fin.elim0 i4) i3 + simp + have hf : + (fun x : Empty => + Semiterm.val ![s, qCode, u, y] (Empty.elim : Empty → M) + ((Rew.subst ![(‘#3 + 1’ : ArithmeticSemiterm Empty 4), #0, #1, #2]) (&x))) = + Empty.elim := + funext (fun x => x.elim) + simp only [evalnCertificateFormula, evalnGraphFormula, HierarchySymbol.Semiformula.val_rew, + HierarchySymbol.Semiformula.val_mkSigma, Semiformula.eval_rew, Function.comp_def, hb, hf] + +variable {M : Type*} [ORingStructure M] + +/-- The history read before the cell depends only on the first two arguments. -/ +private theorem beforeCell_iff [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (s qCode a b z : M) : + Semiformula.Evalb (z :> ![s, qCode, a]) + (FFL.FirstOrder.Arithmetic.code + codeEvaluatorHistoryBeforeCell) ↔ + Semiformula.Evalb (z :> ![s, qCode, b]) + (FFL.FirstOrder.Arithmetic.code + codeEvaluatorHistoryBeforeCell) := by + have hp : + ∀ c : M, + Semiformula.Evalb + (FFL.FirstOrder.Arithmetic.pair s qCode :> ![s, qCode, c]) + (FFL.FirstOrder.Arithmetic.code + (codePair (Code.proj (0 : Fin 3)) (Code.proj (1 : Fin 3)))) := + fun c => + eval_codePair _ _ s qCode ![s, qCode, c] ((eval_proj_iff _ _ _).mpr rfl) + ((eval_proj_iff _ _ _).mpr rfl) + rw [codeEvaluatorHistoryBeforeCell, eval_comp_iff, eval_comp_iff] + constructor + · rintro ⟨w, hw, hwi⟩ + refine ⟨w, hw, fun i => ?_⟩ + refine Fin.cases ?_ (fun j => Fin.elim0 j) i + have h0 := hwi 0 + simp only [Matrix.cons_val_fin_one] at h0 ⊢ + rw [eval_unique h0 (hp a)] + exact hp b + · rintro ⟨w, hw, hwi⟩ + refine ⟨w, hw, fun i => ?_⟩ + refine Fin.cases ?_ (fun j => Fin.elim0 j) i + have h0 := hwi 0 + simp only [Matrix.cons_val_fin_one] at h0 ⊢ + rw [eval_unique h0 (hp b)] + exact hp a + +-- The history-evaluator code contains the whole evaluator-cell code. + +/-- A certificate for a canonical composition index decomposes, at the same +stage, into a certificate for the inner index and one for the outer index. + +`𝐏𝐀` is the only theory assumption. The indices enter the statement through +`ORingStructure.numeral`, which needs no theory, rather than through the +numeral cast, whose `NatCast` instance is not reachable from `𝐏𝐀` by instance +search; `𝐈Σ 1` is installed inside the proof and supplies `𝐈Σ₀`, `𝐈𝐎𝐩𝐞𝐧` and +`𝐏𝐀⁻` through Foundation's instance chain. -/ +theorem evalnCertificateFormula_canonicalPartrecCompIndex_forward [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] (s u y : M) + (fCode gCode : ℕ) + (h : + Semiformula.Evalb + ![s, (ORingStructure.numeral (canonicalPartrecCompIndex fCode gCode) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4)) : + ∃ x : M, + Semiformula.Evalb ![s, (ORingStructure.numeral gCode : M), u, x] + (evalnCertificateFormula : ArithmeticSemisentence 4) ∧ + Semiformula.Evalb ![s, (ORingStructure.numeral fCode : M), x, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) := by + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + simp only [numeral_eq_natCast_app] at h ⊢ + rw [evalnCertificateFormula_eval_history_iff] at h + obtain ⟨hcode, hcell⟩ := eval_codeHistoryEvaluator_succ_extract_cell s _ u y h + obtain ⟨x, hinner, houter⟩ := + eval_codeEvaluatorCell_succ_of_canonicalPartrecCompIndex codeEvaluatorHistoryBeforeCell + (Code.proj (2 : Fin 3)) fCode gCode y ![s, (canonicalPartrecCompIndex fCode gCode : M), u] + (by simpa using hcode) hcell + have hgl : + FFL.FirstOrder.Arithmetic.pair s (gCode : M) < + FFL.FirstOrder.Arithmetic.pair s + (canonicalPartrecCompIndex fCode gCode : M) := + FFL.FirstOrder.Arithmetic.pair_lt_pair_right s + (by exact_mod_cast canonicalPartrecCompIndex_inner_lt fCode gCode) + have hfl : + FFL.FirstOrder.Arithmetic.pair s (fCode : M) < + FFL.FirstOrder.Arithmetic.pair s + (canonicalPartrecCompIndex fCode gCode : M) := + FFL.FirstOrder.Arithmetic.pair_lt_pair_right s + (by exact_mod_cast canonicalPartrecCompIndex_outer_lt fCode gCode) + refine ⟨x, ?_, ?_⟩ + · rw [evalnCertificateFormula_eval_history_iff] + exact eval_codeHistoryEvaluator_succ_of_prefix_lookup s _ u x gCode hgl hinner + · rw [evalnCertificateFormula_eval_history_iff] + refine + eval_codeHistoryEvaluator_succ_of_prefix_lookup s _ x y fCode hfl + ?_ + -- transport the lifted outer lookup from arity four to arity three + refine + (eval_codeTableLookup_congr_at (codeLift codeEvaluatorHistoryBeforeCell) + (codeLift (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell))) + (codeConst (n := 4) fCode) (codeHead (n := 3)) codeEvaluatorHistoryBeforeCell + (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell)) + (codeConst (n := 3) fCode) (Code.proj (2 : Fin 3)) (y + 1) + (x :> ![s, (canonicalPartrecCompIndex fCode gCode : M), u]) + ![s, (canonicalPartrecCompIndex fCode gCode : M), x] ?_ ?_ ?_ ?_).mp + houter + · intro z + rw [eval_codeLift_iff] + exact beforeCell_iff s _ u x z + · intro z + rw [eval_codeLift_iff] + refine eval_codeUnpair₁_congr_at _ _ z _ _ ?_ + intro w + exact eval_codeListLength_congr_at _ _ w _ _ (fun c => beforeCell_iff s _ u x c) + · intro z + rw [eval_codeConst_iff, eval_codeConst_iff] + · intro z + rw [eval_codeHead_iff, eval_proj_iff] + simp + +-- The history-evaluator code contains the whole evaluator-cell code. + +/-- Two component certificates at one supplied stage reconstruct the certificate +for their canonical composition at that same stage. -/ +theorem evalnCertificateFormula_canonicalPartrecCompIndex_reverse [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] (s u x y : M) + (fCode gCode : ℕ) + (hinner : + Semiformula.Evalb ![s, (ORingStructure.numeral gCode : M), u, x] + (evalnCertificateFormula : ArithmeticSemisentence 4)) + (houter : + Semiformula.Evalb ![s, (ORingStructure.numeral fCode : M), x, y] + (evalnCertificateFormula : ArithmeticSemisentence 4)) : + Semiformula.Evalb + ![s, (ORingStructure.numeral (canonicalPartrecCompIndex fCode gCode) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) := by + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + simp only [numeral_eq_natCast_app] at hinner houter ⊢ + rw [evalnCertificateFormula_eval_history_iff] at hinner houter ⊢ + -- the strict input bound of the inner lookup, and positive fuel + obtain ⟨hus, -⟩ := (eval_codeHistoryEvaluator_succ_iff_cell s _ u x).mp hinner + have hs0 : 0 < s := + lt_of_le_of_lt (FFL.FirstOrder.Arithmetic.zero_le u) hus + have hgl : + FFL.FirstOrder.Arithmetic.pair s (gCode : M) < + FFL.FirstOrder.Arithmetic.pair s + (canonicalPartrecCompIndex fCode gCode : M) := + FFL.FirstOrder.Arithmetic.pair_lt_pair_right s + (by exact_mod_cast canonicalPartrecCompIndex_inner_lt fCode gCode) + have hfl : + FFL.FirstOrder.Arithmetic.pair s (fCode : M) < + FFL.FirstOrder.Arithmetic.pair s + (canonicalPartrecCompIndex fCode gCode : M) := + FFL.FirstOrder.Arithmetic.pair_lt_pair_right s + (by exact_mod_cast canonicalPartrecCompIndex_outer_lt fCode gCode) + -- both component lookups at the stage of the composition index + have hinnerL := eval_prefix_lookup_succ_of_codeHistoryEvaluator s _ u x gCode hgl hinner + have houterL := eval_prefix_lookup_succ_of_codeHistoryEvaluator s _ x y fCode hfl houter + have houterLifted : + Semiformula.Evalb ((y + 1) :> (x :> ![s, (canonicalPartrecCompIndex fCode gCode : M), u])) + (FFL.FirstOrder.Arithmetic.code + (codeTableLookup (codeLift codeEvaluatorHistoryBeforeCell) + (codeLift (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell))) + (codeConst (n := 4) fCode) (codeHead (n := 3)))) := + by + refine + (eval_codeTableLookup_congr_at (codeLift codeEvaluatorHistoryBeforeCell) + (codeLift (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell))) + (codeConst (n := 4) fCode) (codeHead (n := 3)) codeEvaluatorHistoryBeforeCell + (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell)) + (codeConst (n := 3) fCode) (Code.proj (2 : Fin 3)) (y + 1) + (x :> ![s, (canonicalPartrecCompIndex fCode gCode : M), u]) + ![s, (canonicalPartrecCompIndex fCode gCode : M), x] ?_ ?_ ?_ ?_).mpr + houterL + · intro z + rw [eval_codeLift_iff] + exact beforeCell_iff s _ u x z + · intro z + rw [eval_codeLift_iff] + refine eval_codeUnpair₁_congr_at _ _ z _ _ ?_ + intro w + exact eval_codeListLength_congr_at _ _ w _ _ (fun c => beforeCell_iff s _ u x c) + · intro z + rw [eval_codeConst_iff, eval_codeConst_iff] + · intro z + rw [eval_codeHead_iff, eval_proj_iff] + simp + -- both Cantor components of the length of the history before the cell + have hlencomp : + Semiformula.Evalb (s :> ![s, (canonicalPartrecCompIndex fCode gCode : M), u]) + (FFL.FirstOrder.Arithmetic.code + (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell))) ∧ + Semiformula.Evalb + ((canonicalPartrecCompIndex fCode gCode : M) :> + ![s, (canonicalPartrecCompIndex fCode gCode : M), u]) + (FFL.FirstOrder.Arithmetic.code + (codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell))) := + by + obtain ⟨H, hH⟩ := + eval_codeEvaluatorHistory_exists + (FFL.FirstOrder.Arithmetic.pair s + (canonicalPartrecCompIndex fCode gCode : M)) + have hbefore : + Semiformula.Evalb (H :> ![s, (canonicalPartrecCompIndex fCode gCode : M), u]) + (FFL.FirstOrder.Arithmetic.code + codeEvaluatorHistoryBeforeCell) := + by + rw [codeEvaluatorHistoryBeforeCell, eval_comp_iff] + refine + ⟨![FFL.FirstOrder.Arithmetic.pair s + (canonicalPartrecCompIndex fCode gCode : M)], + by simpa using hH, ?_⟩ + intro i + refine Fin.cases ?_ (fun j => Fin.elim0 j) i + simpa using + eval_codePair (Code.proj (0 : Fin 3)) (Code.proj (1 : Fin 3)) s _ + ![s, (canonicalPartrecCompIndex fCode gCode : M), u] ((eval_proj_iff _ _ _).mpr rfl) + ((eval_proj_iff _ _ _).mpr rfl) + have hself : + Semiformula.Evalb (H :> ![H]) + (FFL.FirstOrder.Arithmetic.code + (Code.proj (0 : Fin 1))) := + (eval_proj_iff _ _ _).mpr rfl + obtain ⟨len, hlen⟩ := + eval_codeListLength_exists_of_value (Code.proj (0 : Fin 1)) H ![H] hself + have hlenv : + len = + FFL.FirstOrder.Arithmetic.pair s + (canonicalPartrecCompIndex fCode gCode : M) := + eval_codeEvaluatorHistory_length_unique _ H len hH hlen + have hgraph : + ∀ z : M, + Semiformula.Evalb (z :> ![H]) + (FFL.FirstOrder.Arithmetic.code + (Code.proj (0 : Fin 1))) ↔ + Semiformula.Evalb (z :> ![s, (canonicalPartrecCompIndex fCode gCode : M), u]) + (FFL.FirstOrder.Arithmetic.code + codeEvaluatorHistoryBeforeCell) := + by + intro z + constructor + · intro hz + rw [eval_unique hz hself] + exact hbefore + · intro hz + rw [eval_unique hz hbefore] + exact hself + have hlen' := (eval_codeListLength_congr_at _ _ len _ _ hgraph).mp hlen + rw [hlenv] at hlen' + have h₁ := eval_codeUnpair₁ _ _ _ hlen' + have h₂ := eval_codeUnpair₂ _ _ _ hlen' + rw [FFL.FirstOrder.Arithmetic.pi₁_pair] at h₁ + rw [FFL.FirstOrder.Arithmetic.pi₂_pair] at h₂ + exact + ⟨h₁, h₂⟩ + -- the canonical cell has the value `y + 1` + have hcell := + eval_codeEvaluatorCell_succ_of_component_lookups codeEvaluatorHistoryBeforeCell + (Code.proj (2 : Fin 3)) fCode gCode x y + ![s, (canonicalPartrecCompIndex fCode gCode : M), u] + (by rw [numeral_eq_natCast_app]; exact hlencomp.2) ⟨s, hs0, hlencomp.1⟩ hinnerL + houterLifted + exact (eval_codeHistoryEvaluator_succ_iff_cell s _ u y).mpr ⟨hus, hcell⟩ + +/-- A certificate for a canonical composition index at a supplied stage is +equivalent to an inner certificate followed by an outer certificate at that +same stage. -/ +theorem evalnCertificateFormula_canonicalPartrecCompIndex_iff [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] (s u y : M) + (fCode gCode : ℕ) : + Semiformula.Evalb + ![s, (ORingStructure.numeral (canonicalPartrecCompIndex fCode gCode) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) ↔ + ∃ x : M, + Semiformula.Evalb ![s, (ORingStructure.numeral gCode : M), u, x] + (evalnCertificateFormula : ArithmeticSemisentence 4) ∧ + Semiformula.Evalb ![s, (ORingStructure.numeral fCode : M), x, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) := + by + constructor + · intro h + exact evalnCertificateFormula_canonicalPartrecCompIndex_forward (M := M) s u y fCode gCode h + · rintro ⟨x, hinner, houter⟩ + exact + evalnCertificateFormula_canonicalPartrecCompIndex_reverse (M := M) s u x y fCode gCode + hinner houter + +end Evaluator +end CategoricalRiceShapiro + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/CompositionDispatch.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/CompositionDispatch.lean new file mode 100644 index 000000000..c87c55894 --- /dev/null +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/CompositionDispatch.lean @@ -0,0 +1,632 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.CellEvaluation +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.CellCongruence +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.TableLookupEvaluation +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.PartialRecursive.CanonicalComposition + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# Fixed component indices and evaluator-cell reconstruction + +When the index under evaluation has constructor number `5`, the eager branches +of `codeEvaluatorCell` collapse to the composition branch, and a successful cell +yields the two table lookups that branch performs: +`eval_codeEvaluatorCell_succ_of_tag_five`. + +For the canonical index of a composed program the two component indices are +known natural numbers. `eval_codeEvaluatorCell_succ_of_canonicalPartrecCompIndex` +replaces the decoded queries by the constant codes of those numbers, so that a +later argument can reason with fixed indices rather than with decoder terms. +The replacement is a graph equivalence at the given assignment, not a +definitional one: `eval_codeTableLookup_query_congr` performs it, and +`eval_iff_codeConst_of_eval` supplies its hypothesis. + +The outer lookup needs one further step. Transporting the payload equivalence +under `codeLift` produces `codeLift (codeConst (n := r) fCode)`, which is +evaluation-equivalent but not definitionally equal to the arity-`r + 1` constant +the statement asks for; `eval_codeLift_codeConst_iff` closes that gap. + +These results are forward extraction from a successful cell over `𝐏𝐀⁻`. They +construct no cell, so the eager evaluation of the unused branches is not an +obstacle for them. + +The composition reverse theorem, +`eval_codeEvaluatorCell_succ_of_component_lookups`, does construct a cell. +`codeIfPos` is a sum of products +containing both of its branches, so an evaluation of the cell needs a value for +every branch, not only the composition branch. Over `𝐏𝐀`, +`eval_codeEvaluatorCell_exists_of_values` gives the entire eager cell a value; +positive fuel and tag `5` force the composition branch in that evaluation, and +`eval_unique` identifies the cell value with the value of the composition branch +built from the two component lookups. + +The pairing analogue, +`eval_codeEvaluatorCell_succ_of_pair_component_lookups`, starts from a standard +constructor-`4` index and successful lookups at its two decoded payloads. It +constructs the eager cell with the same existence theorem, forces the pairing +branch using positive fuel and the decoded tag, and identifies the result with +`pair a b + 1`. Its decoder-reading and branch-selection lemmas remain private. +This result does not transport certificates between stages or prove persistence +for recursively referenced subcodes. +-/ + +@[expose] public section + +open _root_.Nat Nat Nat.ArithPart₁ + +namespace CategoricalRiceShapiro +namespace Evaluator + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +open scoped FFL.FirstOrder.Arithmetic + +open CategoricalRiceShapiro.ArithmeticCode + +open CategoricalRiceShapiro.PartialRecursive + +/-- A successful evaluator cell whose index has constructor number `5` performs +the two lookups of the composition branch. -/ +theorem eval_codeEvaluatorCell_succ_of_tag_five {M : Type*} [ORingStructure M] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] + {r : ℕ} (dtable dn : Code r) (y : M) (v : Fin r → M) + (htag : + Semiformula.Evalb ((5 : M) :> v) + (code (codePartrecTag (codeUnpair₂ (codeListLength dtable))))) + (hcell : Semiformula.Evalb ((y + 1) :> v) (code (codeEvaluatorCell dtable dn))) : + ∃ x : M, + Semiformula.Evalb ((x + 1) :> v) + (code + (codeTableLookup dtable (codeUnpair₁ (codeListLength dtable)) + (codePartrecPayload₂ (codeUnpair₂ (codeListLength dtable))) dn)) ∧ + Semiformula.Evalb ((y + 1) :> x :> v) + (code + (codeTableLookup (codeLift dtable) (codeLift (codeUnpair₁ (codeListLength dtable))) + (codeLift (codePartrecPayload₁ (codeUnpair₂ (codeListLength dtable)))) + (codeHead (n := r)))) := + by + have hposS : ∀ a : M, (0 : M) < a + 1 := fun a => + lt_of_lt_of_le _root_.zero_lt_one le_add_self + have hne54 : ¬((5 : M) = (4 : M)) := + by + have h5 : (5 : M) = (4 : M) + 1 := by norm_num + rw [h5] + exact (_root_.ne_of_lt (lt_add_one _)).symm + simp only [codeEvaluatorCell] at hcell + obtain ⟨kf, hkf, hkcase⟩ := eval_codeIfPos_cases _ _ _ (y + 1) v hcell + rcases hkcase with ⟨-, hbig⟩ | ⟨-, hzero⟩ + · obtain ⟨e4, he4, h4case⟩ := eval_codeIfPos_cases _ _ _ (y + 1) v hbig + rw [eval_codeEq_iff] at he4 + obtain ⟨a4, b4, ha4, hb4, hc4⟩ := he4 + have ha45 : a4 = (5 : M) := eval_unique ha4 htag + have hb44 : b4 = (4 : M) := + by + have h := (eval_codeConst_iff 4 b4 v).mp hb4 + simpa using h + have he40 : e4 = 0 := by + rcases hc4 with ⟨heq, -⟩ | ⟨-, h0⟩ + · exact absurd (by rw [← ha45, ← hb44]; exact heq) hne54 + · exact h0 + rcases h4case with ⟨hpos, -⟩ | ⟨-, hrest⟩ + · exact absurd (he40 ▸ hpos) (_root_.lt_irrefl 0) + · obtain ⟨e5, he5, h5case⟩ := eval_codeIfPos_cases _ _ _ (y + 1) v hrest + rw [eval_codeEq_iff] at he5 + obtain ⟨a5, b5, ha5, hb5, hc5⟩ := he5 + have ha55 : a5 = (5 : M) := eval_unique ha5 htag + have hb55 : b5 = (5 : M) := + by + have h := (eval_codeConst_iff 5 b5 v).mp hb5 + simpa using h + have he51 : e5 = 1 := by + rcases hc5 with ⟨-, h1⟩ | ⟨hne, -⟩ + · exact h1 + · exact absurd (by rw [ha55, hb55]) hne + rcases h5case with ⟨-, hcomp5⟩ | ⟨h0, -⟩ + · exact + (eval_codeCompEvaluatorCell_succ_iff dtable (codeUnpair₁ (codeListLength dtable)) + (codePartrecPayload₁ (codeUnpair₂ (codeListLength dtable))) + (codePartrecPayload₂ (codeUnpair₂ (codeListLength dtable))) dn y v).mp + hcomp5 + · exact absurd (he51 ▸ h0) _root_.one_ne_zero + · exfalso + have hz0 : y + 1 = ((0 : ℕ) : M) := (eval_codeConst_iff 0 (y + 1) v).mp hzero + simp only [Nat.cast_zero] at hz0 + exact absurd hz0 (ne_of_gt (hposS y)) + +/-- The dispatcher step at the canonical composition index, still with decoded +queries. Used only by the theorem below, which replaces those queries by the +constant codes of the two component indices. -/ +private theorem eval_codeEvaluatorCell_succ_decoded {M : Type*} [ORingStructure M] + [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (dtable dn : Code r) (fCode gCode : ℕ) (y : M) (v : Fin r → M) + (hcode : + Semiformula.Evalb ((canonicalPartrecCompIndex fCode gCode : M) :> v) + (code (codeUnpair₂ (codeListLength dtable)))) + (hcell : Semiformula.Evalb ((y + 1) :> v) (code (codeEvaluatorCell dtable dn))) : + ∃ x : M, + Semiformula.Evalb ((x + 1) :> v) + (code + (codeTableLookup dtable (codeUnpair₁ (codeListLength dtable)) + (codePartrecPayload₂ (codeUnpair₂ (codeListLength dtable))) dn)) ∧ + Semiformula.Evalb ((y + 1) :> x :> v) + (code + (codeTableLookup (codeLift dtable) (codeLift (codeUnpair₁ (codeListLength dtable))) + (codeLift (codePartrecPayload₁ (codeUnpair₂ (codeListLength dtable)))) + (codeHead (n := r)))) := + eval_codeEvaluatorCell_succ_of_tag_five dtable dn y v + (eval_codePartrecTag_canonicalPartrecCompIndex (codeUnpair₂ (codeListLength dtable)) fCode + gCode v hcode) + hcell + +/-- Fixed component indices for canonical program composition. + +From a successful evaluator cell whose index is the canonical index of the +composition of `fCode` and `gCode`, the inner lookup runs the constant `gCode` +and the outer lookup the constant `fCode`, both at their own arities. -/ +theorem eval_codeEvaluatorCell_succ_of_canonicalPartrecCompIndex {M : Type*} [ORingStructure M] + [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (dtable dn : Code r) (fCode gCode : ℕ) (y : M) (v : Fin r → M) + (hcode : + Semiformula.Evalb ((canonicalPartrecCompIndex fCode gCode : M) :> v) + (FFL.FirstOrder.Arithmetic.code + (codeUnpair₂ (codeListLength dtable)))) + (hcell : + Semiformula.Evalb ((y + 1) :> v) + (FFL.FirstOrder.Arithmetic.code + (codeEvaluatorCell dtable dn))) : + ∃ x : M, + Semiformula.Evalb ((x + 1) :> v) + (FFL.FirstOrder.Arithmetic.code + (codeTableLookup dtable (codeUnpair₁ (codeListLength dtable)) + (codeConst (n := r) gCode) dn)) ∧ + Semiformula.Evalb ((y + 1) :> (x :> v)) + (FFL.FirstOrder.Arithmetic.code + (codeTableLookup (codeLift dtable) (codeLift (codeUnpair₁ (codeListLength dtable))) + (codeConst (n := r + 1) fCode) (codeHead (n := r)))) := by + obtain ⟨x, hinner, houter⟩ := + eval_codeEvaluatorCell_succ_decoded dtable dn fCode gCode y v hcode hcell + refine ⟨x, ?_, ?_⟩ + · -- the inner query has the graph of the constant `gCode` at this assignment + have hg := + eval_codePartrecPayload₂_canonicalPartrecCompIndex (codeUnpair₂ (codeListLength dtable)) + fCode gCode v hcode + refine (eval_codeTableLookup_query_congr dtable _ _ _ dn (x + 1) v ?_).mp hinner + intro z + exact eval_iff_codeConst_of_eval _ gCode v (by simpa using hg) z + · -- the outer query, first as a lifted constant, then at the larger arity + have hf := + eval_codePartrecPayload₁_canonicalPartrecCompIndex (codeUnpair₂ (codeListLength dtable)) + fCode gCode v hcode + have hlift := + (eval_codeTableLookup_query_congr (codeLift dtable) + (codeLift (codeUnpair₁ (codeListLength dtable))) + (codeLift (codePartrecPayload₁ (codeUnpair₂ (codeListLength dtable)))) + (codeLift (codeConst (n := r) fCode)) (codeHead (n := r)) (y + 1) (x :> v) ?_).mp + houter + · refine + (eval_codeTableLookup_query_congr (codeLift dtable) + (codeLift (codeUnpair₁ (codeListLength dtable))) + (codeLift (codeConst (n := r) fCode)) (codeConst (n := r + 1) fCode) + (codeHead (n := r)) (y + 1) (x :> v) ?_).mp + hlift + intro z + exact eval_codeLift_codeConst_iff fCode z x v + · intro z + rw [eval_codeLift_iff, eval_codeLift_iff] + exact eval_iff_codeConst_of_eval _ fCode v (by simpa using hf) z + +/-- Reverse direction of `eval_codeEvaluatorCell_succ_of_canonicalPartrecCompIndex`, +with positive fuel as an additional hypothesis: at the canonical index of the +composition of `fCode` and `gCode`, the two component lookups give the evaluator +cell the value `y + 1`. + +The lookups are first returned to the decoded queries, and +`eval_codeCompEvaluatorCell_succ_iff` gives the composition branch the value +`y + 1`. Values of `dtable` and `dn` are read from the inner lookup, and +`eval_codeEvaluatorCell_exists_of_values` gives the entire cell some value `z`. +Positive fuel and tag `5` select the composition branch in that evaluation, so +`z = y + 1` by `eval_unique`. + +`𝐏𝐀` is the only theory assumption; `eval_codeEvaluatorCell_exists_of_values` +assumes it. `𝐈Σ 1` is installed inside the proof and supplies `𝐏𝐀⁻` through +Foundation's instance chain, and the index enters through +`ORingStructure.numeral`. -/ +theorem eval_codeEvaluatorCell_succ_of_component_lookups {M : Type*} [ORingStructure M] + [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] {r : ℕ} (dtable dn : Code r) (fCode gCode : ℕ) (x y : M) (v : Fin r → M) + (hcode : + Semiformula.Evalb + ((ORingStructure.numeral (canonicalPartrecCompIndex fCode gCode) : M) :> v) + (FFL.FirstOrder.Arithmetic.code + (codeUnpair₂ (codeListLength dtable)))) + (hfuel : + ∃ k : M, + 0 < k ∧ + Semiformula.Evalb (k :> v) + (FFL.FirstOrder.Arithmetic.code + (codeUnpair₁ (codeListLength dtable)))) + (hinner : + Semiformula.Evalb ((x + 1) :> v) + (FFL.FirstOrder.Arithmetic.code + (codeTableLookup dtable (codeUnpair₁ (codeListLength dtable)) + (codeConst (n := r) gCode) dn))) + (houter : + Semiformula.Evalb ((y + 1) :> (x :> v)) + (FFL.FirstOrder.Arithmetic.code + (codeTableLookup (codeLift dtable) (codeLift (codeUnpair₁ (codeListLength dtable))) + (codeConst (n := r + 1) fCode) (codeHead (n := r))))) : + Semiformula.Evalb ((y + 1) :> v) + (FFL.FirstOrder.Arithmetic.code + (codeEvaluatorCell dtable dn)) := by + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + simp only [numeral_eq_natCast_app] at hcode + have htag := + eval_codePartrecTag_canonicalPartrecCompIndex (codeUnpair₂ (codeListLength dtable)) fCode + gCode v hcode + have hf := + eval_codePartrecPayload₁_canonicalPartrecCompIndex (codeUnpair₂ (codeListLength dtable)) + fCode gCode v hcode + have hg := + eval_codePartrecPayload₂_canonicalPartrecCompIndex (codeUnpair₂ (codeListLength dtable)) + fCode gCode v hcode + have hinnerDecoded : + Semiformula.Evalb ((x + 1) :> v) + (code + (codeTableLookup dtable (codeUnpair₁ (codeListLength dtable)) + (codePartrecPayload₂ (codeUnpair₂ (codeListLength dtable))) dn)) := + by + refine (eval_codeTableLookup_query_congr dtable _ _ _ dn (x + 1) v ?_).mpr hinner + intro z + exact eval_iff_codeConst_of_eval _ gCode v (by simpa using hg) z + have houterLifted := + (eval_codeTableLookup_query_congr (codeLift dtable) + (codeLift (codeUnpair₁ (codeListLength dtable))) (codeLift (codeConst (n := r) fCode)) + (codeConst (n := r + 1) fCode) (codeHead (n := r)) (y + 1) (x :> v) + (fun z => eval_codeLift_codeConst_iff fCode z x v)).mpr + houter + have houterDecoded : + Semiformula.Evalb ((y + 1) :> x :> v) + (code + (codeTableLookup (codeLift dtable) (codeLift (codeUnpair₁ (codeListLength dtable))) + (codeLift (codePartrecPayload₁ (codeUnpair₂ (codeListLength dtable)))) + (codeHead (n := r)))) := + by + refine + (eval_codeTableLookup_query_congr (codeLift dtable) + (codeLift (codeUnpair₁ (codeListLength dtable))) + (codeLift (codePartrecPayload₁ (codeUnpair₂ (codeListLength dtable)))) + (codeLift (codeConst (n := r) fCode)) (codeHead (n := r)) (y + 1) (x :> v) ?_).mpr + houterLifted + intro z + rw [eval_codeLift_iff, eval_codeLift_iff] + exact eval_iff_codeConst_of_eval _ fCode v (by simpa using hf) z + have hcomp := + (eval_codeCompEvaluatorCell_succ_iff dtable (codeUnpair₁ (codeListLength dtable)) + (codePartrecPayload₁ (codeUnpair₂ (codeListLength dtable))) + (codePartrecPayload₂ (codeUnpair₂ (codeListLength dtable))) dn y v).mpr + ⟨x, hinnerDecoded, houterDecoded⟩ + -- values of `dtable` and `dn`, read from the inner lookup + have hsubArg : + ∀ (A B : Code r) (w : M), + Semiformula.Evalb (w :> v) (code (codeSub A B)) → + ∃ a : M, Semiformula.Evalb (a :> v) (code A) := + by + intro A B w h + obtain ⟨⟨b, -, hbody⟩, -⟩ := (eval_codeRfindPos_iff _ w v).mp h + obtain ⟨p, q, hp, -, -⟩ := (eval_codeOr_iff _ _ b (w :> v)).mp hbody + obtain ⟨e₁, e₂, -, he₂, -⟩ := (eval_codeEq_iff _ _ p (w :> v)).mp hp + exact ⟨e₂, (eval_codeLift_iff A e₂ w v).mp he₂⟩ + rw [codeTableLookup_eq] at hinner + obtain ⟨o, ho⟩ := hsubArg _ _ _ hinner + obtain ⟨l, hl, -⟩ := eval_codeIfPos_cases _ _ _ o v ho + rw [codeListDrop_eq_comp, eval_comp_iff] at hl + obtain ⟨w, -, hw⟩ := hl + have hindex : Semiformula.Evalb (w 0 :> v) (code dn) := hw 0 + obtain ⟨o', ho'⟩ := hsubArg _ _ _ (hw 1) + obtain ⟨l', hl', -⟩ := eval_codeIfPos_cases _ _ _ o' v ho' + rw [codeListDrop_eq_comp, eval_comp_iff] at hl' + obtain ⟨w', -, hw'⟩ := hl' + have htable : Semiformula.Evalb (w' 1 :> v) (code dtable) := + hw' + 1 + -- the entire eager cell has some value `z` + obtain ⟨z, hz⟩ := + eval_codeEvaluatorCell_exists_of_values dtable dn (w' 1) (w 0) v htable hindex + have hne54 : ¬((5 : M) = (4 : M)) := + by + have h5 : (5 : M) = (4 : M) + 1 := by norm_num + rw [h5] + exact (_root_.ne_of_lt (lt_add_one _)).symm + obtain ⟨k, hk, hkv⟩ := hfuel + have hcell := hz + simp only [codeEvaluatorCell] at hcell + obtain ⟨kf, hkf, hkcase⟩ := eval_codeIfPos_cases _ _ _ z v hcell + have hkfk : kf = k := eval_unique hkf hkv + rcases hkcase with ⟨-, hbig⟩ | ⟨hkf0, -⟩ + · obtain ⟨e4, he4, h4case⟩ := eval_codeIfPos_cases _ _ _ z v hbig + rw [eval_codeEq_iff] at he4 + obtain ⟨a4, b4, ha4, hb4, hc4⟩ := he4 + have ha45 : a4 = (5 : M) := eval_unique ha4 htag + have hb44 : b4 = (4 : M) := + by + have h := (eval_codeConst_iff 4 b4 v).mp hb4 + simpa using h + have he40 : e4 = 0 := by + rcases hc4 with ⟨heq, -⟩ | ⟨-, h0⟩ + · exact absurd (by rw [← ha45, ← hb44]; exact heq) hne54 + · exact h0 + rcases h4case with ⟨hpos, -⟩ | ⟨-, hrest⟩ + · exact absurd (he40 ▸ hpos) (_root_.lt_irrefl 0) + · obtain ⟨e5, he5, h5case⟩ := eval_codeIfPos_cases _ _ _ z v hrest + rw [eval_codeEq_iff] at he5 + obtain ⟨a5, b5, ha5, hb5, hc5⟩ := he5 + have ha55 : a5 = (5 : M) := eval_unique ha5 htag + have hb55 : b5 = (5 : M) := + by + have h := (eval_codeConst_iff 5 b5 v).mp hb5 + simpa using h + have he51 : e5 = 1 := by + rcases hc5 with ⟨-, h1⟩ | ⟨hne, -⟩ + · exact h1 + · exact absurd (by rw [ha55, hb55]) hne + rcases h5case with ⟨-, hcomp5⟩ | ⟨h0, -⟩ + · rw [eval_unique hcomp5 hcomp] at hz + exact hz + · exact absurd (he51 ▸ h0) _root_.one_ne_zero + · exact absurd (hkfk ▸ hkf0) (ne_of_gt hk) + +variable {M : Type*} [ORingStructure M] + +/-- The parity bit as a remainder. -/ +private theorem bodd_toNat_eq_mod_two (n : ℕ) : n.bodd.toNat = n % 2 := by + rw [Nat.mod_two_of_bodd] + +/-- The production tag decoder, written with remainders. -/ +private theorem partrecCodeTag_eq (q : ℕ) : + partrecCodeTag q = if q < 4 then q else 4 + 2 * ((q - 4) % 2) + Nat.div2 (q - 4) % 2 := by + simp only [partrecCodeTag, bodd_toNat_eq_mod_two] + +/-- The constructor number of a standard index, read inside a model. -/ +private theorem eval_codePartrecTag_natCast [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) + (v : Fin r → M) (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : + Semiformula.Evalb (((partrecCodeTag q : ℕ) : M) :> v) (code (codePartrecTag d)) := + by + have h4 : Semiformula.Evalb (((4 : ℕ) : M) :> v) (code (codeConst (n := r) 4)) := + eval_codeConst 4 v + have h2 : Semiformula.Evalb (((2 : ℕ) : M) :> v) (code (codeConst (n := r) 2)) := + eval_codeConst 2 v + have hrr := eval_codeSub_natCast d (codeConst 4) q 4 v hd (by simpa using h4) + have hbodd0 := eval_codeBodd_natCast (codeSub d (codeConst 4)) (q - 4) v hrr + have hbodd1 := + eval_codeBodd_natCast (codeDiv2 (codeSub d (codeConst 4))) (Nat.div2 (q - 4)) v + (eval_codeDiv2_natCast _ (q - 4) v hrr) + have hmul : + Semiformula.Evalb ((((2 * ((q - 4) % 2) : ℕ)) : M) :> v) + (code (codeMul (codeConst 2) (codeBodd (codeSub d (codeConst 4))))) := + by + refine (eval_codeMul_iff _ _ _ v).mpr ⟨_, _, h2, hbodd0, ?_⟩ + push_cast + norm_num + have hadd1 : + Semiformula.Evalb ((((4 + 2 * ((q - 4) % 2) : ℕ)) : M) :> v) + (code + (codeAdd (codeConst 4) (codeMul (codeConst 2) (codeBodd (codeSub d (codeConst 4)))))) := + by + refine (eval_codeAdd_iff _ _ _ v).mpr ⟨_, _, h4, hmul, ?_⟩ + push_cast + norm_num + have hbig : + Semiformula.Evalb ((((4 + 2 * ((q - 4) % 2) + Nat.div2 (q - 4) % 2 : ℕ)) : M) :> v) + (code + (codeAdd + (codeAdd (codeConst 4) (codeMul (codeConst 2) (codeBodd (codeSub d (codeConst 4))))) + (codeBodd (codeDiv2 (codeSub d (codeConst 4)))))) := + by + refine (eval_codeAdd_iff _ _ _ v).mpr ⟨_, _, hadd1, hbodd1, ?_⟩ + push_cast + norm_num + rw [partrecCodeTag_eq] + simp only [codePartrecTag] + by_cases hq : q < 4 + · have hlt1 : Semiformula.Evalb ((1 : M) :> v) (code (codeLt d (codeConst 4))) := + by + refine (eval_codeLt_iff _ _ _ v).mpr ⟨_, _, hd, by simpa using h4, Or.inl ⟨?_, rfl⟩⟩ + exact_mod_cast hq + rw [ite_eq_left hq] + exact + eval_codeIfPos_of _ _ _ (1 : M) (((q : ℕ)) : M) _ _ v hlt1 hd hbig + (Or.inl ⟨_root_.zero_lt_one, rfl⟩) + · have hlt0 : Semiformula.Evalb ((0 : M) :> v) (code (codeLt d (codeConst 4))) := + by + refine (eval_codeLt_iff _ _ _ v).mpr ⟨_, _, hd, by simpa using h4, Or.inr ⟨?_, rfl⟩⟩ + intro hc + exact hq (by exact_mod_cast hc) + rw [ite_eq_right hq] + exact eval_codeIfPos_of _ _ _ (0 : M) (((q : ℕ)) : M) _ _ v hlt0 hd hbig (Or.inr ⟨rfl, rfl⟩) + +/-- The payload of a standard compound index, read inside a model. -/ +private theorem eval_codePartrecPayload_natCast [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) + (v : Fin r → M) (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : + Semiformula.Evalb (((partrecCodePayload q : ℕ) : M) :> v) (code (codePartrecPayload d)) := + by + have h4 : Semiformula.Evalb (((4 : ℕ) : M) :> v) (code (codeConst (n := r) 4)) := + eval_codeConst 4 v + have hrr := eval_codeSub_natCast d (codeConst 4) q 4 v hd (by simpa using h4) + simpa only [codePartrecPayload, partrecCodePayload] using + eval_codeDiv2_natCast _ _ v (eval_codeDiv2_natCast _ (q - 4) v hrr) + +/-- The first subcode of a standard index, read inside a model. -/ +private theorem eval_codePartrecPayload₁_natCast [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) + (v : Fin r → M) (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : + Semiformula.Evalb (((partrecCodePayload₁ q : ℕ) : M) :> v) (code (codePartrecPayload₁ d)) := + eval_codeUnpair₁_natCast (codePartrecPayload d) _ v (eval_codePartrecPayload_natCast d q v hd) + +/-- The second subcode of a standard index, read inside a model. -/ +private theorem eval_codePartrecPayload₂_natCast [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) + (v : Fin r → M) (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : + Semiformula.Evalb (((partrecCodePayload₂ q : ℕ) : M) :> v) (code (codePartrecPayload₂ d)) := + eval_codeUnpair₂_natCast (codePartrecPayload d) _ v (eval_codePartrecPayload_natCast d q v hd) + +/-- A successful evaluator cell whose constructor number is `4` is the value of +the pairing branch. Adapted from the accepted external tag-4 probe. -/ +private theorem cell_pair_branch [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (dtable dn : Code r) (v : Fin r → M) + (z k tag : M) (hk : Semiformula.Evalb (k :> v) (code (codeUnpair₁ (codeListLength dtable)))) + (hkpos : 0 < k) + (htag : + Semiformula.Evalb (tag :> v) + (code (codePartrecTag (codeUnpair₂ (codeListLength dtable))))) + (h4 : tag = ((4 : ℕ) : M)) + (hcell : Semiformula.Evalb (z :> v) (code (codeEvaluatorCell dtable dn))) : + Semiformula.Evalb (z :> v) + (code + (codePairEvaluatorCell dtable (codeUnpair₁ (codeListLength dtable)) + (codePartrecPayload₁ (codeUnpair₂ (codeListLength dtable))) + (codePartrecPayload₂ (codeUnpair₂ (codeListLength dtable))) dn)) := + by + have hc : + ∀ (m : ℕ) (w : Fin r → M), + Semiformula.Evalb (((m : ℕ) : M) :> w) (code (codeConst (n := r) m)) := + fun m w => eval_codeConst m w + have hval : + ∀ (m : ℕ) (x : M), + Semiformula.Evalb (x :> v) (code (codeConst (n := r) m)) → x = ((m : ℕ) : M) := + fun m x hx => eval_unique hx (hc m v) + simp only [codeEvaluatorCell] at hcell + obtain ⟨f0, hf0, hc0⟩ := eval_codeIfPos_cases _ _ _ z v hcell + have hf0k : f0 = k := eval_unique hf0 hk + rcases hc0 with ⟨-, hbig⟩ | ⟨h0, -⟩ + swap + · exact absurd (hf0k ▸ h0 : k = 0) (ne_of_gt hkpos) + obtain ⟨e4, he4, hcase4⟩ := eval_codeIfPos_cases _ _ _ z v hbig + rw [eval_codeEq_iff] at he4 + obtain ⟨x, y, hx, hy, hxy⟩ := he4 + have hxt : x = tag := eval_unique hx htag + have hy4 : y = ((4 : ℕ) : M) := hval 4 y hy + have he41 : e4 = 1 := by + rcases hxy with ⟨-, h1⟩ | ⟨hne, -⟩ + · exact h1 + · exact absurd (by rw [hxt, hy4]; exact h4) hne + rcases hcase4 with ⟨-, hpair⟩ | ⟨h0, -⟩ + · exact hpair + · exact absurd (he41 ▸ h0 : (1 : M) = 0) _root_.one_ne_zero + +/-- Fixed component lookups build the whole pairing cell. + +For a standard index `q` of constructor number `4`, two successful component +lookups at the constant codes of its two subcodes — both at the same fuel and the +same argument, as pairing requires — give the entire eager evaluator cell the +value `pair a b + 1`. Nothing about the cell's own success is assumed. -/ +theorem eval_codeEvaluatorCell_succ_of_pair_component_lookups [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + {r : ℕ} (dtable dn : Code r) (q : ℕ) (htagq : partrecCodeTag q = 4) (a b : M) + (v : Fin r → M) + (hcode : + Semiformula.Evalb (((q : ℕ) : M) :> v) (code (codeUnpair₂ (codeListLength dtable)))) + (hfuel : + ∃ k : M, 0 < k ∧ Semiformula.Evalb (k :> v) (code (codeUnpair₁ (codeListLength dtable)))) + (hfirst : + Semiformula.Evalb ((a + 1) :> v) + (code + (codeTableLookup dtable (codeUnpair₁ (codeListLength dtable)) + (codeConst (n := r) (partrecCodePayload₁ q)) dn))) + (hsecond : + Semiformula.Evalb ((b + 1) :> v) + (code + (codeTableLookup dtable (codeUnpair₁ (codeListLength dtable)) + (codeConst (n := r) (partrecCodePayload₂ q)) dn))) : + Semiformula.Evalb + ((FFL.FirstOrder.Arithmetic.pair a b + 1) :> v) + (code (codeEvaluatorCell dtable dn)) := by + let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := + models_of_subtheory + (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + -- the decoded readings of the standard index + have htag := eval_codePartrecTag_natCast (codeUnpair₂ (codeListLength dtable)) q v hcode + rw [htagq] at htag + have hp₁ := eval_codePartrecPayload₁_natCast (codeUnpair₂ (codeListLength dtable)) q v hcode + have hp₂ := eval_codePartrecPayload₂_natCast (codeUnpair₂ (codeListLength dtable)) q v hcode + have hfirstD : + Semiformula.Evalb ((a + 1) :> v) + (code + (codeTableLookup dtable (codeUnpair₁ (codeListLength dtable)) + (codePartrecPayload₁ (codeUnpair₂ (codeListLength dtable))) dn)) := + by + refine (eval_codeTableLookup_query_congr dtable _ _ _ dn (a + 1) v ?_).mpr hfirst + intro z + exact eval_iff_codeConst_of_eval _ (partrecCodePayload₁ q) v hp₁ z + have hsecondD : + Semiformula.Evalb ((b + 1) :> v) + (code + (codeTableLookup dtable (codeUnpair₁ (codeListLength dtable)) + (codePartrecPayload₂ (codeUnpair₂ (codeListLength dtable))) dn)) := + by + refine (eval_codeTableLookup_query_congr dtable _ _ _ dn (b + 1) v ?_).mpr hsecond + intro z + exact eval_iff_codeConst_of_eval _ (partrecCodePayload₂ q) v hp₂ z + have hsecondL : + Semiformula.Evalb ((b + 1) :> a :> v) + (code + (codeTableLookup (codeLift dtable) (codeLift (codeUnpair₁ (codeListLength dtable))) + (codeLift (codePartrecPayload₂ (codeUnpair₂ (codeListLength dtable)))) + (codeLift dn))) := + (eval_codeTableLookup_congr_at (codeLift dtable) + (codeLift (codeUnpair₁ (codeListLength dtable))) + (codeLift (codePartrecPayload₂ (codeUnpair₂ (codeListLength dtable)))) (codeLift dn) + dtable (codeUnpair₁ (codeListLength dtable)) + (codePartrecPayload₂ (codeUnpair₂ (codeListLength dtable))) dn (b + 1) (a :> v) v + (fun z => eval_codeLift_iff _ z a v) (fun z => eval_codeLift_iff _ z a v) + (fun z => eval_codeLift_iff _ z a v) (fun z => eval_codeLift_iff _ z a v)).mpr + hsecondD + have hpair := + (eval_codePairEvaluatorCell_succ_iff dtable (codeUnpair₁ (codeListLength dtable)) + (codePartrecPayload₁ (codeUnpair₂ (codeListLength dtable))) + (codePartrecPayload₂ (codeUnpair₂ (codeListLength dtable))) dn + (FFL.FirstOrder.Arithmetic.pair a b) v).mpr + ⟨a, b, hfirstD, hsecondL, rfl⟩ + -- values for the table and the argument code, read off a component lookup + have hsubArg : + ∀ (A B : Code r) (w : M), + Semiformula.Evalb (w :> v) (code (codeSub A B)) → + ∃ x : M, Semiformula.Evalb (x :> v) (code A) := + by + intro A B w h + obtain ⟨⟨c, -, hbody⟩, -⟩ := (eval_codeRfindPos_iff _ w v).mp h + obtain ⟨p, s, hp, -, -⟩ := (eval_codeOr_iff _ _ c (w :> v)).mp hbody + obtain ⟨e₁, e₂, -, he₂, -⟩ := (eval_codeEq_iff _ _ p (w :> v)).mp hp + exact ⟨e₂, (eval_codeLift_iff A e₂ w v).mp he₂⟩ + have hfirstRaw := hfirst + rw [codeTableLookup_eq] at hfirstRaw + obtain ⟨o, ho⟩ := hsubArg _ _ _ hfirstRaw + obtain ⟨l, hl, -⟩ := eval_codeIfPos_cases _ _ _ o v ho + rw [codeListDrop_eq_comp, eval_comp_iff] at hl + obtain ⟨w, -, hw⟩ := hl + have hindex : Semiformula.Evalb (w 0 :> v) (code dn) := hw 0 + obtain ⟨o', ho'⟩ := hsubArg _ _ _ (hw 1) + obtain ⟨l', hl', -⟩ := eval_codeIfPos_cases _ _ _ o' v ho' + rw [codeListDrop_eq_comp, eval_comp_iff] at hl' + obtain ⟨w', -, hw'⟩ := hl' + have htable : Semiformula.Evalb (w' 1 :> v) (code dtable) := + hw' + 1 + -- the eager whole cell has some value, forced into the pairing branch + obtain ⟨z, hz⟩ := + eval_codeEvaluatorCell_exists_of_values dtable dn (w' 1) (w 0) v htable hindex + obtain ⟨k, hkpos, hkv⟩ := hfuel + have hbranch := + cell_pair_branch dtable dn v z k (((4 : ℕ) : M)) hkv hkpos (by simpa using htag) rfl hz + rw [eval_unique hbranch hpair] at hz + exact hz + +end Evaluator +end CategoricalRiceShapiro + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/CompositionPersistence.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/CompositionPersistence.lean new file mode 100644 index 000000000..0f7aef79f --- /dev/null +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/CompositionPersistence.lean @@ -0,0 +1,139 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.Certificate + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# The tag-5 induction case of certificate persistence + +Constructor number `5` is composition. +`evalnCertificateFormula_natCode_persist_of_tag_five` concerns a standard index `q` with +`partrecCodeTag q = 5`. It proves that the raw evaluator certificate for `q` persists from a +stage `s` to every stage `t ≥ s`, assuming the same persistence for every standard index +`p < q`, whatever the constructor number of `p`. The theory assumptions are `𝐏𝐀` and +`𝐈𝐎𝐩𝐞𝐧`. + +A private helper rewrites `q` as the canonical composition index +`canonicalPartrecCompIndex (partrecCodePayload₁ q) (partrecCodePayload₂ q)`, relating +`bodd.toNat` to `% 2` through `Nat.mod_two_of_bodd`; a second helper places both payloads +strictly below `q`. At that index, `evalnCertificateFormula_canonicalPartrecCompIndex_forward` +reduces the certificate at stage `s` to an inner certificate for the second payload and an +outer certificate for the first. The induction hypothesis gives both at stage `t`, and +`evalnCertificateFormula_canonicalPartrecCompIndex_reverse` reconstructs the certificate for +the canonical index at stage `t`. + +The file states one induction case. It proves neither the cases for the other constructor +numbers nor persistence for all standard indices. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +open scoped FFL.FirstOrder.Arithmetic + +open CategoricalRiceShapiro.ArithmeticCode + +open CategoricalRiceShapiro.PartialRecursive + +namespace CategoricalRiceShapiro +namespace Evaluator + +variable {M : Type*} [ORingStructure M] + +/-- A standard index of constructor number `5` is the canonical composition +index of its two payloads. `bodd.toNat` and `% 2` are related by +`Nat.mod_two_of_bodd`, not assumed definitionally equal. -/ +private theorem tagFive_canonical_reencoding (q : ℕ) (hq : partrecCodeTag q = 5) : + q = canonicalPartrecCompIndex (partrecCodePayload₁ q) (partrecCodePayload₂ q) := + by + have hb : ∀ n : ℕ, n.bodd.toNat = n % 2 := fun n => by rw [Nat.mod_two_of_bodd] + have h4 : ¬q < 4 := by + intro hlt + simp only [partrecCodeTag, hlt, ite_true] at hq + omega + simp only [partrecCodeTag, h4, ite_false, hb, Nat.div2_val] at hq + rw [canonicalPartrecCompIndex_eq] + simp only [partrecCodePayload₁, partrecCodePayload₂, Nat.pair_unpair, partrecCodePayload, + Nat.div2_val] + omega + +/-- Both payloads of a standard index of constructor number `5` lie strictly +below it. -/ +private theorem tagFive_payloads_lt (q : ℕ) (hq : partrecCodeTag q = 5) : + partrecCodePayload₁ q < q ∧ partrecCodePayload₂ q < q := + by + have hindex := tagFive_canonical_reencoding q hq + have houter := + canonicalPartrecCompIndex_outer_lt (partrecCodePayload₁ q) (partrecCodePayload₂ q) + have hinner := + canonicalPartrecCompIndex_inner_lt (partrecCodePayload₁ q) (partrecCodePayload₂ q) + rw [← hindex] at houter hinner + exact ⟨houter, hinner⟩ + +/-- **Tag-5 induction case of certificate persistence.** For a standard index +`q` of constructor number `5`, persistence of the certificate for `q` from stage +`s` to any later stage `t` follows from persistence for every strictly smaller +standard index, whatever its constructor number. -/ +theorem evalnCertificateFormula_natCode_persist_of_tag_five [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + (q : ℕ) (hq : partrecCodeTag q = 5) + (ih : + ∀ p : ℕ, + p < q → + ∀ s t u y : M, + s ≤ t → + Semiformula.Evalb ![s, ((p : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) → + Semiformula.Evalb ![t, ((p : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4)) : + ∀ s t u y : M, + s ≤ t → + Semiformula.Evalb ![s, ((q : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) → + Semiformula.Evalb ![t, ((q : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) := by + intro s t u y hst source_certificate + have hindex := tagFive_canonical_reencoding q hq + obtain ⟨payload₁_lt, payload₂_lt⟩ := tagFive_payloads_lt q hq + have source_canonical : + Semiformula.Evalb + ![s, + (ORingStructure.numeral + (canonicalPartrecCompIndex (partrecCodePayload₁ q) (partrecCodePayload₂ q)) : + M), + u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) := + by + rw [numeral_eq_natCast_app, ← hindex] + exact source_certificate + obtain ⟨x, inner_at_s, outer_at_s⟩ := + evalnCertificateFormula_canonicalPartrecCompIndex_forward s u y (partrecCodePayload₁ q) + (partrecCodePayload₂ q) source_canonical + rw [numeral_eq_natCast_app] at inner_at_s outer_at_s + have inner_at_t := ih (partrecCodePayload₂ q) payload₂_lt s t u x hst inner_at_s + have outer_at_t := ih (partrecCodePayload₁ q) payload₁_lt s t x y hst outer_at_s + have target_canonical := + evalnCertificateFormula_canonicalPartrecCompIndex_reverse t u x y (partrecCodePayload₁ q) + (partrecCodePayload₂ q) (by rw [numeral_eq_natCast_app]; exact inner_at_t) + (by rw [numeral_eq_natCast_app]; exact outer_at_t) + -- (6) back from the canonical composition index to `q` + rw [numeral_eq_natCast_app, ← hindex] at target_canonical + exact target_canonical + +end Evaluator +end CategoricalRiceShapiro + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/History.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/History.lean new file mode 100644 index 000000000..132962682 --- /dev/null +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/History.lean @@ -0,0 +1,98 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.Cell + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# The evaluator-history codes + +The evaluation table is extended one row at a time. `codeEvaluatorRow` builds +the row of a table by primitive recursion on the fuel read from the table +length, `codeEvaluatorTableStep` appends that row, and `codeEvaluatorHistory` +iterates the step from the empty table. `codeHistoryEvaluator` looks one entry +up in the history one step past the pair of its first two arguments, and +`codeEvaluatorHistoryBeforeCell` names the history one step earlier. + +Only the code constructions are given here. The standard computation theorems +over the natural numbers are not part of this migration, and no arithmetic +property of the encoding is asserted. +-/ + +@[expose] public section + +open _root_.Nat Nat Nat.ArithPart₁ + +namespace CategoricalRiceShapiro +namespace Evaluator + +open CategoricalRiceShapiro.ArithmeticCode + +/-- The recursion that builds one row of the evaluation table: at recursion +argument `i` the cell at index `k - (i + 1)` is consed onto the row built so +far, where `k` is the fuel read from the table length. -/ +def codeEvaluatorRowCore {r : ℕ} (dtable : Code r) : Code (r + 1) := + codePrec (codeListNil (n := r)) + (codeListCons + (codeEvaluatorCell (codeLift (codeLift dtable)) + (codeSub (codeUnpair₁ (codeListLength (codeLift (codeLift dtable)))) + (codeSucc (Code.proj (0 : Fin (r + 2)))))) + (Code.proj (1 : Fin (r + 2)))) + +/-- One row of the evaluation table of `dtable`. -/ +def codeEvaluatorRow {r : ℕ} (dtable : Code r) : Code r := + codeBind (codeUnpair₁ (codeListLength dtable)) (codeEvaluatorRowCore dtable) + +/-- `codeEvaluatorRow` binds the fuel read from the table length as the +recursion argument of one fixed arity-`r + 1` code. + +The recursion is an implementation detail and stays private; a proof reaches it +by rewriting with this equation. -/ +theorem codeEvaluatorRow_eq_bind {r : ℕ} (dtable : Code r) : + codeEvaluatorRow dtable = + codeBind (codeUnpair₁ (codeListLength dtable)) + (codePrec (codeListNil (n := r)) + (codeListCons + (codeEvaluatorCell (codeLift (codeLift dtable)) + (codeSub (codeUnpair₁ (codeListLength (codeLift (codeLift dtable)))) + (codeSucc (Code.proj (0 : Fin (r + 2)))))) + (Code.proj (1 : Fin (r + 2))))) := + rfl + +/-- Extend the evaluation table by one row. -/ +def codeEvaluatorTableStep {r : ℕ} (dtable : Code r) : Code r := + codeListSnoc dtable (codeEvaluatorRow dtable) + +/-- The evaluation table after the number of steps given by the argument. -/ +def codeEvaluatorHistory : Code 1 := + codePrec (codeListNil (n := 0)) (codeEvaluatorTableStep (Code.proj (1 : Fin 2))) + +/-- The evaluation history one step before the one `codeHistoryEvaluator` +reads: the history at the pair of the first two arguments. -/ +def codeEvaluatorHistoryBeforeCell : Code 3 := + codeEvaluatorHistory.comp ![codePair (Code.proj (0 : Fin 3)) (Code.proj (1 : Fin 3))] + +/-- Look up entry `n` of the row of `k` and `q` in the history one step past +the pair of `k` and `q`. -/ +def codeHistoryEvaluator : Code 3 := + codeTableLookup + (codeEvaluatorHistory.comp + ![codeSucc (codePair (Code.proj (0 : Fin 3)) (Code.proj (1 : Fin 3)))]) + (Code.proj (0 : Fin 3)) (Code.proj (1 : Fin 3)) (Code.proj (2 : Fin 3)) + +end Evaluator +end CategoricalRiceShapiro + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/HistoryEvaluation.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/HistoryEvaluation.lean new file mode 100644 index 000000000..690e1374d --- /dev/null +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/HistoryEvaluation.lean @@ -0,0 +1,2860 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.History +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.RecursionEvaluation +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.CellCongruence +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.CellEvaluation + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# The length of a constructed evaluation history + +Except in the results described in the paragraphs below, every length +evaluation here is either supplied by a premise or reassembled from drop +evaluations supplied by premises. `length_of_drops` constructs only +the `codeRfindPos` presentation from those existing drop witnesses; it +constructs no drop evaluation, and the uniqueness result only identifies the +value of a supplied length evaluation. + +Four results are of the opposite kind, and each asserts totality over `𝐏𝐀`. +`eval_codeEvaluatorRow_exists_of_value` gives the row of a table a value at any +value of the table. `eval_codeEvaluatorTableStep_exists_of_value` composes that +row totality with `eval_codeListSnoc_exists_of_values`, giving the extended table +a value. `eval_codeEvaluatorHistory_exists` gives the history a value at every +stage, without a premise. `eval_codeHistoryEvaluator_exists` gives the lookup +in the history one step past the pair of the first two arguments a value at +every argument triple, composing history totality with +`eval_codeTableLookup_exists_of_values`. The row and history results are the +only results here that directly use the generic existence theorem for +`codePrec`. + +Four generic readings, over `𝐏𝐀` and `𝐈𝐎𝐩𝐞𝐧`, identify the arguments that the +evaluator cell reads at an arbitrary argument triple `s, qCode, u`. +`eval_codeEvaluatorHistoryBeforeCell_exists` is a further totality result, +derived from `eval_codeEvaluatorHistory_exists`: it gives +`codeEvaluatorHistoryBeforeCell` a value and identifies it with the history at +`pair s qCode`. `eval_codeEvaluatorHistoryBeforeCell_length` proves that the +length of that history is `pair s qCode`, using +`eval_codeEvaluatorHistory_length_unique`. `eval_codeEvaluatorCell_fuel` and +`eval_codeEvaluatorCell_index` read the two components of that length as `s` and +`qCode`. None of the four depends on the constructor number of `qCode`. + +Two results relate a `codeHistoryEvaluator` evaluation at an earlier stage to a +lookup of the same row in the history at a later stage. +`eval_codeHistoryEvaluator_succ_of_prefix_lookup` derives the earlier +evaluation from the later lookup: it descends one stage at a time with +`getAt_step_down`, and every history evaluation it uses is supplied. +`eval_prefix_lookup_succ_of_codeHistoryEvaluator` derives the later lookup from +the earlier evaluation: it ascends one stage at a time with `getAt_step_up`, +which shows that the snoc step preserves an entry below the last row. History +totality gives each later stage a value, and +`eval_codeListLength_exists_of_value` gives the extended histories their +lengths. + +`eval_codeTableLookup_succ_iff_codeHistoryEvaluator_of_history` is the +earlier-row bridge. For a history `H` evaluated at a row count `N`, a stage `k` +and a standard index `q` with `pair k q < N`, a successful lookup in `H` at +`k`, `q` and an input `u` is exactly a successful `codeHistoryEvaluator` +evaluation at `k`, `q`, `u`. Every code is supplied with its value, and the +proof uses no certificate persistence: it descends with `getAt_descend` and +ascends with `getAt_step_up`. `input_lt_of_codeTableLookup_succ_of_history` +derives `u < k` from such a lookup, and +`eval_predecessor_lookup_succ_iff_codeHistoryEvaluator` specializes the bridge +to the history before the cell at `k + 1, q`, read at the decremented stage +`k`. + +`eval_codeHistoryEvaluator_succ_iff_cell` characterizes a successful lookup: +`codeHistoryEvaluator` has a successor value at `s, qCode, u` exactly when +`u < s` and the evaluator cell of the history one step earlier has that value +at index `u`. The bound is strict because the row appended at the pair of `s` +and `qCode` holds the cells at the indices below `s`; the row recursion also +evaluates its step at the terminal index, but that value is not part of the +row. The forward direction is the extraction argument of +`eval_codeHistoryEvaluator_succ_extract_cell`. The reverse direction +constructs the eager row and the history that appends it, using +`eval_codeEvaluatorHistory_exists` and `eval_codeListLength_exists_of_value`, +and locates the supplied cell in them with `chain_match`. +-/ + +@[expose] public section + +open _root_.Nat Nat Nat.ArithPart₁ + +namespace CategoricalRiceShapiro +namespace Evaluator + +open CategoricalRiceShapiro.ArithmeticCode + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +open scoped FFL.FirstOrder.Arithmetic + +open HierarchySymbol + +variable {M : Type*} [ORingStructure M] + +/-- The iterated-tail recursion that `codeListDrop` applies to its index and +its list. -/ +private def dropCore : Code 2 := + codePrec (Code.proj (0 : Fin 1)) (codeListTail (Code.proj (1 : Fin 3))) + +/-- `codeListDrop` applies `dropCore` to its two arguments. -/ +private theorem codeListDrop_eq_dropCore {n : ℕ} (dlist didx : Code n) : + codeListDrop dlist didx = dropCore.comp ![didx, dlist] := + rfl + +/-- The graph of a code is a Sigma-one relation of the whole assignment. -/ +private theorem definable_code_graph {m : ℕ} (A : Code m) : + Σ-[1].Definable (fun w : Fin (m + 1) → M => Semiformula.Evalb w (code A)) := + by + refine + ⟨HierarchySymbol.Semiformula.mkSigma + ((Rew.emb : Rew ℒₒᵣ Empty (m + 1) M (m + 1)) ▹ (code A)) + (Hierarchy.rew _ (code_sigma_one A)), + ?_⟩ + intro w + simp + +/-! +### Reading a supplied length evaluation -/ + +/-- A supplied length evaluation exhibits the drop of the list at its own value +as zero, and every earlier drop as nonzero. -/ +private theorem drops_of_length [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (X : Code r) (Hv n : M) (v : Fin r → M) + (hX : Semiformula.Evalb (Hv :> v) (code X)) + (hlen : Semiformula.Evalb (n :> v) (code (codeListLength X))) : + Semiformula.Evalb ((0 : M) :> n :> ![Hv]) (code dropCore) ∧ + ∀ t : M, t < n → ∃ e : M, e ≠ 0 ∧ Semiformula.Evalb (e :> t :> ![Hv]) (code dropCore) := + by + have harg : + ∀ t z : M, + Semiformula.Evalb (z :> t :> v) (code (codeListDrop (codeLift X) (codeHead (n := r)))) → + Semiformula.Evalb (z :> t :> ![Hv]) (code dropCore) := + by + intro t z hz + rw [codeListDrop_eq_dropCore, eval_comp_iff] at hz + obtain ⟨w, hw, hwi⟩ := hz + have h0 : w 0 = t := by + have := hwi 0 + simp only [Matrix.cons_val_zero] at this + exact eval_unique this ((eval_codeHead_iff _ _).mpr rfl) + have h1 : w 1 = Hv := by + have := hwi 1 + simp only [Matrix.cons_val_one] at this + exact eval_unique this ((eval_codeLift_iff X _ _ v).mpr hX) + have hshape : w = (t :> ![Hv]) := by + funext j + refine Fin.cases ?_ ?_ j + · simpa using h0 + · intro j' + refine Fin.cases ?_ (fun j'' => Fin.elim0 j'') j' + simpa using h1 + rw [hshape] at hw + exact hw + rw [codeListLength, eval_codeRfindPos_iff] at hlen + obtain ⟨⟨y, hy, hbody⟩, hmin⟩ := hlen + constructor + · rw [eval_codeInv_iff] at hbody + obtain ⟨e, he, hcase⟩ := hbody + rcases hcase with ⟨he0, -⟩ | ⟨-, hy0⟩ + · exact harg n 0 (he0 ▸ he) + · exact absurd hy0 (ne_of_gt hy) + · intro t ht + have hb := hmin t ht + rw [eval_codeInv_iff] at hb + obtain ⟨e, he, hcase⟩ := hb + rcases hcase with ⟨-, h01⟩ | ⟨hne, -⟩ + · exact absurd h01.symm _root_.one_ne_zero + · exact ⟨e, hne, harg t e he⟩ + +/-! +### The cons layer and the iterated tail -/ + +/-- Both arguments of a successfully evaluated `codePair` have values. -/ +private theorem codePair_args [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (A B : Code r) (p : M) (v : Fin r → M) + (h : Semiformula.Evalb (p :> v) (code (codePair A B))) : + ∃ a b : M, Semiformula.Evalb (a :> v) (code A) ∧ Semiformula.Evalb (b :> v) (code B) := + by + rw [codePair] at h + obtain ⟨f, hf, -⟩ := eval_codeIfPos_cases _ _ _ _ _ h + rw [eval_codeLt_iff] at hf + obtain ⟨a, b, ha, hb, -⟩ := hf + exact ⟨a, b, ha, hb⟩ + +/-- A successfully evaluated cons is the successor of the pair of two values +that its argument codes take. -/ +private theorem codeListCons_args [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] {r : ℕ} (A B : Code r) (c : M) + (v : Fin r → M) (h : Semiformula.Evalb (c :> v) (code (codeListCons A B))) : + ∃ a b : M, + Semiformula.Evalb (a :> v) (code A) ∧ + Semiformula.Evalb (b :> v) (code B) ∧ c = FFL.FirstOrder.Arithmetic.pair a b + 1 := + by + rw [codeListCons, eval_codeSucc_iff] at h + obtain ⟨p, hp, hc⟩ := h + obtain ⟨a, b, ha, hb⟩ := codePair_args A B p v hp + exact ⟨a, b, ha, hb, by rw [hc, eval_unique hp (eval_codePair A B a b v ha hb)]⟩ + +/-- A successfully evaluated cons is nonzero. -/ +private theorem codeListCons_ne_zero [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (A B : Code r) (c : M) + (v : Fin r → M) (h : Semiformula.Evalb (c :> v) (code (codeListCons A B))) : c ≠ 0 := + by + rw [codeListCons, eval_codeSucc_iff] at h + obtain ⟨p, -, hc⟩ := h + rw [hc] + exact fun hcon => (zero_ne_add_one p) hcon.symm + +/-- The tail of a value known to be a successor of a pair is the pair's second +component. -/ +private theorem eval_tail_of_pair_succ [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] {r : ℕ} (d : Code r) (w x l z : M) + (v : Fin r → M) (hw : Semiformula.Evalb (w :> v) (code d)) + (hwv : w = FFL.FirstOrder.Arithmetic.pair x l + 1) + (hz : Semiformula.Evalb (z :> v) (code (codeListTail d))) : z = l := + by + have hone : Semiformula.Evalb ((1 : M) :> v) (code (codeConst (n := r) 1)) := by + rw [eval_codeConst_iff]; simp + have hsub := eval_codeSub d (codeConst 1) w 1 v hw hone + rw [hwv, add_sub_self] at hsub + have hu := + eval_codeUnpair₂ (codeSub d (codeConst 1)) (FFL.FirstOrder.Arithmetic.pair x l) v hsub + rw [FFL.FirstOrder.Arithmetic.pi₂_pair] at hu + exact eval_unique hz (by rw [codeListTail]; exact hu) + +/-! +### The iterated tail of a fixed list -/ + +/-- Dropping no entries returns the list. -/ +private theorem dropCore_zero [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] (Hv z : M) + (h : Semiformula.Evalb (z :> (0 : M) :> ![Hv]) (code dropCore)) : z = Hv := + by + have h0 := + eval_codePrec_zero (Code.proj (0 : Fin 1)) (codeListTail (Code.proj (1 : Fin 3))) z ![Hv] h + simpa using (eval_proj_iff (0 : Fin 1) z ![Hv]).mp h0 + +/-- Dropping one more entry takes the tail of the previous drop. -/ +private theorem dropCore_succ [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] (Hv t z : M) + (h : Semiformula.Evalb (z :> (t + 1) :> ![Hv]) (code dropCore)) : + ∃ w : M, + Semiformula.Evalb (w :> t :> ![Hv]) (code dropCore) ∧ + Semiformula.Evalb (z :> t :> w :> ![Hv]) + (code (codeListTail (Code.proj (1 : Fin 3)))) := + eval_codePrec_succ (Code.proj (0 : Fin 1)) (codeListTail (Code.proj (1 : Fin 3))) t z ![Hv] h + +/-! +### The recursion that appends one row -/ + +/-- The recursion inside the table step of `codeEvaluatorHistory`, written out. +The private core of `codeListSnoc` is reached through its public equation. -/ +private def historySnocCore : Code 3 := + codePrec (codeListCons (codeEvaluatorRow (Code.proj (1 : Fin 2))) (codeListNil (n := 2))) + (codeListCons + (codeSub + (codeListGetOptional (codeLift (codeLift (Code.proj (1 : Fin 2)))) + (codeSub (codeListLength (codeLift (codeLift (Code.proj (1 : Fin 2))))) + (codeSucc (Code.proj (0 : Fin 4))))) + (codeConst 1)) + (Code.proj (1 : Fin 4))) + +/-- The table step binds the length of the previous history as the recursion +argument of `historySnocCore`. -/ +private theorem codeEvaluatorTableStep_eq : + codeEvaluatorTableStep (Code.proj (1 : Fin 2)) = + codeBind (codeListLength (Code.proj (1 : Fin 2))) historySnocCore := + by + rw [codeEvaluatorTableStep, codeListSnoc_eq_bind] + rfl + +/-- `historySnocCore` written out as a primitive recursion, so that the +recursion eliminators apply without unfolding the definition. -/ +private theorem historySnocCore_eq : + historySnocCore = + codePrec (codeListCons (codeEvaluatorRow (Code.proj (1 : Fin 2))) (codeListNil (n := 2))) + (codeListCons + (codeSub + (codeListGetOptional (codeLift (codeLift (Code.proj (1 : Fin 2)))) + (codeSub (codeListLength (codeLift (codeLift (Code.proj (1 : Fin 2))))) + (codeSucc (Code.proj (0 : Fin 4))))) + (codeConst 1)) + (Code.proj (1 : Fin 4))) := + rfl + +/-! +### Matching the append recursion against the iterated tail -/ + +/-- The matching condition between the append recursion and the iterated tail, +as a Sigma-one condition on the drop index. -/ +private theorem definable_match (Pc : Code 3) (w₀ w₁ b H bound : M) : + Σ-[1].DefinablePred + (fun i : M => + i ≤ b → + i ≤ bound → + ∃ a p : M, + a + i = b ∧ + Semiformula.Evalb ![p, a, w₀, w₁] (code Pc) ∧ + Semiformula.Evalb ![p, i, H] (code dropCore)) := by + have hS : + Σ-[1].Definable (fun w : Fin 3 → M => Semiformula.Evalb ![w 0, w 1, w₀, w₁] (code Pc)) := + by + refine + ((definable_code_graph (M := M) Pc).retractiont (f := + ![(#0 : ArithmeticSemiterm M 3), #1, &w₀, &w₁])).of_iff + ?_ + intro w + have he : + (fun j => Semiterm.val w id (![(#0 : ArithmeticSemiterm M 3), #1, &w₀, &w₁] j)) = + ![w 0, w 1, w₀, w₁] := + by + funext j + refine Fin.cases ?_ ?_ j + · simp + · intro j1 + refine Fin.cases ?_ ?_ j1 + · simp + · intro j2 + refine Fin.cases ?_ ?_ j2 + · simp + · intro j3 + refine Fin.cases ?_ (fun j4 => Fin.elim0 j4) j3 + simp + rw [he] + have hD : + Σ-[1].Definable (fun w : Fin 3 → M => Semiformula.Evalb ![w 0, w 2, H] (code dropCore)) := + by + refine + ((definable_code_graph (M := M) dropCore).retractiont (f := + ![(#0 : ArithmeticSemiterm M 3), #2, &H])).of_iff + ?_ + intro w + have he : + (fun j => Semiterm.val w id (![(#0 : ArithmeticSemiterm M 3), #2, &H] j)) = + ![w 0, w 2, H] := + by + funext j + refine Fin.cases ?_ ?_ j + · simp + · intro j1 + refine Fin.cases ?_ ?_ j1 + · simp + · intro j2 + refine Fin.cases ?_ (fun j3 => Fin.elim0 j3) j2 + simp + rw [he] + have hbody : + Σ-[1].Definable + (fun w : Fin 3 → M => + w 1 + w 2 = b ∧ + Semiformula.Evalb ![w 0, w 1, w₀, w₁] (code Pc) ∧ + Semiformula.Evalb ![w 0, w 2, H] (code dropCore)) := + (by definability : Σ-[1].Definable (fun w : Fin 3 → M => w 1 + w 2 = b)).and (hS.and hD) + have hex : + Σ-[1].Definable + (fun v : Fin 1 → M => + ∃ a p : M, + a + v 0 = b ∧ + Semiformula.Evalb ![p, a, w₀, w₁] (code Pc) ∧ + Semiformula.Evalb ![p, v 0, H] (code dropCore)) := + HierarchySymbol.Definable.exs (HierarchySymbol.Definable.exs hbody) + exact + HierarchySymbol.Definable.imp (by definability) + (HierarchySymbol.Definable.imp (by definability) hex) + +-- The graph formula of the recursions compared here contains the whole +-- evaluator-cell code, so unifying it against the recursion eliminators +-- exceeds the default heartbeat limit. + +/-- A recursion whose step conses onto the previous value runs through the same +values as the iterated tail of its result, in opposite directions. + +Every evaluation used here is supplied: the recursion values come from a +successful evaluation of the recursion, and the drop values from a supplied +bounded family. -/ +private theorem chain_match [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] (base : Code 2) (hdc : Code 4) (w₀ w₁ b H bound : M) + (htop : + Semiformula.Evalb ![H, b, w₀, w₁] + (code (codePrec base (codeListCons hdc (Code.proj (1 : Fin 4)))))) + (hdrop : ∀ t : M, t ≤ bound → ∃ z : M, Semiformula.Evalb ![z, t, H] (code dropCore)) + (i : M) : + i ≤ b → + i ≤ bound → + ∃ a p : M, + a + i = b ∧ + Semiformula.Evalb ![p, a, w₀, w₁] + (code (codePrec base (codeListCons hdc (Code.proj (1 : Fin 4))))) ∧ + Semiformula.Evalb ![p, i, H] (code dropCore) := by + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + let : M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐈Σ1 from inferInstance) + refine + InductionOnHierarchy.succ_induction Σ 1 + (definable_match (codePrec base (codeListCons hdc (Code.proj (1 : Fin 4)))) w₀ w₁ b H + bound) + ?_ ?_ i + · intro _ h0n + refine ⟨b, H, add_zero b, htop, ?_⟩ + obtain ⟨z, hz⟩ := hdrop 0 h0n + have hzH : z = H := dropCore_zero H z hz + rw [hzH] at hz + exact hz + · intro c IH hc1 hc2 + have hcm : c ≤ b := le_trans le_self_add hc1 + have hcn : c ≤ bound := le_trans le_self_add hc2 + obtain ⟨a, p, hac, hsa, hdi⟩ := IH hcm hcn + have hapos : 0 < a := + by + rcases + eq_or_lt_of_le (FFL.FirstOrder.Arithmetic.zero_le a) with + h0 | hpos + · exfalso + rw [← h0, zero_add] at hac + rw [← hac] at hc1 + exact absurd hc1 (by simp) + · exact hpos + have hpred : a - 1 + 1 = a := + sub_add_self_of_le + (FFL.FirstOrder.Arithmetic.pos_iff_one_le.mp hapos) + obtain ⟨q, hsq, hstep⟩ := + eval_codePrec_succ _ _ (a - 1) p ![w₀, w₁] (by rw [hpred]; exact hsa) + obtain ⟨x, l, -, hl, hpv⟩ := codeListCons_args _ _ p _ hstep + have hlq : l = q := eval_unique hl ((eval_proj_iff _ _ _).mpr rfl) + obtain ⟨z, hz⟩ := hdrop (c + 1) hc2 + obtain ⟨w, hw, htail⟩ := dropCore_succ H c z hz + have hwp : w = p := eval_unique hw hdi + refine ⟨a - 1, q, ?_, hsq, ?_⟩ + · calc + a - 1 + (c + 1) = (a - 1 + 1) + c := by rw [add_comm c 1, ← add_assoc] + _ = a + c := by rw [hpred] + _ = b := hac + · have hzq : z = q := + eval_tail_of_pair_succ (Code.proj (1 : Fin 3)) w x q z ![c, w, H] + ((eval_proj_iff _ _ _).mpr rfl) (by rw [hwp, hpv, hlq]) htail + rw [hzq] at hz + exact hz + +-- The drop recursion's graph formula is large; unifying it against the +-- recursion eliminator exceeds the default heartbeat limit. + +/-- The drops of a list below a supplied drop index are themselves supplied. -/ +private theorem drop_prefix [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] (H bnd z : M) + (hz : Semiformula.Evalb ![z, bnd, H] (code dropCore)) : + ∀ t : M, t ≤ bnd → ∃ y : M, Semiformula.Evalb ![y, t, H] (code dropCore) := by + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + let : M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐈Σ1 from inferInstance) + have hD : + Σ-[1].Definable (fun w : Fin 3 → M => Semiformula.Evalb ![w 0, w 1, H] (code dropCore)) := + by + refine + ((definable_code_graph (M := M) dropCore).retractiont (f := + ![(#0 : ArithmeticSemiterm M 3), #1, &H])).of_iff + ?_ + intro w + have he : + (fun j => Semiterm.val w id (![(#0 : ArithmeticSemiterm M 3), #1, &H] j)) = + ![w 0, w 1, H] := + by + funext j + refine Fin.cases ?_ ?_ j + · simp + · intro j1 + refine Fin.cases ?_ ?_ j1 + · simp + · intro j2 + refine Fin.cases ?_ (fun j3 => Fin.elim0 j3) j2 + simp + rw [he] + have hdef : + Σ-[1].DefinablePred + (fun j : M => + j ≤ bnd → ∃ t y : M, t + j = bnd ∧ Semiformula.Evalb ![y, t, H] (code dropCore)) := + by + have hbody : + Σ-[1].Definable + (fun w : Fin 3 → M => + w 1 + w 2 = bnd ∧ Semiformula.Evalb ![w 0, w 1, H] (code dropCore)) := + (by definability : Σ-[1].Definable (fun w : Fin 3 → M => w 1 + w 2 = bnd)).and hD + exact + HierarchySymbol.Definable.imp (by definability) + (HierarchySymbol.Definable.exs (HierarchySymbol.Definable.exs hbody)) + have hstep : + ∀ j : M, j ≤ bnd → ∃ t y : M, t + j = bnd ∧ Semiformula.Evalb ![y, t, H] (code dropCore) := + by + refine InductionOnHierarchy.succ_induction Σ 1 hdef ?_ ?_ + · intro _ + exact ⟨bnd, z, add_zero bnd, hz⟩ + · intro j IH hj + obtain ⟨t, y, htj, hy⟩ := IH (le_trans le_self_add hj) + have htpos : 0 < t := + by + rcases + eq_or_lt_of_le + (FFL.FirstOrder.Arithmetic.zero_le t) with + h0 | hp + · exfalso + rw [← h0, zero_add] at htj + rw [← htj] at hj + exact absurd hj (by simp) + · exact hp + have hpred : t - 1 + 1 = t := + sub_add_self_of_le + (FFL.FirstOrder.Arithmetic.pos_iff_one_le.mp htpos) + obtain ⟨w, hw, -⟩ := dropCore_succ H (t - 1) y (by rw [hpred]; exact hy) + refine ⟨t - 1, w, ?_, hw⟩ + calc + t - 1 + (j + 1) = (t - 1 + 1) + j := by rw [add_comm j 1, ← add_assoc] + _ = t + j := by rw [hpred] + _ = bnd := htj + intro t ht + obtain ⟨t', y, ht', hy⟩ := hstep (bnd - t) (by simp) + have hbt : t + (bnd - t) = bnd := add_tsub_self_of_le ht + have htt : t' = t := add_right_cancel (ht'.trans hbt.symm) + rw [htt] at hy + exact ⟨y, hy⟩ + +-- The drop recursion's graph formula is large; unifying it against the +-- recursion eliminator exceeds the default heartbeat limit. + +/-- Once a drop of a list vanishes, every later supplied drop vanishes too. -/ +private theorem drops_zero_from [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] (H c bound : M) + (hc : Semiformula.Evalb ![(0 : M), c, H] (code dropCore)) + (hdrop : ∀ t : M, t ≤ bound → ∃ z : M, Semiformula.Evalb ![z, t, H] (code dropCore)) (t : M) + (hct : c ≤ t) (htb : t ≤ bound) : Semiformula.Evalb ![(0 : M), t, H] (code dropCore) := + by + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + let : M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐈Σ1 from inferInstance) + have hdef : + Σ-[1].DefinablePred + (fun r : M => c ≤ r → r ≤ bound → Semiformula.Evalb ![(0 : M), r, H] (code dropCore)) := + by + have hD : + Σ-[1].Definable + (fun w : Fin 1 → M => Semiformula.Evalb ![(0 : M), w 0, H] (code dropCore)) := + by + refine + ((definable_code_graph (M := M) dropCore).retractiont (f := + ![&(0 : M), (#0 : ArithmeticSemiterm M 1), &H])).of_iff + ?_ + intro w + have he : + (fun j => Semiterm.val w id (![&(0 : M), (#0 : ArithmeticSemiterm M 1), &H] j)) = + ![(0 : M), w 0, H] := + by + funext j + refine Fin.cases ?_ ?_ j + · simp + · intro j1 + refine Fin.cases ?_ ?_ j1 + · simp + · intro j2 + refine Fin.cases ?_ (fun j3 => Fin.elim0 j3) j2 + simp + rw [he] + exact + HierarchySymbol.Definable.imp (by definability) + (HierarchySymbol.Definable.imp (by definability) hD) + refine InductionOnHierarchy.succ_induction Σ 1 hdef ?_ ?_ t hct htb + · intro hc0 _ + have hcz : c = 0 := le_antisymm hc0 (FFL.FirstOrder.Arithmetic.zero_le c) + rw [hcz] at hc + exact hc + · intro r IH hcr hrb + rcases lt_or_ge r c with hlt | hle + · have hceq : c = r + 1 := + le_antisymm hcr (FFL.FirstOrder.Arithmetic.succ_le_iff_lt.mpr hlt) + rw [hceq] at hc + exact hc + · have hprev := IH hle (le_trans le_self_add hrb) + obtain ⟨z', hz'⟩ := hdrop (r + 1) hrb + obtain ⟨w, hw, htail⟩ := dropCore_succ H r z' hz' + have hw0 : w = 0 := eval_unique hw hprev + have hone : Semiformula.Evalb ((1 : M) :> ![r, w, H]) (code (codeConst (n := 3) 1)) := by + rw [eval_codeConst_iff]; simp + have hsub := + eval_codeSub (Code.proj (1 : Fin 3)) (codeConst 1) w 1 ![r, w, H] + ((eval_proj_iff _ _ _).mpr rfl) hone + have hw1 : w - 1 = 0 := by + rw [hw0] + exact FFL.FirstOrder.Arithmetic.zero_sub 1 + rw [hw1] at hsub + have hu := + eval_codeUnpair₂ (codeSub (Code.proj (1 : Fin 3)) (codeConst 1)) 0 ![r, w, H] hsub + have hpi : FFL.FirstOrder.Arithmetic.pi₂ (0 : M) = 0 := + le_antisymm (by simpa using FFL.FirstOrder.Arithmetic.pi₂_le_self (0 : M)) + (FFL.FirstOrder.Arithmetic.zero_le _) + rw [hpi] at hu + have hz0 : z' = 0 := eval_unique htail (by rw [codeListTail]; exact hu) + rw [hz0] at hz' + exact hz' + +/-- Supplied drop evaluations reassemble into a length evaluation, in any +presentation of the list as a code. Only the minimization is built here; the +drops themselves are always premises. -/ +private theorem length_of_drops [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (X : Code r) (Hv n : M) (v : Fin r → M) + (hX : Semiformula.Evalb (Hv :> v) (code X)) + (h0 : Semiformula.Evalb ((0 : M) :> n :> ![Hv]) (code dropCore)) + (hn : + ∀ t : M, t < n → ∃ e : M, e ≠ 0 ∧ Semiformula.Evalb (e :> t :> ![Hv]) (code dropCore)) : + Semiformula.Evalb (n :> v) (code (codeListLength X)) := + by + have harg : + ∀ t z : M, + Semiformula.Evalb (z :> t :> ![Hv]) (code dropCore) → + Semiformula.Evalb (z :> t :> v) + (code (codeListDrop (codeLift X) (codeHead (n := r)))) := + by + intro t z hz + rw [codeListDrop_eq_dropCore, eval_comp_iff] + refine ⟨![t, Hv], hz, ?_⟩ + intro i + refine Fin.cases ?_ ?_ i + · simpa using (eval_codeHead_iff (M := M) t (t :> v)).mpr rfl + · intro j + refine Fin.cases ?_ (fun j' => Fin.elim0 j') j + simpa using (eval_codeLift_iff X Hv t v).mpr hX + rw [codeListLength, eval_codeRfindPos_iff] + refine ⟨⟨1, by simp, ?_⟩, ?_⟩ + · exact (eval_codeInv_iff _ _ _).mpr ⟨0, harg n 0 h0, Or.inl ⟨rfl, rfl⟩⟩ + · intro t ht + obtain ⟨e, hne, he⟩ := hn t ht + exact (eval_codeInv_iff _ _ _).mpr ⟨e, harg t e he, Or.inr ⟨hne, rfl⟩⟩ + +/-- A history whose length evaluation disagrees with its index. -/ +private theorem definable_bad : + Σ-[1].DefinablePred + (fun m : M => + ∃ H n : M, + Semiformula.Evalb ![H, m] (code codeEvaluatorHistory) ∧ + Semiformula.Evalb ![n, H] (code (codeListLength (Code.proj (0 : Fin 1)))) ∧ + ¬n = m) := + by + have hH : + Σ-[1].Definable + (fun w : Fin 3 → M => Semiformula.Evalb ![w 1, w 2] (code codeEvaluatorHistory)) := + by + refine + ((definable_code_graph (M := M) codeEvaluatorHistory).retractiont (f := + ![(#1 : ArithmeticSemiterm M 3), #2])).of_iff + ?_ + intro w + have he : + (fun j => Semiterm.val w id (![(#1 : ArithmeticSemiterm M 3), #2] j)) = ![w 1, w 2] := + by + funext j + refine Fin.cases ?_ ?_ j + · simp + · intro j1 + refine Fin.cases ?_ (fun j2 => Fin.elim0 j2) j1 + simp + rw [he] + have hL : + Σ-[1].Definable + (fun w : Fin 3 → M => + Semiformula.Evalb ![w 0, w 1] (code (codeListLength (Code.proj (0 : Fin 1))))) := + by + refine + ((definable_code_graph (M := M) (codeListLength (Code.proj (0 : Fin 1)))).retractiont + (f := ![(#0 : ArithmeticSemiterm M 3), #1])).of_iff + ?_ + intro w + have he : + (fun j => Semiterm.val w id (![(#0 : ArithmeticSemiterm M 3), #1] j)) = ![w 0, w 1] := + by + funext j + refine Fin.cases ?_ ?_ j + · simp + · intro j1 + refine Fin.cases ?_ (fun j2 => Fin.elim0 j2) j1 + simp + rw [he] + exact + HierarchySymbol.Definable.exs + (HierarchySymbol.Definable.exs (hH.and (hL.and (by definability)))) + +/-- Every value of the append recursion is a cons, hence nonzero. -/ +private theorem snoc_value_ne_zero [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] (m₁ H' a p : M) + (hp : Semiformula.Evalb ![p, a, m₁, H'] (code historySnocCore)) : p ≠ 0 := by + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + let : M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐈Σ1 from inferInstance) + rw [historySnocCore_eq] at hp + rcases eq_or_lt_of_le (FFL.FirstOrder.Arithmetic.zero_le a) with + h0 | hpos + · rw [← h0] at hp + exact codeListCons_ne_zero _ _ p _ (eval_codePrec_zero _ _ p ![m₁, H'] hp) + · have hpred : a - 1 + 1 = a := + sub_add_self_of_le + (FFL.FirstOrder.Arithmetic.pos_iff_one_le.mp hpos) + obtain ⟨q, -, hstep⟩ := eval_codePrec_succ _ _ (a - 1) p ![m₁, H'] (by rw [hpred]; exact hp) + exact codeListCons_ne_zero _ _ p _ hstep + +-- The same evaluator-cell code appears here through `historySnocCore`. + +/-- A supplied length evaluation of one table step is one more than the length +of the history it extends. -/ +private theorem length_step [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] (m₁ H' H₀ n₀ : M) + (hsnoc : Semiformula.Evalb ![H₀, m₁, m₁, H'] (code historySnocCore)) + (hd0 : Semiformula.Evalb ![(0 : M), n₀, H₀] (code dropCore)) + (hdn : ∀ t : M, t < n₀ → ∃ e : M, e ≠ 0 ∧ Semiformula.Evalb ![e, t, H₀] (code dropCore)) : + n₀ = m₁ + 1 := by + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + let : M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧 := + models_of_subtheory + (show M↓[ℒₒᵣ] ⊧* 𝐈Σ1 from inferInstance) + -- the drop chain does not run out before the recursion does + have hdrop : ∀ t : M, t ≤ n₀ → ∃ z : M, Semiformula.Evalb ![z, t, H₀] (code dropCore) := + by + intro t ht + rcases lt_or_eq_of_le ht with hlt | rfl + · obtain ⟨e, -, he⟩ := hdn t hlt + exact ⟨e, he⟩ + · exact ⟨0, hd0⟩ + rw [historySnocCore_eq] at hsnoc + have hgt : m₁ < n₀ := by + by_contra hcon + have hle : n₀ ≤ m₁ := not_lt.mp hcon + obtain ⟨a, p, -, hsa, hdc⟩ := chain_match _ _ m₁ H' m₁ H₀ n₀ hsnoc hdrop n₀ hle le_rfl + exact + snoc_value_ne_zero m₁ H' a p (by rw [historySnocCore_eq]; exact hsa) + (eval_unique hdc hd0) + -- and it runs out immediately afterwards + have hle : n₀ ≤ m₁ + 1 := by + by_contra hcon + have hlt : m₁ + 1 < n₀ := not_le.mp hcon + obtain ⟨a, p, hac, hsa, hdc⟩ := + chain_match _ _ m₁ H' m₁ H₀ n₀ hsnoc hdrop m₁ le_rfl (le_of_lt hgt) + have ha0 : a = 0 := by + have : a + m₁ = 0 + m₁ := by rw [hac, zero_add] + exact add_right_cancel this + rw [ha0] at hsa + have hbase := eval_codePrec_zero _ _ p ![m₁, H'] hsa + obtain ⟨r, l, -, hnil, hpv⟩ := codeListCons_args _ _ p _ hbase + have hl0 : l = 0 := by + simpa [codeListNil] using (eval_zero_iff (M := M) l ![m₁, H']).mp hnil + obtain ⟨e, hne, he⟩ := hdn (m₁ + 1) hlt + obtain ⟨w, hw, htail⟩ := dropCore_succ H₀ m₁ e he + have hwp : w = p := eval_unique hw hdc + have hel : e = l := + eval_tail_of_pair_succ (Code.proj (1 : Fin 3)) w r l e ![m₁, w, H₀] + ((eval_proj_iff _ _ _).mpr rfl) (by rw [hwp, hpv]) htail + exact hne (by rw [hel, hl0]) + exact + le_antisymm hle + (FFL.FirstOrder.Arithmetic.succ_le_iff_lt.mpr hgt) + +/-! +### The length of a constructed history -/ + +-- The history code contains the whole evaluator-cell code. + +/-- A supplied length evaluation of the history at `m` has the value `m`. + +Existence is never asserted: the length evaluation is a premise, and the proof +only identifies its value. `codeListLength` is a minimization, and the generic +existence theorem for `codePrec` is not used here. -/ +theorem eval_codeEvaluatorHistory_length_unique [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] (m H n : M) + (hH : Semiformula.Evalb ![H, m] (code codeEvaluatorHistory)) + (hLength : Semiformula.Evalb ![n, H] (code (codeListLength (Code.proj (0 : Fin 1))))) : + n = m := by + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + let : M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐈Σ1 from inferInstance) + by_contra hne + obtain ⟨m₀, ⟨H₀, n₀, hH₀, hL₀, hne₀⟩, hleast⟩ := + InductionOnHierarchy.least_number Σ 1 (definable_bad (M := M)) (x := m) + ⟨H, n, hH, hLength, hne⟩ + have hself : Semiformula.Evalb (H₀ :> ![H₀]) (code (Code.proj (0 : Fin 1))) := + (eval_proj_iff _ _ _).mpr rfl + obtain ⟨hd0, hdn⟩ := drops_of_length _ H₀ n₀ ![H₀] hself hL₀ + rcases + eq_or_lt_of_le (FFL.FirstOrder.Arithmetic.zero_le m₀) with + hzero | hpos + · -- the empty history has no nonzero drop at index zero + refine hne₀ ?_ + rw [← hzero] at hH₀ ⊢ + have hnil : H₀ = 0 := + by + have h0 := + eval_codePrec_zero _ _ H₀ ![] (by rw [codeEvaluatorHistory] at hH₀; simpa using hH₀) + simpa [codeListNil] using (eval_zero_iff (M := M) H₀ ![]).mp h0 + by_contra hn0 + obtain ⟨e, hne', he⟩ := + hdn 0 + (lt_of_le_of_ne (FFL.FirstOrder.Arithmetic.zero_le n₀) + (Ne.symm hn0)) + exact hne' (by rw [dropCore_zero H₀ e he, hnil]) + · -- the successor step adds exactly one entry + have hpred : m₀ - 1 + 1 = m₀ := + sub_add_self_of_le + (FFL.FirstOrder.Arithmetic.pos_iff_one_le.mp hpos) + obtain ⟨H', hH', hstep⟩ := + eval_codePrec_succ _ _ (m₀ - 1) H₀ ![] + (by rw [codeEvaluatorHistory] at hH₀; rw [hpred]; simpa using hH₀) + rw [← codeEvaluatorHistory] at hH' + rw [codeEvaluatorTableStep_eq, eval_codeBind_iff] at hstep + obtain ⟨n', hlen', hsnoc⟩ := hstep + have hproj : Semiformula.Evalb (H' :> ![m₀ - 1, H']) (code (Code.proj (1 : Fin 2))) := + (eval_proj_iff _ _ _).mpr rfl + obtain ⟨hd0', hdn'⟩ := drops_of_length _ H' n' ![m₀ - 1, H'] hproj hlen' + have hlen'' : + Semiformula.Evalb (n' :> ![H']) (code (codeListLength (Code.proj (0 : Fin 1)))) := + length_of_drops _ H' n' ![H'] ((eval_proj_iff _ _ _).mpr rfl) hd0' hdn' + have hn'm : n' = m₀ - 1 := by + by_contra hcon + exact hleast (m₀ - 1) (by rw [← hpred]; simp) ⟨H', n', by simpa using hH', hlen'', hcon⟩ + rw [hn'm] at hsnoc + refine hne₀ ?_ + rw [← hpred] + exact length_step (m₀ - 1) H' H₀ n₀ (by simpa using hsnoc) hd0 hdn + +/-! +### The program index read from the history -/ + +private theorem posL [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {x y : M} (h : 0 < x * y) : 0 < x := + by + rcases eq_or_lt_of_le (FFL.FirstOrder.Arithmetic.zero_le x) with h0 | hp + · rw [← h0, zero_mul] at h; exact absurd h (_root_.lt_irrefl 0) + · exact hp + +private theorem posR [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {x y : M} (h : 0 < x * y) : 0 < y := + by + rcases eq_or_lt_of_le (FFL.FirstOrder.Arithmetic.zero_le y) with h0 | hp + · rw [← h0, mul_zero] at h; exact absurd h (_root_.lt_irrefl 0) + · exact hp + +/-- Both arguments of a successfully evaluated truncated difference have +values. -/ +private theorem eval_sub_args [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {n : ℕ} (A B : Code n) (z : M) (v : Fin n → M) + (h : Semiformula.Evalb (z :> v) (code (codeSub A B))) : + ∃ a b : M, + Semiformula.Evalb (a :> v) (code A) ∧ + Semiformula.Evalb (b :> v) (code B) ∧ (z + b = a ∨ z = 0) := + by + rw [codeSub, eval_codeRfindPos_iff] at h + obtain ⟨⟨y, hy, hbody⟩, -⟩ := h + rw [eval_codeOr_iff] at hbody + obtain ⟨p, q, hp, hq, hcase⟩ := hbody + rw [eval_codeEq_iff] at hp + obtain ⟨e₁, e₂, he₁, he₂, hdec⟩ := hp + rw [eval_codeAdd_iff] at he₁ + obtain ⟨zz, b, hzz, hb, hsum⟩ := he₁ + rw [eval_codeHead_iff] at hzz + simp only [Matrix.cons_val_zero] at hzz + subst hzz + rw [eval_codeLift_iff] at hb he₂ + refine ⟨e₂, b, he₂, hb, ?_⟩ + rcases hdec with ⟨heq, -⟩ | ⟨-, hp0⟩ + · left; rw [← heq, hsum] + · right + rw [eval_codeAnd_iff] at hq + obtain ⟨c₁, c₂, -, hc₂, hdec₂⟩ := hq + have hqpos : 0 < q := by + rcases hcase with ⟨hpos, -⟩ | ⟨-, h0⟩ + · rw [hp0, zero_add] at hpos; exact hpos + · exact absurd h0 (ne_of_gt hy) + have hc₂pos : 0 < c₂ := by + rcases hdec₂ with ⟨hpos, -⟩ | ⟨-, h0⟩ + · exact posR hpos + · exact absurd h0 (ne_of_gt hqpos) + rw [eval_codeEq_iff] at hc₂ + obtain ⟨d₁, d₂, hd₁, hd₂, hdec₃⟩ := hc₂ + rw [eval_codeHead_iff] at hd₁ + simp only [Matrix.cons_val_zero] at hd₁ + rw [eval_zero_iff] at hd₂ + rcases hdec₃ with ⟨heq, -⟩ | ⟨-, h0⟩ + · rw [hd₁] at heq; rw [heq, hd₂] + · exact absurd h0 (ne_of_gt hc₂pos) + +/-- Two codes with a common value have the same graph, at whatever arities and +assignments they are written. -/ +private theorem graph_iff [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k l : ℕ} (A : Code k) (A' : Code l) (t : M) + (v : Fin k → M) (v' : Fin l → M) (h : Semiformula.Evalb (t :> v) (code A)) + (h' : Semiformula.Evalb (t :> v') (code A')) : + ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v') (code A') := by + intro x + constructor + · intro hx; rw [eval_unique hx h]; exact h' + · intro hx; rw [eval_unique hx h']; exact h + +-- The history-evaluator code contains the whole evaluator-cell code. + +/-- A successful history-evaluator lookup one step past the pair of `s` and +`qCode` exhibits `qCode` as the second Cantor component of the length of the +history one step earlier. -/ +theorem eval_codeHistoryEvaluator_succ_extract_index [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] (s qCode u y : M) + (h : Semiformula.Evalb ![y + 1, s, qCode, u] (code codeHistoryEvaluator)) : + Semiformula.Evalb ![qCode, s, qCode, u] + (code (codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell))) := + by + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + let : M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐈Σ1 from inferInstance) + rw [codeHistoryEvaluator, codeTableLookup_eq] at h + obtain ⟨a, -, ha, -, -⟩ := eval_sub_args _ _ _ _ h + rw [codeListGetOptional] at ha + obtain ⟨row, hrow, -⟩ := eval_codeIfPos_cases _ _ _ _ _ ha + rw [codeListDrop_eq_dropCore, eval_comp_iff] at hrow + obtain ⟨w, -, hwi⟩ := hrow + have hY := hwi 1 + simp only [Matrix.cons_val_one, Matrix.cons_val_fin_one] at hY + obtain ⟨a₁, -, ha₁, -, -⟩ := eval_sub_args _ _ _ _ hY + rw [codeListGetOptional] at ha₁ + obtain ⟨tbl, htbl, -⟩ := eval_codeIfPos_cases _ _ _ _ _ ha₁ + rw [codeListDrop_eq_dropCore, eval_comp_iff] at htbl + obtain ⟨w', -, hw'i⟩ := htbl + have hDT := hw'i 1 + simp only [Matrix.cons_val_one, Matrix.cons_val_fin_one] at hDT + rw [eval_comp_iff] at hDT + obtain ⟨w'', hhist, hw''i⟩ := hDT + have hsucc := hw''i 0 + simp only [Matrix.cons_val_zero] at hsucc + rw [eval_codeSucc_iff] at hsucc + obtain ⟨m, hm, hw''0⟩ := hsucc + have hshape : w'' = (m + 1) :> ![] := by + funext j + refine Fin.cases ?_ (fun j' => Fin.elim0 j') j + exact hw''0 + rw [hshape, codeEvaluatorHistory] at hhist + obtain ⟨H₀, hH₀, hstep⟩ := eval_codePrec_succ _ _ m _ ![] hhist + rw [← codeEvaluatorHistory] at hH₀ + rw [codeEvaluatorTableStep_eq, eval_codeBind_iff] at hstep + obtain ⟨n', hlen', -⟩ := hstep + obtain ⟨hd0, hdn⟩ := + drops_of_length _ H₀ n' ![m, H₀] ((eval_proj_iff (1 : Fin 2) H₀ ![m, H₀]).mpr rfl) hlen' + have hn'm : n' = m := + eval_codeEvaluatorHistory_length_unique m H₀ n' (by simpa using hH₀) + (length_of_drops _ H₀ n' ![H₀] ((eval_proj_iff _ _ _).mpr rfl) hd0 hdn) + rw [hn'm] at hd0 hdn + have hbefore : + Semiformula.Evalb (H₀ :> ![s, qCode, u]) (code codeEvaluatorHistoryBeforeCell) := + by + rw [codeEvaluatorHistoryBeforeCell, eval_comp_iff] + refine ⟨![m], by simpa using hH₀, ?_⟩ + intro i + refine Fin.cases ?_ (fun j => Fin.elim0 j) i + simpa using hm + have hlen : + Semiformula.Evalb (m :> ![s, qCode, u]) + (code (codeListLength codeEvaluatorHistoryBeforeCell)) := + length_of_drops _ H₀ m ![s, qCode, u] hbefore hd0 hdn + have hmpair : m = FFL.FirstOrder.Arithmetic.pair s qCode := + eval_unique hm + (eval_codePair _ _ s qCode ![s, qCode, u] ((eval_proj_iff _ _ _).mpr rfl) + ((eval_proj_iff _ _ _).mpr rfl)) + have hu := + eval_codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell) m ![s, qCode, u] hlen + rw [hmpair, FFL.FirstOrder.Arithmetic.pi₂_pair] at hu + exact hu + +/-! +### The evaluator cell read from the history -/ + +-- The history-evaluator code contains the whole evaluator-cell code. + +/-- A successful history-evaluator lookup one step past the pair of `s` and +`qCode` has its input `u` strictly below `s`, and exhibits its own value as the +evaluator cell of the history one step earlier at index `u`. + +The bound is strict. The entry at `u` is nonempty, so the position of the row +recursion that holds it is positive, position zero being the empty list; that +position plus `u` is `s`. -/ +private theorem pair_assignment {α : Type*} (w : Fin 2 → α) (a : α) (h : w 0 = a) : + w = a :> ![w 1] := by + funext i + refine Fin.cases ?_ ?_ i + · simpa using h + · intro j + have hj : j = 0 := Subsingleton.elim _ _ + subst j + rfl + +private theorem singleton_assignment {α : Type*} (w : Fin 1 → α) (a : α) (h : w 0 = a) : + w = a :> ![] := by + funext i + have hi : i = 0 := Subsingleton.elim _ _ + subst i + simpa using h + +private theorem positive_recursion_entry [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] (cell : Code 4) + (w₀ w₁ bound row input value : M) + (hrec : + Semiformula.Evalb ![row, bound, w₀, w₁] + (code (codePrec (codeListNil (n := 2)) (codeListCons cell (Code.proj (1 : Fin 4)))))) + (hdrops : ∀ t : M, t ≤ input → ∃ z : M, Semiformula.Evalb ![z, t, row] (code dropCore)) + (hentry : Semiformula.Evalb ![value, input, row] (code dropCore)) (hpositive : 0 < value) : + ∃ a previous head tail : M, + a + input = bound ∧ + 0 < a ∧ + Semiformula.Evalb ![head, a - 1, previous, w₀, w₁] (code cell) ∧ + Semiformula.Evalb ![tail, a - 1, previous, w₀, w₁] (code (Code.proj (1 : Fin 4))) ∧ + value = FFL.FirstOrder.Arithmetic.pair head tail + 1 := + by + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + let : M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧 := models_of_subtheory (U := 𝐈Σ₁) inferInstance + have hbound : input ≤ bound := by + by_contra hcon + have hlt : bound < input := not_le.mp hcon + obtain ⟨a, result, ha, heval, hdrop⟩ := + chain_match _ _ w₀ w₁ bound row input hrec hdrops bound le_rfl (le_of_lt hlt) + have ha0 : a = 0 := + by + have heq : a + bound = 0 + bound := by simpa using ha + exact add_right_cancel heq + rw [ha0] at heval + have hbase := eval_codePrec_zero _ _ result ![w₀, w₁] heval + have hzero : result = 0 := by + simpa [codeListNil] using (eval_zero_iff (M := M) result ![w₀, w₁]).mp hbase + rw [hzero] at hdrop + have hnil := drops_zero_from row bound input hdrop hdrops input (le_of_lt hlt) le_rfl + exact absurd (eval_unique hentry hnil) (ne_of_gt hpositive) + obtain ⟨a, result, ha, heval, hdrop⟩ := + chain_match _ _ w₀ w₁ bound row input hrec hdrops input hbound le_rfl + have hresult : result = value := eval_unique hdrop hentry + have hapos : 0 < a := + by + rcases eq_or_lt_of_le (FFL.FirstOrder.Arithmetic.zero_le a) with hzero | hpos + · rw [← hzero] at heval + have hbase := eval_codePrec_zero _ _ result ![w₀, w₁] heval + have hz : result = 0 := by + simpa [codeListNil] using (eval_zero_iff (M := M) result ![w₀, w₁]).mp hbase + exact absurd (hz ▸ hresult) (ne_of_gt hpositive).symm + · exact hpos + have hpredecessor : a - 1 + 1 = a := + sub_add_self_of_le (FFL.FirstOrder.Arithmetic.pos_iff_one_le.mp hapos) + obtain ⟨previous, _, hstep⟩ := + eval_codePrec_succ _ _ (a - 1) result ![w₀, w₁] (by rw [hpredecessor]; exact heval) + obtain ⟨head, tail, hhead, htail, hvalue⟩ := codeListCons_args _ _ result _ hstep + exact ⟨a, previous, head, tail, ha, hapos, hhead, htail, by rw [← hresult]; exact hvalue⟩ + +private theorem eval_codeHistoryEvaluator_succ_extract_cell_core [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] + (s qCode u y : M) + (h : Semiformula.Evalb ![y + 1, s, qCode, u] (code codeHistoryEvaluator)) : + u < s ∧ + Semiformula.Evalb ![y + 1, s, qCode, u] + (code (codeEvaluatorCell codeEvaluatorHistoryBeforeCell (Code.proj (2 : Fin 3)))) := by + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + let : M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐈Σ1 from inferInstance) + have hone : ∀ w : Fin 3 → M, Semiformula.Evalb ((1 : M) :> w) (code (codeConst (n := 3) 1)) := + by intro w; rw [eval_codeConst_iff]; simp + rw [codeHistoryEvaluator, codeTableLookup_eq] at h + obtain ⟨a, b₀, ha, hb₀, hcase₀⟩ := eval_sub_args _ _ _ _ h + have hb₀v : b₀ = 1 := eval_unique hb₀ (hone _) + have hay : a = y + 1 + 1 := by + rcases hcase₀ with heq | h0 + · rw [← heq, hb₀v] + · exact absurd h0.symm (zero_ne_add_one y) + rw [codeListGetOptional] at ha + obtain ⟨f, hf, hbr⟩ := eval_codeIfPos_cases _ _ _ _ _ ha + have hanz : ¬Semiformula.Evalb (a :> ![s, qCode, u]) (code (Code.zero 3)) := + by + intro hR + rw [eval_zero_iff, hay] at hR + exact (zero_ne_add_one (y + 1)) hR.symm + obtain ⟨hfpos, hsucc⟩ := hbr.resolve_right (fun hp => hanz hp.2) + rw [eval_codeSucc_iff] at hsucc + obtain ⟨c, hc, hac⟩ := hsucc + have hcy : c = y + 1 := + by + have : c + 1 = y + 1 + 1 := by rw [← hac, hay] + exact add_right_cancel this + have hfdrop := hf + rw [codeListDrop_eq_dropCore, eval_comp_iff] at hf + obtain ⟨w, hfw, hwi⟩ := hf + have hw0 : w 0 = u := by + have h0 := hwi 0 + simp only [Matrix.cons_val_zero] at h0 + simpa using eval_unique h0 ((eval_proj_iff (2 : Fin 3) u ![s, qCode, u]).mpr rfl) + have hYv := hwi 1 + simp only [Matrix.cons_val_one, Matrix.cons_val_fin_one] at hYv + have hinner : Semiformula.Evalb ![f, u, w 1] (code dropCore) := + by + have hshape := pair_assignment w u hw0 + rw [hshape] at hfw + simpa using hfw + have hdropRow := drop_prefix (w 1) u f hinner + obtain ⟨a₁, b₁, ha₁, hb₁, hcase₁⟩ := eval_sub_args _ _ _ _ hYv + have hb₁v : b₁ = 1 := eval_unique hb₁ (hone _) + have hYpos : w 1 + 1 = a₁ := by + rcases hcase₁ with heq | h0 + · rw [← heq, hb₁v] + · exfalso + have hz0 : Semiformula.Evalb ![(0 : M), 0, w 1] (code dropCore) := + by + obtain ⟨z, hz⟩ := + hdropRow 0 (FFL.FirstOrder.Arithmetic.zero_le u) + have hzw : z = w 1 := dropCore_zero (w 1) z hz + have hz0' : z = 0 := by rw [hzw, h0] + rw [hz0'] at hz + exact hz + have := + drops_zero_from (w 1) 0 u hz0 hdropRow u + (FFL.FirstOrder.Arithmetic.zero_le u) le_rfl + exact + absurd (eval_unique hinner this) + (ne_of_gt hfpos) + -- the outer lookup selects the row of the predecessor history + rw [codeListGetOptional] at ha₁ + obtain ⟨g, hg, hbr₁⟩ := eval_codeIfPos_cases _ _ _ _ _ ha₁ + have ha₁nz : ¬Semiformula.Evalb (a₁ :> ![s, qCode, u]) (code (Code.zero 3)) := + by + intro hR + rw [eval_zero_iff, ← hYpos] at hR + exact (zero_ne_add_one (w 1)) hR.symm + obtain ⟨hgpos, hsucc₁⟩ := hbr₁.resolve_right (fun hp => ha₁nz hp.2) + rw [eval_codeSucc_iff] at hsucc₁ + obtain ⟨c₁, hc₁, ha₁c⟩ := hsucc₁ + have hc₁Y : c₁ = w 1 := + by + have : c₁ + 1 = w 1 + 1 := by rw [← ha₁c, hYpos] + exact add_right_cancel this + have hgsub := eval_codeSub _ (codeConst 1) g 1 ![s, qCode, u] hg (hone _) + have hgu := eval_codeUnpair₁ _ (g - 1) ![s, qCode, u] hgsub + have hc₁pi : c₁ = FFL.FirstOrder.Arithmetic.pi₁ (g - 1) := + eval_unique hc₁ hgu + rw [codeListDrop_eq_dropCore, eval_comp_iff] at hg + obtain ⟨w', hgw, hw'i⟩ := hg + have hm := hw'i 0 + simp only [Matrix.cons_val_zero] at hm + have hDT := hw'i 1 + simp only [Matrix.cons_val_one, Matrix.cons_val_fin_one] at hDT + rw [eval_comp_iff] at hDT + obtain ⟨w'', hhist, hw''i⟩ := hDT + have hsuccP := hw''i 0 + simp only [Matrix.cons_val_zero] at hsuccP + rw [eval_codeSucc_iff] at hsuccP + obtain ⟨m, hmP, hw''0⟩ := hsuccP + have hmw : w' 0 = m := eval_unique hm hmP + have hshape'' := singleton_assignment w'' (m + 1) hw''0 + rw [hshape'', codeEvaluatorHistory] at hhist + obtain ⟨H₀, hH₀, hstep⟩ := eval_codePrec_succ _ _ m _ ![] hhist + rw [← codeEvaluatorHistory] at hH₀ + rw [codeEvaluatorTableStep_eq, eval_codeBind_iff] at hstep + obtain ⟨n', hlen', hsnoc⟩ := hstep + obtain ⟨hd0, hdn⟩ := + drops_of_length _ H₀ n' ![m, H₀] ((eval_proj_iff (1 : Fin 2) H₀ ![m, H₀]).mpr rfl) hlen' + have hn'm : n' = m := + eval_codeEvaluatorHistory_length_unique m H₀ n' (by simpa using hH₀) + (length_of_drops _ H₀ n' ![H₀] ((eval_proj_iff _ _ _).mpr rfl) hd0 hdn) + rw [hn'm] at hd0 hdn hsnoc hlen' + have hgT : Semiformula.Evalb ![g, m, w' 1] (code dropCore) := + by + have hshape' := pair_assignment w' m hmw + rw [hshape'] at hgw + simpa using hgw + have hdropT := drop_prefix (w' 1) m g hgT + rw [historySnocCore_eq] at hsnoc + obtain ⟨aT, pT, haT, hsaT, hdT⟩ := + chain_match _ _ m H₀ m (w' 1) m hsnoc hdropT m le_rfl le_rfl + have haT0 : aT = 0 := by + have : aT + m = 0 + m := by rw [haT, zero_add] + exact add_right_cancel this + rw [haT0] at hsaT + have hbase := eval_codePrec_zero _ _ pT ![m, H₀] hsaT + obtain ⟨rowv, nilv, hrow, hnil, hpTv⟩ := codeListCons_args _ _ pT _ hbase + have hnil0 : nilv = 0 := by + simpa [codeListNil] using (eval_zero_iff (M := M) nilv ![m, H₀]).mp hnil + have hgp : g = pT := eval_unique hgT hdT + have hrowv : w 1 = rowv := by + rw [hc₁Y] at hc₁pi + rw [hc₁pi, hgp, hpTv, hnil0, add_sub_self, + FFL.FirstOrder.Arithmetic.pi₁_pair] + -- the row recursion, whose bound is `s` + rw [hrowv] at hinner hdropRow + rw [codeEvaluatorRow_eq_bind, eval_codeBind_iff] at hrow + obtain ⟨bnd, hbnd, hrowcore⟩ := hrow + have hmpair : m = FFL.FirstOrder.Arithmetic.pair s qCode := + eval_unique hmP + (eval_codePair _ _ s qCode ![s, qCode, u] ((eval_proj_iff _ _ _).mpr rfl) + ((eval_proj_iff _ _ _).mpr rfl)) + have hbnds : bnd = s := + by + have := + eval_unique hbnd + (eval_codeUnpair₁ (codeListLength (Code.proj (1 : Fin 2))) m ![m, H₀] hlen') + rw [this, hmpair, FFL.FirstOrder.Arithmetic.pi₁_pair] + rw [hbnds] at hrowcore + obtain ⟨aR, q, cellv, l, haR, haRpos, hcell, hl, hpRv⟩ := + positive_recursion_entry _ m H₀ s rowv u f hrowcore hdropRow hinner hfpos + have hpredR : aR - 1 + 1 = aR := + sub_add_self_of_le (FFL.FirstOrder.Arithmetic.pos_iff_one_le.mp haRpos) + have hfsub := eval_codeSub _ (codeConst 1) f 1 ![s, qCode, u] hfdrop (hone _) + have hcpi : c = FFL.FirstOrder.Arithmetic.pi₁ (f - 1) := + eval_unique hc (eval_codeUnpair₁ _ (f - 1) ![s, qCode, u] hfsub) + have hpif : FFL.FirstOrder.Arithmetic.pi₁ (f - 1) = cellv := by + rw [hpRv, add_sub_self, + FFL.FirstOrder.Arithmetic.pi₁_pair] + have hcelly : cellv = y + 1 := by rw [← hpif, ← hcpi]; exact hcy + have hTsrc : + Semiformula.Evalb (H₀ :> ![aR - 1, q, m, H₀]) + (code (codeLift (codeLift (Code.proj (1 : Fin 2))))) := + (eval_codeLift_iff _ _ _ _).mpr + ((eval_codeLift_iff _ _ _ _).mpr ((eval_proj_iff _ _ _).mpr rfl)) + have hTtgt : Semiformula.Evalb (H₀ :> ![s, qCode, u]) (code codeEvaluatorHistoryBeforeCell) := + by + rw [codeEvaluatorHistoryBeforeCell, eval_comp_iff] + refine ⟨![m], by simpa using hH₀, ?_⟩ + intro i + refine Fin.cases ?_ (fun j => Fin.elim0 j) i + simpa using hmP + have hlenlift : + Semiformula.Evalb (m :> ![aR - 1, q, m, H₀]) + (code (codeListLength (codeLift (codeLift (Code.proj (1 : Fin 2)))))) := + length_of_drops _ H₀ m ![aR - 1, q, m, H₀] hTsrc hd0 hdn + have hfuel : + Semiformula.Evalb (s :> ![aR - 1, q, m, H₀]) + (code (codeUnpair₁ (codeListLength (codeLift (codeLift (Code.proj (1 : Fin 2))))))) := + by + have hpi : FFL.FirstOrder.Arithmetic.pi₁ m = s := by + rw [hmpair, FFL.FirstOrder.Arithmetic.pi₁_pair] + have hlift := eval_codeUnpair₁ _ m ![aR - 1, q, m, H₀] hlenlift + rwa [hpi] at hlift + have hstepv : + Semiformula.Evalb (aR :> ![aR - 1, q, m, H₀]) (code (codeSucc (Code.proj (0 : Fin 4)))) := + (eval_codeSucc_iff _ _ _).mpr ⟨aR - 1, (eval_proj_iff _ _ _).mpr rfl, hpredR.symm⟩ + have hNsrc : + Semiformula.Evalb (u :> ![aR - 1, q, m, H₀]) + (code + (codeSub (codeUnpair₁ (codeListLength (codeLift (codeLift (Code.proj (1 : Fin 2)))))) + (codeSucc (Code.proj (0 : Fin 4))))) := + by + have hsu : s - aR = u := sub_remove_left (by rw [← haR, add_comm]) + have := eval_codeSub _ _ s aR ![aR - 1, q, m, H₀] hfuel hstepv + rwa [hsu] at this + have hNtgt : Semiformula.Evalb (u :> ![s, qCode, u]) (code (Code.proj (2 : Fin 3))) := + (eval_proj_iff _ _ _).mpr rfl + have hfin := + (eval_codeEvaluatorCell_congr_at _ _ _ _ cellv ![aR - 1, q, m, H₀] ![s, qCode, u] + (graph_iff _ _ H₀ _ _ hTsrc hTtgt) (graph_iff _ _ u _ _ hNsrc hNtgt)).mp + hcell + rw [hcelly] at hfin + refine ⟨?_, hfin⟩ + rw [← haR] + exact lt_add_of_pos_left u haRpos + +/-- A successful history-evaluator lookup one step past the pair of `s` and +`qCode` exhibits `qCode` as the second Cantor component of the length of the +history one step earlier, and exhibits its own value as the evaluator cell of +that history at index `u`. -/ +theorem eval_codeHistoryEvaluator_succ_extract_cell [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] (s qCode u y : M) + (h : Semiformula.Evalb ![y + 1, s, qCode, u] (code codeHistoryEvaluator)) : + Semiformula.Evalb ![qCode, s, qCode, u] + (code (codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell))) ∧ + Semiformula.Evalb ![y + 1, s, qCode, u] + (code (codeEvaluatorCell codeEvaluatorHistoryBeforeCell (Code.proj (2 : Fin 3)))) := + ⟨eval_codeHistoryEvaluator_succ_extract_index s qCode u y h, + (eval_codeHistoryEvaluator_succ_extract_cell_core s qCode u y h).2⟩ + +/-! +### Entries of an encoded list, independently of how the list is written -/ + +/-- The encoded list `l` has the nonzero entry `z` at index `i`: the drop of `l` +at `i` is a nonempty cons whose head is `z - 1`. + +Stating this at values rather than at codes lets an entry be moved between +different presentations of the same list. -/ +private abbrev GetAt (l i z : M) : Prop := + ∃ d hd : M, + Semiformula.Evalb ![d, i, l] (code dropCore) ∧ + Semiformula.Evalb ![hd, d] + (code (codeUnpair₁ (codeSub (Code.proj (0 : Fin 1)) (codeConst 1)))) ∧ + 0 < d ∧ z = hd + 1 + +/-- The head of a nonempty encoded list, read at one fixed presentation. -/ +private theorem head_of_drop [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] {r : ℕ} (D : Code r) (d : M) (v : Fin r → M) + (hd : Semiformula.Evalb (d :> v) (code D)) : + Semiformula.Evalb (FFL.FirstOrder.Arithmetic.pi₁ (d - 1) :> v) + (code (codeUnpair₁ (codeSub D (codeConst 1)))) := + by + have hone : Semiformula.Evalb ((1 : M) :> v) (code (codeConst (n := r) 1)) := by + rw [eval_codeConst_iff]; simp + exact eval_codeUnpair₁ _ (d - 1) v (eval_codeSub _ (codeConst 1) d 1 v hd hone) + +/-- A positive `codeListGet?` evaluation exhibits its list, its index and the +entry relation between them. -/ +private theorem getAt_of_eval [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] {r : ℕ} (A B : Code r) (z : M) (v : Fin r → M) + (hz : Semiformula.Evalb (z :> v) (code (codeListGetOptional A B))) (hpos : 0 < z) : + ∃ l i : M, + Semiformula.Evalb (l :> v) (code A) ∧ Semiformula.Evalb (i :> v) (code B) ∧ GetAt l i z := + by + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + let : M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐈Σ1 from inferInstance) + rw [codeListGetOptional] at hz + obtain ⟨d, hd, hbr⟩ := eval_codeIfPos_cases _ _ _ _ _ hz + have hnz : ¬Semiformula.Evalb (z :> v) (code (Code.zero r)) := + by + intro hR + rw [eval_zero_iff] at hR + rw [hR] at hpos + exact absurd hpos (_root_.lt_irrefl 0) + obtain ⟨hdpos, hsucc⟩ := hbr.resolve_right (fun hp => hnz hp.2) + rw [eval_codeSucc_iff] at hsucc + obtain ⟨e, he, hze⟩ := hsucc + have hev : e = FFL.FirstOrder.Arithmetic.pi₁ (d - 1) := eval_unique he (head_of_drop _ d v hd) + have hdcopy := hd + rw [codeListDrop_eq_dropCore, eval_comp_iff] at hd + obtain ⟨w, hdw, hwi⟩ := hd + have hB := hwi 0 + simp only [Matrix.cons_val_zero] at hB + have hA := hwi 1 + simp only [Matrix.cons_val_one, Matrix.cons_val_fin_one] at hA + have hshape : w = (w 0 :> ![w 1]) := by + funext j + refine Fin.cases ?_ ?_ j + · rfl + · intro j' + refine Fin.cases ?_ (fun j'' => Fin.elim0 j'') j' + rfl + rw [hshape] at hdw + refine + ⟨w 1, w 0, hA, hB, d, FFL.FirstOrder.Arithmetic.pi₁ (d - 1), by simpa using hdw, + head_of_drop (Code.proj (0 : Fin 1)) d ![d] ((eval_proj_iff _ _ _).mpr rfl), hdpos, ?_⟩ + rw [← hev, hze] + +/-- Conversely, an entry relation gives a `codeListGet?` evaluation at any pair +of codes taking the list and the index as values. -/ +private theorem eval_of_getAt [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] {r : ℕ} (A B : Code r) (l i z : M) (v : Fin r → M) + (hA : Semiformula.Evalb (l :> v) (code A)) (hB : Semiformula.Evalb (i :> v) (code B)) + (hg : GetAt l i z) : Semiformula.Evalb (z :> v) (code (codeListGetOptional A B)) := + by + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + let : M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐈Σ1 from inferInstance) + obtain ⟨d, hh, hd, hhead, hdpos, hz⟩ := hg + have hdrop : Semiformula.Evalb (d :> v) (code (codeListDrop A B)) := + by + rw [codeListDrop_eq_dropCore, eval_comp_iff] + refine ⟨![i, l], by simpa using hd, ?_⟩ + intro j + refine Fin.cases ?_ ?_ j + · simpa using hB + · intro j' + refine Fin.cases ?_ (fun j'' => Fin.elim0 j'') j' + simpa using hA + have hhv : hh = FFL.FirstOrder.Arithmetic.pi₁ (d - 1) := + eval_unique hhead + (head_of_drop (Code.proj (0 : Fin 1)) d ![d] ((eval_proj_iff _ _ _).mpr rfl)) + rw [codeListGetOptional] + exact + eval_codeIfPos_of _ _ _ d (FFL.FirstOrder.Arithmetic.pi₁ (d - 1) + 1) 0 z v hdrop + ((eval_codeSucc_iff _ _ _).mpr ⟨_, head_of_drop _ d v hdrop, rfl⟩) + ((eval_zero_iff _ _).mpr rfl) (Or.inl ⟨hdpos, by rw [hz, hhv]⟩) + +/-! +### An entry older than the last row survives one step back -/ + +-- The history code contains the whole evaluator-cell code, so unifying it +-- against the recursion eliminators exceeds the default heartbeat limit. + +/-- An entry of the history at `j + 1` whose index is below `j` is already an +entry of the history at `j`, with the same value. + +Every evaluation used is supplied: the recursion values come from the successful +table step, and the drop values from the supplied entry. -/ +private theorem getAt_step_down [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] (j i z Hj1 : M) + (hHj1 : Semiformula.Evalb ![Hj1, j + 1] (code codeEvaluatorHistory)) (hij : i < j) + (hget : GetAt Hj1 i z) (hz : 1 < z) : + ∃ Hj : M, Semiformula.Evalb ![Hj, j] (code codeEvaluatorHistory) ∧ GetAt Hj i z := + by + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + let : M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐈Σ1 from inferInstance) + obtain ⟨d, hh, hd, hhead, hdpos, hzv⟩ := hget + rw [codeEvaluatorHistory] at hHj1 + obtain ⟨Hj, hHj, hstep⟩ := eval_codePrec_succ _ _ j Hj1 ![] hHj1 + rw [← codeEvaluatorHistory] at hHj + rw [codeEvaluatorTableStep_eq, eval_codeBind_iff] at hstep + obtain ⟨n', hlen', hsnoc⟩ := hstep + obtain ⟨hd0, hdn⟩ := + drops_of_length _ Hj n' ![j, Hj] ((eval_proj_iff (1 : Fin 2) Hj ![j, Hj]).mpr rfl) hlen' + have hn'j : n' = j := + eval_codeEvaluatorHistory_length_unique j Hj n' (by simpa using hHj) + (length_of_drops _ Hj n' ![Hj] ((eval_proj_iff _ _ _).mpr rfl) hd0 hdn) + rw [hn'j] at hd0 hdn hsnoc hlen' + have hdropJ1 := drop_prefix Hj1 i d hd + rw [historySnocCore_eq] at hsnoc + obtain ⟨a, p, hai, hsa, hdi⟩ := + chain_match _ _ j Hj j Hj1 i hsnoc hdropJ1 i (le_of_lt hij) le_rfl + have hpd : p = d := eval_unique hdi hd + have hapos : 0 < a := + by + rcases eq_or_lt_of_le (FFL.FirstOrder.Arithmetic.zero_le a) with h0 | hpos + · exfalso + rw [← h0, zero_add] at hai + rw [hai] at hij + exact absurd hij (_root_.lt_irrefl j) + · exact hpos + have hpred : a - 1 + 1 = a := + sub_add_self_of_le (FFL.FirstOrder.Arithmetic.pos_iff_one_le.mp hapos) + obtain ⟨q, -, hcons⟩ := eval_codePrec_succ _ _ (a - 1) p ![j, Hj] (by rw [hpred]; exact hsa) + obtain ⟨x, l, hx, hl, hpv⟩ := codeListCons_args _ _ p _ hcons + have hxh : x = hh := + by + have h1 := head_of_drop (Code.proj (0 : Fin 1)) d ![d] ((eval_proj_iff _ _ _).mpr rfl) + have h2 : FFL.FirstOrder.Arithmetic.pi₁ (d - 1) = x := by + rw [← hpd, hpv, add_sub_self, FFL.FirstOrder.Arithmetic.pi₁_pair] + rw [h2] at h1 + exact (eval_unique hhead h1).symm + have hxpos : 0 < x := by + rw [hxh] + rcases eq_or_lt_of_le (FFL.FirstOrder.Arithmetic.zero_le hh) with h0 | hpos + · exfalso + rw [← h0, zero_add] at hzv + rw [hzv] at hz + exact absurd hz (_root_.lt_irrefl 1) + · exact hpos + have hTsrc : + Semiformula.Evalb (Hj :> ![a - 1, q, j, Hj]) + (code (codeLift (codeLift (Code.proj (1 : Fin 2))))) := + (eval_codeLift_iff _ _ _ _).mpr + ((eval_codeLift_iff _ _ _ _).mpr ((eval_proj_iff _ _ _).mpr rfl)) + have hlenlift : + Semiformula.Evalb (j :> ![a - 1, q, j, Hj]) + (code (codeListLength (codeLift (codeLift (Code.proj (1 : Fin 2)))))) := + length_of_drops _ Hj j ![a - 1, q, j, Hj] hTsrc hd0 hdn + have hstepv : + Semiformula.Evalb (a :> ![a - 1, q, j, Hj]) (code (codeSucc (Code.proj (0 : Fin 4)))) := + (eval_codeSucc_iff _ _ _).mpr ⟨a - 1, (eval_proj_iff _ _ _).mpr rfl, hpred.symm⟩ + have hidx : + Semiformula.Evalb (i :> ![a - 1, q, j, Hj]) + (code + (codeSub (codeListLength (codeLift (codeLift (Code.proj (1 : Fin 2))))) + (codeSucc (Code.proj (0 : Fin 4))))) := + by + have hji : j - a = i := sub_remove_left (by rw [← hai, add_comm]) + have := eval_codeSub _ _ j a ![a - 1, q, j, Hj] hlenlift hstepv + rwa [hji] at this + obtain ⟨gv, b₂, hgv, hb₂, hcase⟩ := eval_sub_args _ _ _ _ hx + have hb₂v : b₂ = 1 := + by + have : Semiformula.Evalb ((1 : M) :> ![a - 1, q, j, Hj]) (code (codeConst (n := 4) 1)) := by + rw [eval_codeConst_iff]; simp + exact eval_unique hb₂ this + have hgvz : gv = z := by + rcases hcase with heq | h0 + · rw [← heq, hb₂v, hxh, hzv] + · exfalso + rw [h0] at hxpos + exact absurd hxpos (_root_.lt_irrefl 0) + rw [hgvz] at hgv + obtain ⟨l', i', hl', hi', hgetJ⟩ := + getAt_of_eval _ _ z ![a - 1, q, j, Hj] hgv (lt_trans (by simp) hz) + have hl'v : l' = Hj := eval_unique hl' hTsrc + have hi'v : i' = i := eval_unique hi' hidx + rw [hl'v, hi'v] at hgetJ + exact ⟨Hj, hHj, hgetJ⟩ + +/-! +### An entry below the last row survives one step forward -/ + +-- The history code contains the whole evaluator-cell code, so unifying it +-- against the recursion eliminators exceeds the default heartbeat limit. + +/-- An entry of the history at `j` whose index is below `j` is still an entry of +the history at `j + 1`, with the same value. + +Both history evaluations are supplied. The drops of the extended history up to +the index come from a value of its length, which +`eval_codeListLength_exists_of_value` supplies and +`eval_codeEvaluatorHistory_length_unique` identifies with `j + 1`. -/ +private theorem getAt_step_up [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] (j i z Hj Hj1 : M) + (hHj : Semiformula.Evalb ![Hj, j] (code codeEvaluatorHistory)) + (hHj1 : Semiformula.Evalb ![Hj1, j + 1] (code codeEvaluatorHistory)) (hij : i < j) + (hget : GetAt Hj i z) : GetAt Hj1 i z := by + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + let : M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧 := + models_of_subtheory + (show M↓[ℒₒᵣ] ⊧* 𝐈Σ1 from inferInstance) + -- the drops of the extended history up to index `i` + have hself : Semiformula.Evalb (Hj1 :> ![Hj1]) (code (Code.proj (0 : Fin 1))) := + (eval_proj_iff _ _ _).mpr rfl + obtain ⟨len1, hlen1⟩ := + eval_codeListLength_exists_of_value (Code.proj (0 : Fin 1)) Hj1 ![Hj1] hself + have hlen1v : len1 = j + 1 := + eval_codeEvaluatorHistory_length_unique (j + 1) Hj1 len1 hHj1 hlen1 + obtain ⟨-, hdn1⟩ := drops_of_length _ Hj1 len1 ![Hj1] hself hlen1 + obtain ⟨e, -, he⟩ := hdn1 i (by rw [hlen1v]; exact lt_trans hij (lt_add_one j)) + have hdropJ1 := drop_prefix Hj1 i e he + rw [codeEvaluatorHistory] at hHj1 + obtain ⟨H', hH', hstep⟩ := eval_codePrec_succ _ _ j Hj1 ![] hHj1 + rw [← codeEvaluatorHistory] at hH' + have hH'j : H' = Hj := + eval_unique (show Semiformula.Evalb ![H', j] (code codeEvaluatorHistory) by simpa using hH') + hHj + rw [hH'j] at hstep + rw [codeEvaluatorTableStep_eq, eval_codeBind_iff] at hstep + obtain ⟨n', hlen', hsnoc⟩ := hstep + obtain ⟨hd0, hdn⟩ := + drops_of_length _ Hj n' ![j, Hj] ((eval_proj_iff (1 : Fin 2) Hj ![j, Hj]).mpr rfl) hlen' + have hn'j : n' = j := + eval_codeEvaluatorHistory_length_unique j Hj n' hHj + (length_of_drops _ Hj n' ![Hj] ((eval_proj_iff _ _ _).mpr rfl) hd0 hdn) + rw [hn'j] at hd0 hdn hsnoc + rw [historySnocCore_eq] at hsnoc + obtain ⟨a, p, hai, hsa, hdi⟩ := + chain_match _ _ j Hj j Hj1 i hsnoc hdropJ1 i (le_of_lt hij) le_rfl + have hapos : 0 < a := + by + rcases + eq_or_lt_of_le (FFL.FirstOrder.Arithmetic.zero_le a) with + h0 | hpos + · exfalso + rw [← h0, zero_add] at hai + rw [hai] at hij + exact absurd hij (_root_.lt_irrefl j) + · exact hpos + have hpred : a - 1 + 1 = a := + sub_add_self_of_le + (FFL.FirstOrder.Arithmetic.pos_iff_one_le.mp hapos) + obtain ⟨q, -, hcons⟩ := eval_codePrec_succ _ _ (a - 1) p ![j, Hj] (by rw [hpred]; exact hsa) + obtain ⟨x, l, hx, -, hpv⟩ := codeListCons_args _ _ p _ hcons + have hTsrc : + Semiformula.Evalb (Hj :> ![a - 1, q, j, Hj]) + (code (codeLift (codeLift (Code.proj (1 : Fin 2))))) := + (eval_codeLift_iff _ _ _ _).mpr + ((eval_codeLift_iff _ _ _ _).mpr ((eval_proj_iff _ _ _).mpr rfl)) + have hlenlift : + Semiformula.Evalb (j :> ![a - 1, q, j, Hj]) + (code (codeListLength (codeLift (codeLift (Code.proj (1 : Fin 2)))))) := + length_of_drops _ Hj j ![a - 1, q, j, Hj] hTsrc hd0 hdn + have hstepv : + Semiformula.Evalb (a :> ![a - 1, q, j, Hj]) (code (codeSucc (Code.proj (0 : Fin 4)))) := + (eval_codeSucc_iff _ _ _).mpr ⟨a - 1, (eval_proj_iff _ _ _).mpr rfl, hpred.symm⟩ + have hidx : + Semiformula.Evalb (i :> ![a - 1, q, j, Hj]) + (code + (codeSub (codeListLength (codeLift (codeLift (Code.proj (1 : Fin 2))))) + (codeSucc (Code.proj (0 : Fin 4))))) := + by + have hji : j - a = i := sub_remove_left (by rw [← hai, add_comm]) + have := eval_codeSub _ _ j a ![a - 1, q, j, Hj] hlenlift hstepv + rwa [hji] at this + have hone : Semiformula.Evalb ((1 : M) :> ![a - 1, q, j, Hj]) (code (codeConst (n := 4) 1)) := + by rw [eval_codeConst_iff]; simp + have hxz : x = z - 1 := + eval_unique hx + (eval_codeSub _ (codeConst 1) z 1 ![a - 1, q, j, Hj] + (eval_of_getAt _ _ Hj i z ![a - 1, q, j, Hj] hTsrc hidx hget) hone) + -- the drop of the extended history at `i` is that cons + obtain ⟨-, hh, -, -, -, hzv⟩ := hget + refine + ⟨p, FFL.FirstOrder.Arithmetic.pi₁ (p - 1), hdi, + head_of_drop (Code.proj (0 : Fin 1)) p ![p] ((eval_proj_iff _ _ _).mpr rfl), ?_, ?_⟩ + · rw [hpv] + exact lt_of_lt_of_le _root_.zero_lt_one le_add_self + · rw [hpv, add_sub_self, FFL.FirstOrder.Arithmetic.pi₁_pair, + hxz, hzv, add_sub_self] + +/-! +### Descending to the stage that first records the row -/ + +-- The history code contains the whole evaluator-cell code. + +/-- An entry recorded at a later stage was already recorded at the first stage +past its index. -/ +private theorem getAt_descend [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] (m i z Hm : M) + (hHm : Semiformula.Evalb ![Hm, m] (code codeEvaluatorHistory)) (hget : GetAt Hm i z) + (hz : 1 < z) (hle : i + 1 ≤ m) : + ∃ H : M, Semiformula.Evalb ![H, i + 1] (code codeEvaluatorHistory) ∧ GetAt H i z := + by + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + let : M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐈Σ1 from inferInstance) + have hHist : + Σ-[1].Definable + (fun w : Fin 5 → M => Semiformula.Evalb ![w 2, w 3] (code codeEvaluatorHistory)) := + by + refine + ((definable_code_graph (M := M) codeEvaluatorHistory).retractiont (f := + ![(#2 : ArithmeticSemiterm M 5), #3])).of_iff + ?_ + intro w + have he : + (fun j => Semiterm.val w id (![(#2 : ArithmeticSemiterm M 5), #3] j)) = ![w 2, w 3] := + by + funext j + refine Fin.cases ?_ ?_ j + · simp + · intro j1 + refine Fin.cases ?_ (fun j2 => Fin.elim0 j2) j1 + simp + rw [he] + have hDrop : + Σ-[1].Definable (fun w : Fin 5 → M => Semiformula.Evalb ![w 1, i, w 2] (code dropCore)) := + by + refine + ((definable_code_graph (M := M) dropCore).retractiont (f := + ![(#1 : ArithmeticSemiterm M 5), &i, #2])).of_iff + ?_ + intro w + have he : + (fun j => Semiterm.val w id (![(#1 : ArithmeticSemiterm M 5), &i, #2] j)) = + ![w 1, i, w 2] := + by + funext j + refine Fin.cases ?_ ?_ j + · simp + · intro j1 + refine Fin.cases ?_ ?_ j1 + · simp + · intro j2 + refine Fin.cases ?_ (fun j3 => Fin.elim0 j3) j2 + simp + rw [he] + have hHead : + Σ-[1].Definable + (fun w : Fin 5 → M => + Semiformula.Evalb ![w 0, w 1] + (code (codeUnpair₁ (codeSub (Code.proj (0 : Fin 1)) (codeConst 1))))) := + by + refine + ((definable_code_graph (M := M) + (codeUnpair₁ (codeSub (Code.proj (0 : Fin 1)) (codeConst 1)))).retractiont + (f := ![(#0 : ArithmeticSemiterm M 5), #1])).of_iff + ?_ + intro w + have he : + (fun j => Semiterm.val w id (![(#0 : ArithmeticSemiterm M 5), #1] j)) = ![w 0, w 1] := + by + funext j + refine Fin.cases ?_ ?_ j + · simp + · intro j1 + refine Fin.cases ?_ (fun j2 => Fin.elim0 j2) j1 + simp + rw [he] + have hdef : + Σ-[1].DefinablePred + (fun t : M => + i + 1 + t ≤ m → + ∃ j H d hd : M, + j + t = m ∧ + Semiformula.Evalb ![H, j] (code codeEvaluatorHistory) ∧ + Semiformula.Evalb ![d, i, H] (code dropCore) ∧ + Semiformula.Evalb ![hd, d] + (code (codeUnpair₁ (codeSub (Code.proj (0 : Fin 1)) (codeConst 1)))) ∧ + 0 < d ∧ z = hd + 1) := + by + have hbody : + Σ-[1].Definable + (fun w : Fin 5 → M => + w 3 + w 4 = m ∧ + Semiformula.Evalb ![w 2, w 3] (code codeEvaluatorHistory) ∧ + Semiformula.Evalb ![w 1, i, w 2] (code dropCore) ∧ + Semiformula.Evalb ![w 0, w 1] + (code (codeUnpair₁ (codeSub (Code.proj (0 : Fin 1)) (codeConst 1)))) ∧ + 0 < w 1 ∧ z = w 0 + 1) := + (by definability : Σ-[1].Definable (fun w : Fin 5 → M => w 3 + w 4 = m)).and + (hHist.and (hDrop.and (hHead.and (by definability)))) + exact + HierarchySymbol.Definable.imp (by definability) + (HierarchySymbol.Definable.exs + (HierarchySymbol.Definable.exs + (HierarchySymbol.Definable.exs (HierarchySymbol.Definable.exs hbody)))) + have hall : + ∀ t : M, + i + 1 + t ≤ m → + ∃ j H d hd : M, + j + t = m ∧ + Semiformula.Evalb ![H, j] (code codeEvaluatorHistory) ∧ + Semiformula.Evalb ![d, i, H] (code dropCore) ∧ + Semiformula.Evalb ![hd, d] + (code (codeUnpair₁ (codeSub (Code.proj (0 : Fin 1)) (codeConst 1)))) ∧ + 0 < d ∧ z = hd + 1 := + by + refine InductionOnHierarchy.succ_induction Σ 1 hdef ?_ ?_ + · intro _ + obtain ⟨d, hd, h1, h2, h3, h4⟩ := hget + exact ⟨m, Hm, d, hd, add_zero m, hHm, h1, h2, h3, h4⟩ + · intro t IH ht + have ht' : i + 1 + t ≤ m := le_trans (by rw [← add_assoc]; exact le_self_add) ht + obtain ⟨j, H, d, hd, hjt, hH, h1, h2, h3, h4⟩ := IH ht' + have hij2 : i + 1 + 1 ≤ j := + by + have hh : i + 1 + (t + 1) ≤ j + t := by rw [hjt]; exact ht + rw [← add_assoc, add_right_comm (i + 1) t 1] at hh + exact le_of_add_le_add_right hh + have hjpos : 0 < j := lt_of_lt_of_le (by simp) hij2 + have hpred : j - 1 + 1 = j := + sub_add_self_of_le (FFL.FirstOrder.Arithmetic.pos_iff_one_le.mp hjpos) + have hij : i < j - 1 := + by + have : i + 1 ≤ j - 1 := by + have h := hij2 + rw [← hpred] at h + exact le_of_add_le_add_right h + exact lt_of_lt_of_le (by simp) this + obtain ⟨H', hH', hget'⟩ := + getAt_step_down (j - 1) i z H (by rw [hpred]; exact hH) hij ⟨d, hd, h1, h2, h3, h4⟩ hz + obtain ⟨d', hd', g1, g2, g3, g4⟩ := hget' + refine ⟨j - 1, H', d', hd', ?_, hH', g1, g2, g3, g4⟩ + calc + j - 1 + (t + 1) = (j - 1 + 1) + t := by rw [add_comm t 1, ← add_assoc] + _ = j + t := by rw [hpred] + _ = m := hjt + obtain ⟨j, H, d, hd, hjt, hH, h1, h2, h3, h4⟩ := + hall (m - (i + 1)) (by rw [add_tsub_self_of_le hle]) + have hjeq : j = i + 1 := + by + have hb : i + 1 + (m - (i + 1)) = m := add_tsub_self_of_le hle + exact add_right_cancel (hjt.trans hb.symm) + rw [hjeq] at hH + exact ⟨H, hH, d, hd, h1, h2, h3, h4⟩ + +/-! +### A positive lookup at an earlier stage -/ + +/-- The argument of a successfully evaluated first Cantor component has a +value. -/ +private theorem unpair₁_arg [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (X : Code r) (z : M) (v : Fin r → M) + (h : Semiformula.Evalb (z :> v) (code (codeUnpair₁ X))) : + ∃ a : M, Semiformula.Evalb (a :> v) (code X) := + by + rw [codeUnpair₁] at h + obtain ⟨t, ht, -⟩ := eval_codeIfPos_cases _ _ _ _ _ h + rw [eval_codeLt_iff] at ht + obtain ⟨u, -, hu, -, -⟩ := ht + obtain ⟨a, -, ha, -, -⟩ := eval_sub_args _ _ _ _ hu + exact ⟨a, ha⟩ + +/-- An entry of the empty list is impossible. -/ +private theorem getAt_nil_absurd [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] (n z : M) (hg : GetAt 0 n z) : False := by + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + let : M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐈Σ1 from inferInstance) + obtain ⟨d, -, hd, -, hdpos, -⟩ := hg + have hdrop := drop_prefix 0 n d hd + obtain ⟨z₀, hz₀⟩ := + hdrop 0 (FFL.FirstOrder.Arithmetic.zero_le n) + have hz₀0 : z₀ = 0 := dropCore_zero 0 z₀ hz₀ + rw [hz₀0] at hz₀ + have := + drops_zero_from 0 0 n hz₀ hdrop n + (FFL.FirstOrder.Arithmetic.zero_le n) le_rfl + rw [eval_unique hd this] at hdpos + exact absurd hdpos (_root_.lt_irrefl 0) + +-- The history-evaluator code contains the whole evaluator-cell code. + +/-- A successful lookup of an earlier row in the history at a later stage is +already a successful `codeHistoryEvaluator` evaluation at that earlier stage. + +`𝐈𝐎𝐩𝐞𝐧` is listed only so that Foundation's `pair` elaborates in the +statement; it is implied by `𝐏𝐀`. -/ +theorem eval_codeHistoryEvaluator_succ_of_prefix_lookup [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + (s qCode n y : M) (q : ℕ) + (hprefix : + FFL.FirstOrder.Arithmetic.pair s ((q : ℕ) : M) < + FFL.FirstOrder.Arithmetic.pair s qCode) + (h : + Semiformula.Evalb ((y + 1) :> ![s, qCode, n]) + (code + (codeTableLookup codeEvaluatorHistoryBeforeCell + (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell)) (codeConst (n := 3) q) + (Code.proj (2 : Fin 3))))) : + Semiformula.Evalb ![y + 1, s, ((q : ℕ) : M), n] (code codeHistoryEvaluator) := by + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + have hone : ∀ w : Fin 3 → M, Semiformula.Evalb ((1 : M) :> w) (code (codeConst (n := 3) 1)) := + by intro w; rw [eval_codeConst_iff]; simp + rw [codeTableLookup_eq] at h + obtain ⟨G2, b₀, hG2, hb₀, hcase₀⟩ := eval_sub_args _ _ _ _ h + have hG2v : G2 = y + 1 + 1 := by + rcases hcase₀ with heq | h0 + · rw [← heq, eval_unique hb₀ (hone _)] + · exact absurd h0.symm (zero_ne_add_one y) + rw [hG2v] at hG2 + obtain ⟨rowv, n₀, hrow, hn₀, hgetRow⟩ := getAt_of_eval _ _ _ _ hG2 (by simp) + have hn₀v : n₀ = n := by + simpa using eval_unique hn₀ ((eval_proj_iff (2 : Fin 3) n ![s, qCode, n]).mpr rfl) + rw [hn₀v] at hgetRow + obtain ⟨G1, b₁, hG1, hb₁, hcase₁⟩ := eval_sub_args _ _ _ _ hrow + have hrowpos : 0 < rowv := + by + rcases + eq_or_lt_of_le (FFL.FirstOrder.Arithmetic.zero_le rowv) with + h0 | hp + · exact + absurd (getAt_nil_absurd n (y + 1 + 1) (by rw [← h0] at hgetRow; exact hgetRow)) + not_false + · exact hp + have hG1v : G1 = rowv + 1 := by + rcases hcase₁ with heq | h0 + · rw [← heq, eval_unique hb₁ (hone _)] + · exfalso + rw [h0] at hrowpos + exact absurd hrowpos (_root_.lt_irrefl 0) + rw [hG1v] at hG1 + obtain ⟨Hm, i₀, hHm, hi₀, hgetHm⟩ := + getAt_of_eval _ _ _ _ hG1 + (by simp) + -- the history is the one at the pair of `s` and `qCode` + have hbefore := hHm + rw [codeEvaluatorHistoryBeforeCell, eval_comp_iff] at hbefore + obtain ⟨w, hhist, hwi⟩ := hbefore + have hpv := hwi 0 + simp only [Matrix.cons_val_zero] at hpv + have hmv : w 0 = FFL.FirstOrder.Arithmetic.pair s qCode := + eval_unique hpv + (eval_codePair _ _ s qCode ![s, qCode, n] ((eval_proj_iff _ _ _).mpr rfl) + ((eval_proj_iff _ _ _).mpr rfl)) + have hshape : w = (w 0) :> ![] := by + funext j + refine Fin.cases ?_ (fun j' => Fin.elim0 j') j + rfl + rw [hshape, hmv] at hhist + obtain ⟨fu, cqv, hfu, hcq⟩ := codePair_args _ _ _ _ hi₀ + obtain ⟨lenv, hlenv⟩ := + unpair₁_arg (codeListLength codeEvaluatorHistoryBeforeCell) fu ![s, qCode, n] hfu + obtain ⟨hd0, hdn⟩ := drops_of_length _ Hm lenv ![s, qCode, n] hHm hlenv + have hlenm : lenv = FFL.FirstOrder.Arithmetic.pair s qCode := + eval_codeEvaluatorHistory_length_unique _ Hm lenv hhist + (length_of_drops _ Hm lenv ![Hm] ((eval_proj_iff _ _ _).mpr rfl) hd0 hdn) + have hi₀v : + i₀ = FFL.FirstOrder.Arithmetic.pair s ((q : ℕ) : M) := + by + have hfuv : fu = s := + by + have hu := eval_unique hfu (eval_codeUnpair₁ _ lenv ![s, qCode, n] hlenv) + rw [hu, hlenm, FFL.FirstOrder.Arithmetic.pi₁_pair] + have hcqv : cqv = ((q : ℕ) : M) := by rw [eval_codeConst_iff] at hcq; exact hcq + rw [eval_unique hi₀ (eval_codePair _ _ fu cqv ![s, qCode, n] hfu hcq), hfuv, hcqv] + rw [hi₀v] at hgetHm + obtain ⟨H, hH, hgetH⟩ := + getAt_descend _ _ _ Hm hhist hgetHm (by simpa using hrowpos) + (FFL.FirstOrder.Arithmetic.succ_le_iff_lt.mpr hprefix) + -- reassemble the history-evaluator evaluation at the earlier stage + rw [codeHistoryEvaluator, codeTableLookup_eq] + have hpair : + Semiformula.Evalb + (FFL.FirstOrder.Arithmetic.pair s ((q : ℕ) : M) :> + ![s, ((q : ℕ) : M), n]) + (code (codePair (Code.proj (0 : Fin 3)) (Code.proj (1 : Fin 3)))) := + eval_codePair _ _ s _ ![s, ((q : ℕ) : M), n] ((eval_proj_iff _ _ _).mpr rfl) + ((eval_proj_iff _ _ _).mpr rfl) + have htab : + Semiformula.Evalb (H :> ![s, ((q : ℕ) : M), n]) + (code + (codeEvaluatorHistory.comp + ![codeSucc (codePair (Code.proj (0 : Fin 3)) (Code.proj (1 : Fin 3)))])) := + by + rw [eval_comp_iff] + refine + ⟨![FFL.FirstOrder.Arithmetic.pair s ((q : ℕ) : M) + 1], by + simpa using hH, ?_⟩ + intro j + refine Fin.cases ?_ (fun j' => Fin.elim0 j') j + simpa using (eval_codeSucc_iff _ _ _).mpr ⟨_, hpair, rfl⟩ + have hget1 := eval_of_getAt _ _ H _ (rowv + 1) ![s, ((q : ℕ) : M), n] htab hpair hgetH + have hsub1 := + eval_codeSub _ (codeConst 1) (rowv + 1) 1 ![s, ((q : ℕ) : M), n] hget1 + (by rw [eval_codeConst_iff]; simp) + rw [add_sub_self] at hsub1 + have hget2 := + eval_of_getAt _ (Code.proj (2 : Fin 3)) rowv n (y + 1 + 1) ![s, ((q : ℕ) : M), n] hsub1 + ((eval_proj_iff _ _ _).mpr rfl) hgetRow + have hsub2 := + eval_codeSub _ (codeConst 1) (y + 1 + 1) 1 ![s, ((q : ℕ) : M), n] hget2 + (by rw [eval_codeConst_iff]; simp) + rw [add_sub_self] at hsub2 + simpa using hsub2 + +/-! +### Totality of one evaluation row -/ + +/-- The row of a table has a value at any value of the table. + +The row is primitive recursion on the fuel read from the table length, so +`eval_codePrec_exists_of_total` applies: the base is the empty list and the step +conses one evaluator cell onto the row built so far. The step is constructed at +every recursion index and every predecessor row, the terminal index included, +because the bounded search inside `codePrec` evaluates its step there as well. + +Only existence is asserted. Nothing here decodes the row, and `table` is not +assumed to encode a well-formed table. -/ +theorem eval_codeEvaluatorRow_exists_of_value [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] {r : ℕ} (dtable : Code r) + (table : M) (v : Fin r → M) (htable : Semiformula.Evalb (table :> v) (code dtable)) : + ∃ row : M, Semiformula.Evalb (row :> v) (code (codeEvaluatorRow dtable)) := + by + let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + obtain ⟨p, hp⟩ := eval_codeListLength_exists_of_value dtable table v htable + have hbound := eval_codeUnpair₁ (codeListLength dtable) p v hp + have hbase : ∃ z : M, Semiformula.Evalb (z :> v) (code (codeListNil (n := r))) := + ⟨0, (eval_zero_iff _ _).mpr rfl⟩ + have hstep : + ∀ i : M, + i ≤ FFL.FirstOrder.Arithmetic.pi₁ p → + ∀ row : M, + ∃ w : M, + Semiformula.Evalb (w :> i :> row :> v) + (code + (codeListCons + (codeEvaluatorCell (codeLift (codeLift dtable)) + (codeSub (codeUnpair₁ (codeListLength (codeLift (codeLift dtable)))) + (codeSucc (Code.proj (0 : Fin (r + 2)))))) + (Code.proj (1 : Fin (r + 2))))) := + by + intro i _ row + have htable₁ : Semiformula.Evalb (table :> row :> v) (code (codeLift dtable)) := + (eval_codeLift_iff dtable table row v).mpr htable + have htable₂ : + Semiformula.Evalb (table :> i :> row :> v) (code (codeLift (codeLift dtable))) := + (eval_codeLift_iff (codeLift dtable) table i (row :> v)).mpr htable₁ + obtain ⟨pi, hpi⟩ := + eval_codeListLength_exists_of_value (codeLift (codeLift dtable)) table (i :> row :> v) + htable₂ + have hbi := + eval_codeUnpair₁ (codeListLength (codeLift (codeLift dtable))) pi (i :> row :> v) hpi + have hidx : Semiformula.Evalb (i :> i :> row :> v) (code (Code.proj (0 : Fin (r + 2)))) := + (eval_proj_iff _ _ _).mpr rfl + have hsucc : + Semiformula.Evalb ((i + 1) :> i :> row :> v) + (code (codeSucc (Code.proj (0 : Fin (r + 2))))) := + (eval_codeSucc_iff _ _ _).mpr ⟨i, hidx, rfl⟩ + have hrev := eval_codeSub _ _ _ (i + 1) (i :> row :> v) hbi hsucc + obtain ⟨c, hc⟩ := + eval_codeEvaluatorCell_exists_of_values (codeLift (codeLift dtable)) _ table _ + (i :> row :> v) htable₂ hrev + have hrow : Semiformula.Evalb (row :> i :> row :> v) (code (Code.proj (1 : Fin (r + 2)))) := + (eval_proj_iff _ _ _).mpr (by simp) + exact eval_codeListCons_exists_of_values _ _ c row (i :> row :> v) hc hrow + obtain ⟨w, hw⟩ := eval_codePrec_exists_of_total _ _ _ v hbase hstep + refine ⟨w, ?_⟩ + rw [codeEvaluatorRow_eq_bind, eval_codeBind_iff] + exact ⟨_, hbound, hw⟩ + +/-- Extending a table by one row has a value at any value of the table. + +The row has a value by `eval_codeEvaluatorRow_exists_of_value`, and appending it +has a value by `eval_codeListSnoc_exists_of_values`. Only existence is +asserted: neither the table nor the row is decoded. -/ +theorem eval_codeEvaluatorTableStep_exists_of_value [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] {r : ℕ} (dtable : Code r) + (table : M) (v : Fin r → M) (htable : Semiformula.Evalb (table :> v) (code dtable)) : + ∃ table' : M, Semiformula.Evalb (table' :> v) (code (codeEvaluatorTableStep dtable)) := + by + obtain ⟨row, hrow⟩ := eval_codeEvaluatorRow_exists_of_value dtable table v htable + exact + eval_codeListSnoc_exists_of_values dtable (codeEvaluatorRow dtable) table row v htable hrow + +/-- The history has a value at every stage. + +The history is `codePrec` with base `codeListNil` and step +`codeEvaluatorTableStep` applied to the projection onto the predecessor table, +so `eval_codePrec_exists_of_total` applies: the base has value `0`, and the step +has a value by `eval_codeEvaluatorTableStep_exists_of_value`. The step is +constructed at every recursion index and every predecessor table, the terminal +index included, because the bounded search inside `codePrec` evaluates its step +there as well. + +Only existence is asserted. Nothing here decodes the history or any table in +it. -/ +theorem eval_codeEvaluatorHistory_exists [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] (m : M) : + ∃ H : M, Semiformula.Evalb ![H, m] (code codeEvaluatorHistory) := + by + have hbase : ∃ z : M, Semiformula.Evalb (z :> ![]) (code (codeListNil (n := 0))) := + ⟨0, (eval_zero_iff _ _).mpr rfl⟩ + have hstep : + ∀ i : M, + i ≤ m → + ∀ table : M, + ∃ w : M, + Semiformula.Evalb (w :> i :> table :> ![]) + (code (codeEvaluatorTableStep (Code.proj (1 : Fin 2)))) := + by + intro i _ table + exact + eval_codeEvaluatorTableStep_exists_of_value (Code.proj (1 : Fin 2)) table + (i :> table :> ![]) ((eval_proj_iff _ _ _).mpr (by simp)) + exact eval_codePrec_exists_of_total _ _ m ![] hbase hstep + +/-! +### The history and cell arguments read before the cell -/ + +/-- The history one step before the cell has a value at every argument triple, +and that value is the history at the pair of the first two arguments. + +`codeEvaluatorHistoryBeforeCell` is `codeEvaluatorHistory` composed with the +pair of the first two projections. History totality, +`eval_codeEvaluatorHistory_exists`, gives the history a value `H` at the stage +`pair s qCode`, and `eval_codePair` gives the composed argument that value. -/ +theorem eval_codeEvaluatorHistoryBeforeCell_exists [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + (s qCode u : M) : + ∃ H : M, + Semiformula.Evalb (H :> ![s, qCode, u]) (code codeEvaluatorHistoryBeforeCell) ∧ + Semiformula.Evalb ![H, FFL.FirstOrder.Arithmetic.pair s qCode] + (code codeEvaluatorHistory) := + by + obtain ⟨H, hH⟩ := eval_codeEvaluatorHistory_exists (FFL.FirstOrder.Arithmetic.pair s qCode) + refine ⟨H, ?_, hH⟩ + have hpair : + Semiformula.Evalb (FFL.FirstOrder.Arithmetic.pair s qCode :> ![s, qCode, u]) + (code (codePair (Code.proj (0 : Fin 3)) (Code.proj (1 : Fin 3)))) := + eval_codePair _ _ s qCode ![s, qCode, u] ((eval_proj_iff _ _ _).mpr rfl) + ((eval_proj_iff _ _ _).mpr rfl) + rw [codeEvaluatorHistoryBeforeCell, eval_comp_iff] + refine ⟨![FFL.FirstOrder.Arithmetic.pair s qCode], by simpa using hH, ?_⟩ + intro i + refine Fin.cases ?_ (fun j => Fin.elim0 j) i + simpa using hpair + +/-- The length of the history read before the cell is the pair of the first +two arguments. + +The history has a value by `eval_codeEvaluatorHistoryBeforeCell_exists`, its +length has a value by `eval_codeListLength_exists_of_value`, and +`eval_codeEvaluatorHistory_length_unique` identifies that value with the stage +`pair s qCode`. -/ +theorem eval_codeEvaluatorHistoryBeforeCell_length [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] (s qCode u : M) : + Semiformula.Evalb (FFL.FirstOrder.Arithmetic.pair s qCode :> ![s, qCode, u]) + (code (codeListLength codeEvaluatorHistoryBeforeCell)) := + by + obtain ⟨H, hbefore, hH⟩ := eval_codeEvaluatorHistoryBeforeCell_exists s qCode u + obtain ⟨lenv, hlenv⟩ := + eval_codeListLength_exists_of_value codeEvaluatorHistoryBeforeCell H ![s, qCode, u] hbefore + have hcongr : + Semiformula.Evalb (lenv :> ![s, qCode, u]) + (code (codeListLength codeEvaluatorHistoryBeforeCell)) ↔ + Semiformula.Evalb (lenv :> ![H]) (code (codeListLength (Code.proj (0 : Fin 1)))) := + by + refine eval_codeListLength_congr_at _ _ lenv ![s, qCode, u] ![H] ?_ + intro x + constructor + · intro hx + have hxH : x = H := eval_unique hx hbefore + rw [hxH] + exact (eval_proj_iff _ _ _).mpr rfl + · intro hx + have hxH : x = H := by + simpa using eval_unique hx ((eval_proj_iff (0 : Fin 1) H ![H]).mpr rfl) + rw [hxH] + exact hbefore + have hlen1 : Semiformula.Evalb ![lenv, H] (code (codeListLength (Code.proj (0 : Fin 1)))) := + by simpa using hcongr.mp hlenv + have hval : lenv = FFL.FirstOrder.Arithmetic.pair s qCode := + eval_codeEvaluatorHistory_length_unique _ H lenv hH hlen1 + rw [← hval] + exact hlenv + +/-- The fuel that the evaluator cell reads, the first component of the history +length, is the first argument. -/ +theorem eval_codeEvaluatorCell_fuel [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] + (s qCode u : M) : + Semiformula.Evalb (s :> ![s, qCode, u]) + (code (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell))) := + by + have h := + eval_codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell) + (FFL.FirstOrder.Arithmetic.pair s qCode) ![s, qCode, u] + (eval_codeEvaluatorHistoryBeforeCell_length s qCode u) + rwa [FFL.FirstOrder.Arithmetic.pi₁_pair] at h + +/-- The program index that the evaluator cell reads, the second component of +the history length, is the second argument. -/ +theorem eval_codeEvaluatorCell_index [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] + (s qCode u : M) : + Semiformula.Evalb (qCode :> ![s, qCode, u]) + (code (codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell))) := + by + have h := + eval_codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell) + (FFL.FirstOrder.Arithmetic.pair s qCode) ![s, qCode, u] + (eval_codeEvaluatorHistoryBeforeCell_length s qCode u) + rwa [FFL.FirstOrder.Arithmetic.pi₂_pair] at h + +/-- The history evaluator has a value at every argument triple. + +At `s, qCode, u` the three projections have values `s`, `qCode` and `u`, the +pair of the first two has value `pair s qCode` by `eval_codePair`, and its +successor has value `pair s qCode + 1`. The history has a value `H` at that +stage by `eval_codeEvaluatorHistory_exists`, so the composed table argument of +`codeTableLookup` has value `H`, and the lookup has a value by +`eval_codeTableLookup_exists_of_values`. `𝐈𝐎𝐩𝐞𝐧` is installed inside the proof +for `eval_codePair` and is derived from `𝐏𝐀` through `𝐈Σ 1`. + +Only existence is asserted. Nothing here decodes the history, the table, or +the program index. -/ +theorem eval_codeHistoryEvaluator_exists [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] (s qCode u : M) : + ∃ z : M, Semiformula.Evalb ![z, s, qCode, u] (code codeHistoryEvaluator) := + by + let : M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧 := + models_of_subtheory (U := 𝐈Σ1) (models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance)) + have hs : Semiformula.Evalb (s :> ![s, qCode, u]) (code (Code.proj (0 : Fin 3))) := + (eval_proj_iff _ _ _).mpr rfl + have hq : Semiformula.Evalb (qCode :> ![s, qCode, u]) (code (Code.proj (1 : Fin 3))) := + (eval_proj_iff _ _ _).mpr rfl + have hu : Semiformula.Evalb (u :> ![s, qCode, u]) (code (Code.proj (2 : Fin 3))) := + (eval_proj_iff _ _ _).mpr rfl + have hpair := eval_codePair _ _ s qCode ![s, qCode, u] hs hq + have hsucc : + Semiformula.Evalb ((FFL.FirstOrder.Arithmetic.pair s qCode + 1) :> ![s, qCode, u]) + (code (codeSucc (codePair (Code.proj (0 : Fin 3)) (Code.proj (1 : Fin 3))))) := + (eval_codeSucc_iff _ _ _).mpr ⟨_, hpair, rfl⟩ + obtain ⟨H, hH⟩ := + eval_codeEvaluatorHistory_exists (FFL.FirstOrder.Arithmetic.pair s qCode + 1) + have htab : + Semiformula.Evalb (H :> ![s, qCode, u]) + (code + (codeEvaluatorHistory.comp + ![codeSucc (codePair (Code.proj (0 : Fin 3)) (Code.proj (1 : Fin 3)))])) := + (eval_comp_iff _ _ _ _).mpr + ⟨![FFL.FirstOrder.Arithmetic.pair s qCode + 1], hH, Fin.forall_fin_one.mpr hsucc⟩ + exact eval_codeTableLookup_exists_of_values _ _ _ _ H s qCode u ![s, qCode, u] htab hs hq hu + +/-! +### The same lookup at a later stage -/ + +-- The history-evaluator code contains the whole evaluator-cell code. + +/-- A successful `codeHistoryEvaluator` evaluation at `s, q, n` is a successful +lookup of the same row, with the fixed query `q`, in the history before the cell +at `s, qCode, n`, whenever the pair of `s` and `q` is below the pair of `s` and +`qCode`. + +This is the converse of `eval_codeHistoryEvaluator_succ_of_prefix_lookup`. The +row is an entry of the history one step past the pair of `s` and `q`. An +induction on the stage, `InductionOnHierarchy.succ_induction` on a Sigma-one +condition, shows that it is an entry of the history at every later stage up to +the pair of `s` and `qCode`: `eval_codeEvaluatorHistory_exists` gives each next +history a value, and `getAt_step_up` preserves the entry. + +`𝐈𝐎𝐩𝐞𝐧` is listed only so that Foundation's `pair` elaborates in the +statement; it is implied by `𝐏𝐀`. -/ +private theorem history_ascent_definable : + ∀ P C z : M, + Σ-[1].DefinablePred + (fun t : M => + P + 1 + t ≤ C → + ∃ j H' d hd : M, + P + 1 + t = j ∧ + Semiformula.Evalb ![H', j] (code codeEvaluatorHistory) ∧ + Semiformula.Evalb ![d, P, H'] (code dropCore) ∧ + Semiformula.Evalb ![hd, d] + (code (codeUnpair₁ (codeSub (Code.proj (0 : Fin 1)) (codeConst 1)))) ∧ + 0 < d ∧ z = hd + 1) := + by + intro P C z + have hHist : + Σ-[1].Definable + (fun w : Fin 5 → M => Semiformula.Evalb ![w 2, w 3] (code codeEvaluatorHistory)) := + by + refine + ((definable_code_graph (M := M) codeEvaluatorHistory).retractiont (f := + ![(#2 : ArithmeticSemiterm M 5), #3])).of_iff + ?_ + intro w + have he : + (fun j => Semiterm.val w id (![(#2 : ArithmeticSemiterm M 5), #3] j)) = ![w 2, w 3] := + by + funext j + refine Fin.cases ?_ ?_ j + · simp + · intro j1 + refine Fin.cases ?_ (fun j2 => Fin.elim0 j2) j1 + simp + rw [he] + have hDrop : + Σ-[1].Definable (fun w : Fin 5 → M => Semiformula.Evalb ![w 1, P, w 2] (code dropCore)) := + by + refine + ((definable_code_graph (M := M) dropCore).retractiont (f := + ![(#1 : ArithmeticSemiterm M 5), &P, #2])).of_iff + ?_ + intro w + have he : + (fun j => Semiterm.val w id (![(#1 : ArithmeticSemiterm M 5), &P, #2] j)) = + ![w 1, P, w 2] := + by + funext j + refine Fin.cases ?_ ?_ j + · simp + · intro j1 + refine Fin.cases ?_ ?_ j1 + · simp + · intro j2 + refine Fin.cases ?_ (fun j3 => Fin.elim0 j3) j2 + simp + rw [he] + have hHead : + Σ-[1].Definable + (fun w : Fin 5 → M => + Semiformula.Evalb ![w 0, w 1] + (code (codeUnpair₁ (codeSub (Code.proj (0 : Fin 1)) (codeConst 1))))) := + by + refine + ((definable_code_graph (M := M) + (codeUnpair₁ (codeSub (Code.proj (0 : Fin 1)) (codeConst 1)))).retractiont + (f := ![(#0 : ArithmeticSemiterm M 5), #1])).of_iff + ?_ + intro w + have he : + (fun j => Semiterm.val w id (![(#0 : ArithmeticSemiterm M 5), #1] j)) = ![w 0, w 1] := + by + funext j + refine Fin.cases ?_ ?_ j + · simp + · intro j1 + refine Fin.cases ?_ (fun j2 => Fin.elim0 j2) j1 + simp + rw [he] + have hbody : + Σ-[1].Definable + (fun w : Fin 5 → M => + P + 1 + w 4 = w 3 ∧ + Semiformula.Evalb ![w 2, w 3] (code codeEvaluatorHistory) ∧ + Semiformula.Evalb ![w 1, P, w 2] (code dropCore) ∧ + Semiformula.Evalb ![w 0, w 1] + (code (codeUnpair₁ (codeSub (Code.proj (0 : Fin 1)) (codeConst 1)))) ∧ + 0 < w 1 ∧ z = w 0 + 1) := + (by definability : Σ-[1].Definable (fun w : Fin 5 → M => P + 1 + w 4 = w 3)).and + (hHist.and (hDrop.and (hHead.and (by definability)))) + exact + HierarchySymbol.Definable.imp (by definability) + (HierarchySymbol.Definable.exs + (HierarchySymbol.Definable.exs + (HierarchySymbol.Definable.exs (HierarchySymbol.Definable.exs hbody)))) + +theorem eval_prefix_lookup_succ_of_codeHistoryEvaluator [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + (s qCode n y : M) (q : ℕ) + (hprefix : + FFL.FirstOrder.Arithmetic.pair s ((q : ℕ) : M) < + FFL.FirstOrder.Arithmetic.pair s qCode) + (h : Semiformula.Evalb ![y + 1, s, ((q : ℕ) : M), n] (code codeHistoryEvaluator)) : + Semiformula.Evalb ((y + 1) :> ![s, qCode, n]) + (code + (codeTableLookup codeEvaluatorHistoryBeforeCell + (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell)) (codeConst (n := 3) q) + (Code.proj (2 : Fin 3)))) := by + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := + models_of_subtheory + (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + -- the Sigma-one condition of the ascent + have hdef := history_ascent_definable (M := M) + have hone : ∀ w : Fin 3 → M, Semiformula.Evalb ((1 : M) :> w) (code (codeConst (n := 3) 1)) := + by intro w; rw [eval_codeConst_iff]; simp + have hpairQ : + Semiformula.Evalb + (FFL.FirstOrder.Arithmetic.pair s ((q : ℕ) : M) :> + ![s, ((q : ℕ) : M), n]) + (code (codePair (Code.proj (0 : Fin 3)) (Code.proj (1 : Fin 3)))) := + eval_codePair _ _ s _ ![s, ((q : ℕ) : M), n] ((eval_proj_iff _ _ _).mpr rfl) + ((eval_proj_iff _ _ _).mpr rfl) + rw [codeHistoryEvaluator, codeTableLookup_eq] at h + obtain ⟨G2, b₀, hG2, hb₀, hcase₀⟩ := eval_sub_args _ _ _ _ h + have hG2v : G2 = y + 1 + 1 := by + rcases hcase₀ with heq | h0 + · rw [← heq, eval_unique hb₀ (hone _)] + · exact absurd h0.symm (zero_ne_add_one y) + rw [hG2v] at hG2 + obtain ⟨rowv, n₀, hrow, hn₀, hgetRow⟩ := getAt_of_eval _ _ _ _ hG2 (by simp) + have hn₀v : n₀ = n := by + simpa using eval_unique hn₀ ((eval_proj_iff (2 : Fin 3) n ![s, ((q : ℕ) : M), n]).mpr rfl) + rw [hn₀v] at hgetRow + obtain ⟨G1, b₁, hG1, hb₁, hcase₁⟩ := eval_sub_args _ _ _ _ hrow + have hrowpos : 0 < rowv := + by + rcases + eq_or_lt_of_le (FFL.FirstOrder.Arithmetic.zero_le rowv) with + h0 | hp + · exact + absurd (getAt_nil_absurd n (y + 1 + 1) (by rw [← h0] at hgetRow; exact hgetRow)) + not_false + · exact hp + have hG1v : G1 = rowv + 1 := by + rcases hcase₁ with heq | h0 + · rw [← heq, eval_unique hb₁ (hone _)] + · exfalso + rw [h0] at hrowpos + exact absurd hrowpos (_root_.lt_irrefl 0) + rw [hG1v] at hG1 + obtain ⟨H, i₀, hH, hi₀, hgetH⟩ := getAt_of_eval _ _ _ _ hG1 (by simp) + have hi₀v : + i₀ = FFL.FirstOrder.Arithmetic.pair s ((q : ℕ) : M) := + eval_unique hi₀ hpairQ + rw [hi₀v] at hgetH + rw [eval_comp_iff] at hH + obtain ⟨w, hhist, hwi⟩ := hH + have hsv := hwi 0 + simp only [Matrix.cons_val_zero] at hsv + have hw0 : + w 0 = FFL.FirstOrder.Arithmetic.pair s ((q : ℕ) : M) + 1 := + eval_unique hsv ((eval_codeSucc_iff _ _ _).mpr ⟨_, hpairQ, rfl⟩) + have hshape : w = (w 0) :> ![] := by + funext j + refine Fin.cases ?_ (fun j' => Fin.elim0 j') j + rfl + rw [hshape, hw0] at hhist + generalize hPdef : + FFL.FirstOrder.Arithmetic.pair s ((q : ℕ) : M) = + P at hgetH hhist hprefix + generalize hCdef : FFL.FirstOrder.Arithmetic.pair s qCode = + C at hprefix + have hall : + ∀ t : M, + P + 1 + t ≤ C → + ∃ j H' d hd : M, + P + 1 + t = j ∧ + Semiformula.Evalb ![H', j] (code codeEvaluatorHistory) ∧ + Semiformula.Evalb ![d, P, H'] (code dropCore) ∧ + Semiformula.Evalb ![hd, d] + (code (codeUnpair₁ (codeSub (Code.proj (0 : Fin 1)) (codeConst 1)))) ∧ + 0 < d ∧ rowv + 1 = hd + 1 := + by + refine InductionOnHierarchy.succ_induction Σ 1 (hdef P C (rowv + 1)) ?_ ?_ + · intro _ + obtain ⟨d, hd, h1, h2, h3, h4⟩ := hgetH + exact ⟨P + 1, H, d, hd, add_zero _, hhist, h1, h2, h3, h4⟩ + · intro t IH ht + have ht' : P + 1 + t ≤ C := le_trans (by rw [← add_assoc]; exact le_self_add) ht + obtain ⟨j, H', d, hd, hjt, hH', h1, h2, h3, h4⟩ := IH ht' + obtain ⟨H'', hH''⟩ := eval_codeEvaluatorHistory_exists (j + 1) + have hPj : P < j := by + rw [← hjt] + exact lt_of_lt_of_le (lt_add_one P) le_self_add + obtain ⟨d', hd', g1, g2, g3, g4⟩ := + getAt_step_up j P (rowv + 1) H' H'' hH' hH'' hPj ⟨d, hd, h1, h2, h3, h4⟩ + refine ⟨j + 1, H'', d', hd', ?_, hH'', g1, g2, g3, g4⟩ + rw [← hjt] + exact (add_assoc (P + 1) t 1).symm + have hle : P + 1 ≤ C := + FFL.FirstOrder.Arithmetic.succ_le_iff_lt.mpr hprefix + obtain ⟨j, Hm, d, hd, hjt, hHm, h1, h2, h3, h4⟩ := + hall (C - (P + 1)) (by rw [add_tsub_self_of_le hle]) + have hjC : j = C := by rw [← hjt, add_tsub_self_of_le hle] + rw [hjC] at hHm + have hgetHm : GetAt Hm P (rowv + 1) := ⟨d, hd, h1, h2, h3, h4⟩ + subst hPdef hCdef + have hpairC : + Semiformula.Evalb + (FFL.FirstOrder.Arithmetic.pair s qCode :> ![s, qCode, n]) + (code (codePair (Code.proj (0 : Fin 3)) (Code.proj (1 : Fin 3)))) := + eval_codePair _ _ s qCode ![s, qCode, n] ((eval_proj_iff _ _ _).mpr rfl) + ((eval_proj_iff _ _ _).mpr rfl) + have hbefore : + Semiformula.Evalb (Hm :> ![s, qCode, n]) (code codeEvaluatorHistoryBeforeCell) := + by + rw [codeEvaluatorHistoryBeforeCell, eval_comp_iff] + refine + ⟨![FFL.FirstOrder.Arithmetic.pair s qCode], by + simpa using hHm, ?_⟩ + intro i + refine Fin.cases ?_ (fun j => Fin.elim0 j) i + simpa using hpairC + obtain ⟨lenv, hlenv⟩ := + eval_codeListLength_exists_of_value codeEvaluatorHistoryBeforeCell Hm ![s, qCode, n] hbefore + obtain ⟨hd0, hdn⟩ := drops_of_length _ Hm lenv ![s, qCode, n] hbefore hlenv + have hlenm : lenv = FFL.FirstOrder.Arithmetic.pair s qCode := + eval_codeEvaluatorHistory_length_unique _ Hm lenv hHm + (length_of_drops _ Hm lenv ![Hm] ((eval_proj_iff _ _ _).mpr rfl) hd0 hdn) + have hfuel := eval_codeUnpair₁ _ lenv ![s, qCode, n] hlenv + rw [hlenm, FFL.FirstOrder.Arithmetic.pi₁_pair] at hfuel + have hkey : + Semiformula.Evalb + (FFL.FirstOrder.Arithmetic.pair s ((q : ℕ) : M) :> + ![s, qCode, n]) + (code + (codePair (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell)) + (codeConst (n := 3) q))) := + eval_codePair _ _ s _ ![s, qCode, n] hfuel ((eval_codeConst_iff _ _ _).mpr rfl) + have hget1 := eval_of_getAt _ _ Hm _ (rowv + 1) ![s, qCode, n] hbefore hkey hgetHm + have hsub1 := eval_codeSub _ (codeConst 1) (rowv + 1) 1 ![s, qCode, n] hget1 (hone _) + rw [add_sub_self] at hsub1 + have hget2 := + eval_of_getAt _ (Code.proj (2 : Fin 3)) rowv n (y + 1 + 1) ![s, qCode, n] hsub1 + ((eval_proj_iff _ _ _).mpr rfl) hgetRow + have hsub2 := eval_codeSub _ (codeConst 1) (y + 1 + 1) 1 ![s, qCode, n] hget2 (hone _) + rw [add_sub_self] at hsub2 + rw [codeTableLookup_eq] + exact hsub2 + +/-! +### A successful lookup and a successful cell -/ + +-- The history-evaluator code contains the whole evaluator-cell code. + +/-- A successful history lookup is exactly a successful evaluator cell in the +preceding history at an input strictly below the stage bound. -/ +private theorem eval_codeHistoryEvaluator_succ_of_cell [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] + (s qCode u y : M) (hus : u < s) + (hcell : Semiformula.Evalb ![y + 1, s, qCode, u] + (code (codeEvaluatorCell codeEvaluatorHistoryBeforeCell (Code.proj (2 : Fin 3))))) : + Semiformula.Evalb ![y + 1, s, qCode, u] (code codeHistoryEvaluator) := by + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + let : M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐈Σ1 from inferInstance) + have hone : ∀ w : Fin 3 → M, Semiformula.Evalb ((1 : M) :> w) (code (codeConst (n := 3) 1)) := + by + intro w + rw [eval_codeConst_iff] + simp + -- the stage `m`, the pair of `s` and `qCode` + have hmP : + Semiformula.Evalb + (FFL.FirstOrder.Arithmetic.pair s qCode :> ![s, qCode, u]) + (code (codePair (Code.proj (0 : Fin 3)) (Code.proj (1 : Fin 3)))) := + eval_codePair _ _ s qCode ![s, qCode, u] ((eval_proj_iff _ _ _).mpr rfl) + ((eval_proj_iff _ _ _).mpr rfl) + generalize hmdef : FFL.FirstOrder.Arithmetic.pair s qCode = + m at hmP + obtain ⟨H₀, hH₀⟩ := eval_codeEvaluatorHistory_exists m + obtain ⟨H₁, hH₁⟩ := + eval_codeEvaluatorHistory_exists + (m + 1) + -- the drops of `H₁` up to index `m` + have hself₁ : Semiformula.Evalb (H₁ :> ![H₁]) (code (Code.proj (0 : Fin 1))) := + (eval_proj_iff _ _ _).mpr rfl + obtain ⟨len₁, hlen₁⟩ := + eval_codeListLength_exists_of_value (Code.proj (0 : Fin 1)) H₁ ![H₁] hself₁ + have hlen₁v : len₁ = m + 1 := + eval_codeEvaluatorHistory_length_unique (m + 1) H₁ len₁ hH₁ hlen₁ + obtain ⟨-, hdn₁⟩ := drops_of_length _ H₁ len₁ ![H₁] hself₁ hlen₁ + obtain ⟨e₁, -, he₁⟩ := hdn₁ m (by rw [hlen₁v]; exact lt_add_one m) + have hdropT := drop_prefix H₁ m e₁ he₁ + have hH₁c := hH₁ + rw [codeEvaluatorHistory] at hH₁c + obtain ⟨H', hH', hstep⟩ := eval_codePrec_succ _ _ m H₁ ![] hH₁c + rw [← codeEvaluatorHistory] at hH' + have hH'0 : H' = H₀ := + eval_unique (show Semiformula.Evalb ![H', m] (code codeEvaluatorHistory) by simpa using hH') + hH₀ + rw [hH'0] at hstep + rw [codeEvaluatorTableStep_eq, eval_codeBind_iff] at hstep + obtain ⟨n', hlen', hsnoc⟩ := hstep + obtain ⟨hd0, hdn⟩ := + drops_of_length _ H₀ n' ![m, H₀] ((eval_proj_iff (1 : Fin 2) H₀ ![m, H₀]).mpr rfl) hlen' + have hn'm : n' = m := + eval_codeEvaluatorHistory_length_unique m H₀ n' hH₀ + (length_of_drops _ H₀ n' ![H₀] ((eval_proj_iff _ _ _).mpr rfl) hd0 hdn) + rw [hn'm] at hd0 hdn hsnoc hlen' + rw [historySnocCore_eq] at hsnoc + obtain ⟨aT, pT, haT, hsaT, hdT⟩ := chain_match _ _ m H₀ m H₁ m hsnoc hdropT m le_rfl le_rfl + have haT0 : aT = 0 := by + have : aT + m = 0 + m := by rw [haT, zero_add] + exact add_right_cancel this + rw [haT0] at hsaT + have hbase := eval_codePrec_zero _ _ pT ![m, H₀] hsaT + obtain ⟨rowv, nilv, hrow, -, hpTv⟩ := codeListCons_args _ _ pT _ hbase + have hgetH : GetAt H₁ m (rowv + 1) := + by + refine + ⟨pT, FFL.FirstOrder.Arithmetic.pi₁ (pT - 1), hdT, + head_of_drop (Code.proj (0 : Fin 1)) pT ![pT] ((eval_proj_iff _ _ _).mpr rfl), ?_, ?_⟩ + · rw [hpTv] + exact lt_of_lt_of_le _root_.zero_lt_one le_add_self + · rw [hpTv, add_sub_self, FFL.FirstOrder.Arithmetic.pi₁_pair] + -- the row recursion, whose bound is `s` + rw [codeEvaluatorRow_eq_bind, eval_codeBind_iff] at hrow + obtain ⟨bnd, hbnd, hrowcore⟩ := hrow + have hbnds : bnd = s := + by + have := + eval_unique hbnd + (eval_codeUnpair₁ (codeListLength (Code.proj (1 : Fin 2))) m ![m, H₀] hlen') + rw [this, ← hmdef, FFL.FirstOrder.Arithmetic.pi₁_pair] + rw [hbnds] at hrowcore + have hselfR : Semiformula.Evalb (rowv :> ![rowv]) (code (Code.proj (0 : Fin 1))) := + (eval_proj_iff _ _ _).mpr rfl + obtain ⟨lenR, hlenR⟩ := + eval_codeListLength_exists_of_value (Code.proj (0 : Fin 1)) rowv ![rowv] hselfR + obtain ⟨hd0R, hdnR⟩ := drops_of_length _ rowv lenR ![rowv] hselfR hlenR + have hulen : u < lenR := by + by_contra hcon + have hle : lenR ≤ u := not_lt.mp hcon + have hdropR : + ∀ t : M, t ≤ lenR → ∃ z : M, Semiformula.Evalb ![z, t, rowv] (code dropCore) := + by + intro t ht + rcases lt_or_eq_of_le ht with hlt | rfl + · obtain ⟨e, -, he⟩ := hdnR t hlt + exact ⟨e, he⟩ + · exact ⟨0, hd0R⟩ + have hls : lenR < s := lt_of_le_of_lt hle hus + obtain ⟨a, p, ha, hsa, hdp⟩ := + chain_match _ _ m H₀ s rowv lenR hrowcore hdropR lenR (le_of_lt hls) le_rfl + have hp0 : p = 0 := eval_unique hdp hd0R + have hapos : 0 < a := + by + rcases + eq_or_lt_of_le (FFL.FirstOrder.Arithmetic.zero_le a) with + h0 | hpos + · exfalso + rw [← h0, zero_add] at ha + rw [ha] at hls + exact absurd hls (_root_.lt_irrefl s) + · exact hpos + have hpred : a - 1 + 1 = a := + sub_add_self_of_le + (FFL.FirstOrder.Arithmetic.pos_iff_one_le.mp hapos) + obtain ⟨q', -, hstep'⟩ := + eval_codePrec_succ _ _ (a - 1) p ![m, H₀] (by rw [hpred]; exact hsa) + exact codeListCons_ne_zero _ _ p _ hstep' hp0 + obtain ⟨eR, -, heR⟩ := hdnR u hulen + have hdropRow := drop_prefix rowv u eR heR + obtain ⟨aR, pR, haR, hsaR, hdR⟩ := + chain_match _ _ m H₀ s rowv u hrowcore hdropRow u (le_of_lt hus) le_rfl + have haRpos : 0 < aR := + by + rcases + eq_or_lt_of_le (FFL.FirstOrder.Arithmetic.zero_le aR) with + h0 | hpos + · exfalso + rw [← h0, zero_add] at haR + rw [haR] at hus + exact absurd hus (_root_.lt_irrefl s) + · exact hpos + have hpredR : aR - 1 + 1 = aR := + sub_add_self_of_le + (FFL.FirstOrder.Arithmetic.pos_iff_one_le.mp haRpos) + obtain ⟨q, -, hstepR⟩ := + eval_codePrec_succ _ _ (aR - 1) pR ![m, H₀] (by rw [hpredR]; exact hsaR) + obtain ⟨cellv, l, hcellv, -, hpRv⟩ := codeListCons_args _ _ pR _ hstepR + have hTsrc : + Semiformula.Evalb (H₀ :> ![aR - 1, q, m, H₀]) + (code (codeLift (codeLift (Code.proj (1 : Fin 2))))) := + (eval_codeLift_iff _ _ _ _).mpr + ((eval_codeLift_iff _ _ _ _).mpr ((eval_proj_iff _ _ _).mpr rfl)) + have hTtgt : Semiformula.Evalb (H₀ :> ![s, qCode, u]) (code codeEvaluatorHistoryBeforeCell) := + by + rw [codeEvaluatorHistoryBeforeCell, eval_comp_iff] + refine ⟨![m], by simpa using hH₀, ?_⟩ + intro i + refine Fin.cases ?_ (fun j => Fin.elim0 j) i + simpa using hmP + have hlenlift : + Semiformula.Evalb (m :> ![aR - 1, q, m, H₀]) + (code (codeListLength (codeLift (codeLift (Code.proj (1 : Fin 2)))))) := + length_of_drops _ H₀ m ![aR - 1, q, m, H₀] hTsrc hd0 hdn + have hfuel : + Semiformula.Evalb (s :> ![aR - 1, q, m, H₀]) + (code (codeUnpair₁ (codeListLength (codeLift (codeLift (Code.proj (1 : Fin 2))))))) := + by + have hpi : FFL.FirstOrder.Arithmetic.pi₁ m = s := by + rw [← hmdef, FFL.FirstOrder.Arithmetic.pi₁_pair] + have hlift := eval_codeUnpair₁ _ m ![aR - 1, q, m, H₀] hlenlift + rwa [hpi] at hlift + have hstepv : + Semiformula.Evalb (aR :> ![aR - 1, q, m, H₀]) (code (codeSucc (Code.proj (0 : Fin 4)))) := + (eval_codeSucc_iff _ _ _).mpr ⟨aR - 1, (eval_proj_iff _ _ _).mpr rfl, hpredR.symm⟩ + have hNsrc : + Semiformula.Evalb (u :> ![aR - 1, q, m, H₀]) + (code + (codeSub (codeUnpair₁ (codeListLength (codeLift (codeLift (Code.proj (1 : Fin 2)))))) + (codeSucc (Code.proj (0 : Fin 4))))) := + by + have hsu : s - aR = u := sub_remove_left (by rw [← haR, add_comm]) + have := eval_codeSub _ _ s aR ![aR - 1, q, m, H₀] hfuel hstepv + rwa [hsu] at this + have hNtgt : Semiformula.Evalb (u :> ![s, qCode, u]) (code (Code.proj (2 : Fin 3))) := + (eval_proj_iff _ _ _).mpr rfl + have hcellsrc := + (eval_codeEvaluatorCell_congr_at _ _ _ _ (y + 1) ![aR - 1, q, m, H₀] ![s, qCode, u] + (graph_iff _ _ H₀ _ _ hTsrc hTtgt) (graph_iff _ _ u _ _ hNsrc hNtgt)).mpr + hcell + have hcellvy : cellv = y + 1 := eval_unique hcellv hcellsrc + have hgetRow : GetAt rowv u (y + 1 + 1) := + by + refine + ⟨pR, FFL.FirstOrder.Arithmetic.pi₁ (pR - 1), hdR, + head_of_drop (Code.proj (0 : Fin 1)) pR ![pR] ((eval_proj_iff _ _ _).mpr rfl), ?_, ?_⟩ + · rw [hpRv] + exact lt_of_lt_of_le _root_.zero_lt_one le_add_self + · rw [hpRv, add_sub_self, FFL.FirstOrder.Arithmetic.pi₁_pair, + hcellvy] + -- reassemble the two lookups in the history one step past `m` + have htab : + Semiformula.Evalb (H₁ :> ![s, qCode, u]) + (code + (codeEvaluatorHistory.comp + ![codeSucc (codePair (Code.proj (0 : Fin 3)) (Code.proj (1 : Fin 3)))])) := + by + rw [eval_comp_iff] + refine ⟨![m + 1], by simpa using hH₁, ?_⟩ + intro j + refine Fin.cases ?_ (fun j' => Fin.elim0 j') j + simpa using (eval_codeSucc_iff _ _ _).mpr ⟨_, hmP, rfl⟩ + have hget1 := eval_of_getAt _ _ H₁ m (rowv + 1) ![s, qCode, u] htab hmP hgetH + have hsub1 := eval_codeSub _ (codeConst 1) (rowv + 1) 1 ![s, qCode, u] hget1 (hone _) + rw [add_sub_self] at hsub1 + have hget2 := + eval_of_getAt _ (Code.proj (2 : Fin 3)) rowv u (y + 1 + 1) ![s, qCode, u] hsub1 + ((eval_proj_iff _ _ _).mpr rfl) hgetRow + have hsub2 := eval_codeSub _ (codeConst 1) (y + 1 + 1) 1 ![s, qCode, u] hget2 (hone _) + rw [add_sub_self] at hsub2 + rw [codeHistoryEvaluator, codeTableLookup_eq] + exact hsub2 + +/-! +### A successful lookup in a history at an earlier row -/ + +-- The history-evaluator code contains the whole evaluator-cell code. + +theorem eval_codeHistoryEvaluator_succ_iff_cell [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] (s qCode u y : M) : + Semiformula.Evalb ![y + 1, s, qCode, u] + (FFL.FirstOrder.Arithmetic.code codeHistoryEvaluator) ↔ + u < s ∧ + Semiformula.Evalb ![y + 1, s, qCode, u] + (FFL.FirstOrder.Arithmetic.code + (codeEvaluatorCell codeEvaluatorHistoryBeforeCell (Code.proj (2 : Fin 3)))) := + by + exact + ⟨eval_codeHistoryEvaluator_succ_extract_cell_core s qCode u y, fun h => + eval_codeHistoryEvaluator_succ_of_cell s qCode u y h.1 h.2⟩ + +/-- **Earlier-row bridge.** Let `H` be the value of `codeEvaluatorHistory` at a +row count `N`, and let the row `pair k q` of the standard index `q` lie below +`N`. For codes `dtable`, `dk`, `dq`, `dn` whose values at `v` are `H`, `k`, the +numeral `q` and `u`, the table lookup succeeds with output `y + 1` exactly when +`codeHistoryEvaluator` succeeds with output `y + 1` at stage `k`, index `q`, +input `u`. + +The stage `k` is arbitrary below the row bound; it need not be the stage that +produced `H`. No certificate persistence is used: the forward direction +descends from `N` to `pair k q + 1` with `getAt_step_down`, and the reverse +direction ascends from `pair k q + 1` to `N` with `getAt_step_up`. -/ +theorem eval_codeTableLookup_succ_iff_codeHistoryEvaluator_of_history [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] + [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] {r : ℕ} (dtable dk dq dn : Code r) (v : Fin r → M) (N H k u y : M) + (q : ℕ) (hH : Semiformula.Evalb ![H, N] (code codeEvaluatorHistory)) + (hrow : FFL.FirstOrder.Arithmetic.pair k ((q : ℕ) : M) < N) + (htable : Semiformula.Evalb (H :> v) (code dtable)) + (hk : Semiformula.Evalb (k :> v) (code dk)) + (hq : Semiformula.Evalb (((q : ℕ) : M) :> v) (code dq)) + (hn : Semiformula.Evalb (u :> v) (code dn)) : + Semiformula.Evalb ((y + 1) :> v) (code (codeTableLookup dtable dk dq dn)) ↔ + Semiformula.Evalb ![y + 1, k, ((q : ℕ) : M), u] (code codeHistoryEvaluator) := by + let : M↓[ℒₒᵣ] ⊧* 𝐈Σ1 := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + have hone : + ∀ {s : ℕ} (w : Fin s → M), Semiformula.Evalb ((1 : M) :> w) (code (codeConst (n := s) 1)) := + by intro s w; rw [eval_codeConst_iff]; simp + have hkey : + Semiformula.Evalb + (FFL.FirstOrder.Arithmetic.pair k ((q : ℕ) : M) :> v) + (code (codePair dk dq)) := + eval_codePair _ _ k _ v hk hq + have hpairQ : + Semiformula.Evalb + (FFL.FirstOrder.Arithmetic.pair k ((q : ℕ) : M) :> + ![k, ((q : ℕ) : M), u]) + (code (codePair (Code.proj (0 : Fin 3)) (Code.proj (1 : Fin 3)))) := + eval_codePair _ _ k _ ![k, ((q : ℕ) : M), u] ((eval_proj_iff _ _ _).mpr rfl) + ((eval_proj_iff _ _ _).mpr rfl) + constructor + · -- the lookup in `H` gives the history evaluator at the earlier stage + intro h + rw [codeTableLookup_eq] at h + obtain ⟨G2, b₀, hG2, hb₀, hcase₀⟩ := eval_sub_args _ _ _ _ h + have hG2v : G2 = y + 1 + 1 := by + rcases hcase₀ with heq | h0 + · rw [← heq, eval_unique hb₀ (hone _)] + · exact absurd h0.symm (zero_ne_add_one y) + rw [hG2v] at hG2 + obtain ⟨rowv, n₀, hrowc, hn₀, hgetRow⟩ := getAt_of_eval _ _ _ _ hG2 (by simp) + have hn₀v : n₀ = u := eval_unique hn₀ hn + rw [hn₀v] at hgetRow + obtain ⟨G1, b₁, hG1, hb₁, hcase₁⟩ := eval_sub_args _ _ _ _ hrowc + have hrowpos : 0 < rowv := + by + rcases + eq_or_lt_of_le + (FFL.FirstOrder.Arithmetic.zero_le rowv) with + h0 | hp + · exact + absurd (getAt_nil_absurd u (y + 1 + 1) (by rw [← h0] at hgetRow; exact hgetRow)) + not_false + · exact hp + have hG1v : G1 = rowv + 1 := by + rcases hcase₁ with heq | h0 + · rw [← heq, eval_unique hb₁ (hone _)] + · exfalso + rw [h0] at hrowpos + exact absurd hrowpos (_root_.lt_irrefl 0) + rw [hG1v] at hG1 + obtain ⟨Hm, i₀, hHm, hi₀, hgetHm⟩ := getAt_of_eval _ _ _ _ hG1 (by simp) + have hHmv : Hm = H := eval_unique hHm htable + have hi₀v : + i₀ = FFL.FirstOrder.Arithmetic.pair k ((q : ℕ) : M) := + eval_unique hi₀ hkey + rw [hHmv, hi₀v] at hgetHm + obtain ⟨H', hH', hgetH'⟩ := + getAt_descend _ _ _ H hH hgetHm (by simpa using hrowpos) + (FFL.FirstOrder.Arithmetic.succ_le_iff_lt.mpr hrow) + -- reassemble the history-evaluator evaluation at the earlier stage + rw [codeHistoryEvaluator, codeTableLookup_eq] + have htab : + Semiformula.Evalb (H' :> ![k, ((q : ℕ) : M), u]) + (code + (codeEvaluatorHistory.comp + ![codeSucc (codePair (Code.proj (0 : Fin 3)) (Code.proj (1 : Fin 3)))])) := + by + rw [eval_comp_iff] + refine + ⟨![FFL.FirstOrder.Arithmetic.pair k ((q : ℕ) : M) + 1], by + simpa using hH', ?_⟩ + intro j + refine Fin.cases ?_ (fun j' => Fin.elim0 j') j + simpa using (eval_codeSucc_iff _ _ _).mpr ⟨_, hpairQ, rfl⟩ + have hget1 := eval_of_getAt _ _ H' _ (rowv + 1) ![k, ((q : ℕ) : M), u] htab hpairQ hgetH' + have hsub1 := + eval_codeSub _ (codeConst 1) (rowv + 1) 1 ![k, ((q : ℕ) : M), u] hget1 (hone _) + rw [add_sub_self] at hsub1 + have hget2 := + eval_of_getAt _ (Code.proj (2 : Fin 3)) rowv u (y + 1 + 1) ![k, ((q : ℕ) : M), u] hsub1 + ((eval_proj_iff _ _ _).mpr rfl) hgetRow + have hsub2 := + eval_codeSub _ (codeConst 1) (y + 1 + 1) 1 ![k, ((q : ℕ) : M), u] hget2 (hone _) + rw [add_sub_self] at hsub2 + simpa using hsub2 + · -- the history evaluator at the earlier stage gives the lookup in `H` + intro h + have hdef := history_ascent_definable (M := M) + rw [codeHistoryEvaluator, codeTableLookup_eq] at h + obtain ⟨G2, b₀, hG2, hb₀, hcase₀⟩ := eval_sub_args _ _ _ _ h + have hG2v : G2 = y + 1 + 1 := by + rcases hcase₀ with heq | h0 + · rw [← heq, eval_unique hb₀ (hone _)] + · exact absurd h0.symm (zero_ne_add_one y) + rw [hG2v] at hG2 + obtain ⟨rowv, n₀, hrowc, hn₀, hgetRow⟩ := getAt_of_eval _ _ _ _ hG2 (by simp) + have hn₀v : n₀ = u := by + simpa using eval_unique hn₀ ((eval_proj_iff (2 : Fin 3) u ![k, ((q : ℕ) : M), u]).mpr rfl) + rw [hn₀v] at hgetRow + obtain ⟨G1, b₁, hG1, hb₁, hcase₁⟩ := eval_sub_args _ _ _ _ hrowc + have hrowpos : 0 < rowv := + by + rcases + eq_or_lt_of_le + (FFL.FirstOrder.Arithmetic.zero_le rowv) with + h0 | hp + · exact + absurd (getAt_nil_absurd u (y + 1 + 1) (by rw [← h0] at hgetRow; exact hgetRow)) + not_false + · exact hp + have hG1v : G1 = rowv + 1 := by + rcases hcase₁ with heq | h0 + · rw [← heq, eval_unique hb₁ (hone _)] + · exfalso + rw [h0] at hrowpos + exact absurd hrowpos (_root_.lt_irrefl 0) + rw [hG1v] at hG1 + obtain ⟨H₀, i₀, hH₀, hi₀, hgetH₀⟩ := getAt_of_eval _ _ _ _ hG1 (by simp) + have hi₀v : + i₀ = FFL.FirstOrder.Arithmetic.pair k ((q : ℕ) : M) := + eval_unique hi₀ hpairQ + rw [hi₀v] at hgetH₀ + rw [eval_comp_iff] at hH₀ + obtain ⟨w, hhist, hwi⟩ := hH₀ + have hsv := hwi 0 + simp only [Matrix.cons_val_zero] at hsv + have hw0 : + w 0 = FFL.FirstOrder.Arithmetic.pair k ((q : ℕ) : M) + 1 := + eval_unique hsv ((eval_codeSucc_iff _ _ _).mpr ⟨_, hpairQ, rfl⟩) + have hshape : w = (w 0) :> ![] := by + funext j + refine Fin.cases ?_ (fun j' => Fin.elim0 j') j + rfl + rw [hshape, hw0] at hhist + generalize hPdef : + FFL.FirstOrder.Arithmetic.pair k ((q : ℕ) : M) = + P at hgetH₀ hhist hrow + have hall : + ∀ t : M, + P + 1 + t ≤ N → + ∃ j H' d hd : M, + P + 1 + t = j ∧ + Semiformula.Evalb ![H', j] (code codeEvaluatorHistory) ∧ + Semiformula.Evalb ![d, P, H'] (code dropCore) ∧ + Semiformula.Evalb ![hd, d] + (code (codeUnpair₁ (codeSub (Code.proj (0 : Fin 1)) (codeConst 1)))) ∧ + 0 < d ∧ rowv + 1 = hd + 1 := + by + refine InductionOnHierarchy.succ_induction Σ 1 (hdef P N (rowv + 1)) ?_ ?_ + · intro _ + obtain ⟨d, hd, h1, h2, h3, h4⟩ := hgetH₀ + exact ⟨P + 1, H₀, d, hd, add_zero _, hhist, h1, h2, h3, h4⟩ + · intro t IH ht + have ht' : P + 1 + t ≤ N := le_trans (by rw [← add_assoc]; exact le_self_add) ht + obtain ⟨j, H', d, hd, hjt, hH', h1, h2, h3, h4⟩ := IH ht' + obtain ⟨H'', hH''⟩ := eval_codeEvaluatorHistory_exists (j + 1) + have hPj : P < j := by + rw [← hjt] + exact lt_of_lt_of_le (lt_add_one P) le_self_add + obtain ⟨d', hd', g1, g2, g3, g4⟩ := + getAt_step_up j P (rowv + 1) H' H'' hH' hH'' hPj ⟨d, hd, h1, h2, h3, h4⟩ + refine ⟨j + 1, H'', d', hd', ?_, hH'', g1, g2, g3, g4⟩ + rw [← hjt] + exact (add_assoc (P + 1) t 1).symm + have hle : P + 1 ≤ N := + FFL.FirstOrder.Arithmetic.succ_le_iff_lt.mpr hrow + obtain ⟨j, Hm, d, hd, hjt, hHm, h1, h2, h3, h4⟩ := + hall (N - (P + 1)) (by rw [add_tsub_self_of_le hle]) + have hjN : j = N := by rw [← hjt, add_tsub_self_of_le hle] + rw [hjN] at hHm + have hHmv : Hm = H := eval_unique hHm hH + have hgetH : GetAt H P (rowv + 1) := by rw [← hHmv]; exact ⟨d, hd, h1, h2, h3, h4⟩ + subst hPdef + have hget1 := eval_of_getAt _ _ H _ (rowv + 1) v htable hkey hgetH + have hsub1 := eval_codeSub _ (codeConst 1) (rowv + 1) 1 v hget1 (hone _) + rw [add_sub_self] at hsub1 + have hget2 := eval_of_getAt _ dn rowv u (y + 1 + 1) v hsub1 hn hgetRow + have hsub2 := eval_codeSub _ (codeConst 1) (y + 1 + 1) 1 v hget2 (hone _) + rw [add_sub_self] at hsub2 + rw [codeTableLookup_eq] + exact hsub2 + +/-- **Input bound.** Under the hypotheses of the earlier-row bridge, a +successful lookup forces the input below the earlier stage. -/ +theorem input_lt_of_codeTableLookup_succ_of_history [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] {r : ℕ} + (dtable dk dq dn : Code r) (v : Fin r → M) (N H k u y : M) (q : ℕ) + (hH : Semiformula.Evalb ![H, N] (code codeEvaluatorHistory)) + (hrow : FFL.FirstOrder.Arithmetic.pair k ((q : ℕ) : M) < N) + (htable : Semiformula.Evalb (H :> v) (code dtable)) + (hk : Semiformula.Evalb (k :> v) (code dk)) + (hq : Semiformula.Evalb (((q : ℕ) : M) :> v) (code dq)) + (hn : Semiformula.Evalb (u :> v) (code dn)) + (h : Semiformula.Evalb ((y + 1) :> v) (code (codeTableLookup dtable dk dq dn))) : u < k := + ((eval_codeHistoryEvaluator_succ_iff_cell k ((q : ℕ) : M) u y).mp + ((eval_codeTableLookup_succ_iff_codeHistoryEvaluator_of_history dtable dk dq dn v N H k u + y q hH hrow htable hk hq hn).mp + h)).1 + +-- The history code contains the whole evaluator-cell code. + +/-- **Predecessor-stage specialization.** In the history before the cell at +`k + 1, q, w` (which holds the rows below `pair (k + 1) q`), the lookup at the +decremented stage read by the dispatcher, the program index read by the +dispatcher, and an input code `dn` with value `u` succeeds with output `y + 1` +exactly when `codeHistoryEvaluator` succeeds at `y + 1, k, q, u`. -/ +theorem eval_predecessor_lookup_succ_iff_codeHistoryEvaluator [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + (k w u y : M) (q : ℕ) (dn : Code 3) + (hn : Semiformula.Evalb (u :> ![k + 1, ((q : ℕ) : M), w]) (code dn)) : + Semiformula.Evalb ((y + 1) :> ![k + 1, ((q : ℕ) : M), w]) + (code + (codeTableLookup codeEvaluatorHistoryBeforeCell + (codeSub (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell)) + (codeConst 1)) + (codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell)) dn)) ↔ + Semiformula.Evalb ![y + 1, k, ((q : ℕ) : M), u] (code codeHistoryEvaluator) := + by + let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + obtain ⟨H, hbefore, hH⟩ := eval_codeEvaluatorHistoryBeforeCell_exists (k + 1) ((q : ℕ) : M) w + have hone : + Semiformula.Evalb ((1 : M) :> ![k + 1, ((q : ℕ) : M), w]) (code (codeConst (n := 3) 1)) := + by rw [eval_codeConst_iff]; simp + have hk : + Semiformula.Evalb (k :> ![k + 1, ((q : ℕ) : M), w]) + (code + (codeSub (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell)) + (codeConst 1))) := + by + have h := + eval_codeSub _ (codeConst 1) (k + 1) 1 ![k + 1, ((q : ℕ) : M), w] + (eval_codeEvaluatorCell_fuel (k + 1) ((q : ℕ) : M) w) hone + rwa [add_sub_self] at h + exact + eval_codeTableLookup_succ_iff_codeHistoryEvaluator_of_history _ _ _ dn + ![k + 1, ((q : ℕ) : M), w] (FFL.FirstOrder.Arithmetic.pair (k + 1) ((q : ℕ) : M)) H k u y + q hH (FFL.FirstOrder.Arithmetic.pair_lt_pair_left (lt_add_one k) _) hbefore hk + (eval_codeEvaluatorCell_index (k + 1) ((q : ℕ) : M) w) hn + +end Evaluator +end CategoricalRiceShapiro + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/PairPersistence.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/PairPersistence.lean new file mode 100644 index 000000000..2821d39b2 --- /dev/null +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/PairPersistence.lean @@ -0,0 +1,389 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.CompositionDispatch +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.Certificate + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# The tag-4 induction case of certificate persistence + +`evalnCertificateFormula_natCode_persist_of_tag_four` concerns a standard index +`q` whose constructor number `partrecCodeTag q` is `4`. It proves that the raw +evaluator certificate for `q` persists from a stage `s` to every stage `t ≥ s`, +assuming the same persistence for every standard index `p < q`, whatever the +constructor number of `p`. The persistence predicate is written out in both the +hypothesis and the conclusion. The theory assumptions are `𝐏𝐀` and `𝐈𝐎𝐩𝐞𝐧`; +the proof obtains `𝐏𝐀⁻` from `𝐏𝐀` with `models_of_subtheory`. + +The proof decomposes a successful source cell into certificates for the two +payload subcodes at stage `s`, applies the induction hypothesis once to each, +rebuilds the two table lookups at stage `t` with +`eval_prefix_lookup_succ_of_codeHistoryEvaluator`, and reconstructs the target +cell with `eval_codeEvaluatorCell_succ_of_pair_component_lookups`. The private +helpers relate `partrecCodeTag` to its remainder form, bound both payloads +strictly below `q`, and read the decoders inside a model. The fuel and the +program index that the cell reads are supplied by the generic public readings +`eval_codeEvaluatorCell_fuel` and `eval_codeEvaluatorCell_index` of +`Evaluator.HistoryEvaluation`. + +The file states one induction case. It proves neither the cases for the other +constructor numbers nor persistence for all standard indices. +-/ + +@[expose] public section + +open _root_.Nat Nat Nat.ArithPart₁ + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +open scoped FFL.FirstOrder.Arithmetic + +open CategoricalRiceShapiro.ArithmeticCode + +namespace CategoricalRiceShapiro +namespace Evaluator + +variable {M : Type*} [ORingStructure M] + +/-! +### Decoder bridge and ranking, over `ℕ` -/ + +/-- Production's tag decoder, written with remainders. `bodd.toNat` and `% 2` +are related by `Nat.mod_two_of_bodd`, not assumed definitionally equal. -/ +private theorem tagFour_tag_remainders (q : ℕ) : + partrecCodeTag q = if q < 4 then q else 4 + 2 * ((q - 4) % 2) + Nat.div2 (q - 4) % 2 := + by + have hb : ∀ n : ℕ, n.bodd.toNat = n % 2 := fun n => by rw [Nat.mod_two_of_bodd] + simp only [partrecCodeTag, hb] + +/-- Both subcodes of a standard constructor-`4` index lie strictly below it. -/ +private theorem tagFour_payloads_lt (q : ℕ) (hq : partrecCodeTag q = 4) : + partrecCodePayload₁ q < q ∧ partrecCodePayload₂ q < q := + by + have h4 : 4 ≤ q := by + rcases Nat.lt_or_ge q 4 with hlt | hge + · rw [tagFour_tag_remainders, ite_eq_left hlt] at hq + omega + · exact hge + have hdd : partrecCodePayload q ≤ q - 4 := + by + simp only [partrecCodePayload, Nat.div2_val] + exact le_trans (Nat.div_le_self ((q - 4) / 2) 2) (Nat.div_le_self (q - 4) 2) + have h1 : partrecCodePayload₁ q ≤ partrecCodePayload q := + Nat.unpair_left_le (partrecCodePayload q) + have h2 : partrecCodePayload₂ q ≤ partrecCodePayload q := + Nat.unpair_right_le (partrecCodePayload q) + omega + +/-! +### Decoder readings inside a model -/ + +/-- The constructor number of a standard index, read inside a model. -/ +private theorem tagFour_read_tag [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) (v : Fin r → M) + (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : + Semiformula.Evalb (((partrecCodeTag q : ℕ) : M) :> v) (code (codePartrecTag d)) := + by + have h4 : Semiformula.Evalb (((4 : ℕ) : M) :> v) (code (codeConst (n := r) 4)) := + eval_codeConst 4 v + have h2 : Semiformula.Evalb (((2 : ℕ) : M) :> v) (code (codeConst (n := r) 2)) := + eval_codeConst 2 v + have hrr := eval_codeSub_natCast d (codeConst 4) q 4 v hd (by simpa using h4) + have hbodd0 := eval_codeBodd_natCast (codeSub d (codeConst 4)) (q - 4) v hrr + have hbodd1 := + eval_codeBodd_natCast (codeDiv2 (codeSub d (codeConst 4))) (Nat.div2 (q - 4)) v + (eval_codeDiv2_natCast _ (q - 4) v hrr) + have hmul : + Semiformula.Evalb ((((2 * ((q - 4) % 2) : ℕ)) : M) :> v) + (code (codeMul (codeConst 2) (codeBodd (codeSub d (codeConst 4))))) := + by + refine (eval_codeMul_iff _ _ _ v).mpr ⟨_, _, h2, hbodd0, ?_⟩ + push_cast + norm_num + have hadd1 : + Semiformula.Evalb ((((4 + 2 * ((q - 4) % 2) : ℕ)) : M) :> v) + (code + (codeAdd (codeConst 4) (codeMul (codeConst 2) (codeBodd (codeSub d (codeConst 4)))))) := + by + refine (eval_codeAdd_iff _ _ _ v).mpr ⟨_, _, h4, hmul, ?_⟩ + push_cast + norm_num + have hbig : + Semiformula.Evalb ((((4 + 2 * ((q - 4) % 2) + Nat.div2 (q - 4) % 2 : ℕ)) : M) :> v) + (code + (codeAdd + (codeAdd (codeConst 4) (codeMul (codeConst 2) (codeBodd (codeSub d (codeConst 4))))) + (codeBodd (codeDiv2 (codeSub d (codeConst 4)))))) := + by + refine (eval_codeAdd_iff _ _ _ v).mpr ⟨_, _, hadd1, hbodd1, ?_⟩ + push_cast + norm_num + rw [tagFour_tag_remainders] + simp only [codePartrecTag] + by_cases hq : q < 4 + · have hlt1 : Semiformula.Evalb ((1 : M) :> v) (code (codeLt d (codeConst 4))) := + by + refine (eval_codeLt_iff _ _ _ v).mpr ⟨_, _, hd, by simpa using h4, Or.inl ⟨?_, rfl⟩⟩ + exact_mod_cast hq + rw [ite_eq_left hq] + exact + eval_codeIfPos_of _ _ _ (1 : M) (((q : ℕ)) : M) _ _ v hlt1 hd hbig + (Or.inl ⟨_root_.zero_lt_one, rfl⟩) + · have hlt0 : Semiformula.Evalb ((0 : M) :> v) (code (codeLt d (codeConst 4))) := + by + refine (eval_codeLt_iff _ _ _ v).mpr ⟨_, _, hd, by simpa using h4, Or.inr ⟨?_, rfl⟩⟩ + intro hc + exact hq (by exact_mod_cast hc) + rw [ite_eq_right hq] + exact eval_codeIfPos_of _ _ _ (0 : M) (((q : ℕ)) : M) _ _ v hlt0 hd hbig (Or.inr ⟨rfl, rfl⟩) + +/-- The payload of a standard index, read inside a model. -/ +private theorem tagFour_read_payload [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) + (v : Fin r → M) (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : + Semiformula.Evalb (((partrecCodePayload q : ℕ) : M) :> v) (code (codePartrecPayload d)) := + by + have h4 : Semiformula.Evalb (((4 : ℕ) : M) :> v) (code (codeConst (n := r) 4)) := + eval_codeConst 4 v + have hrr := eval_codeSub_natCast d (codeConst 4) q 4 v hd (by simpa using h4) + simpa only [codePartrecPayload, partrecCodePayload] using + eval_codeDiv2_natCast _ _ v (eval_codeDiv2_natCast _ (q - 4) v hrr) + +/-- The first subcode of a standard index, read inside a model. -/ +private theorem tagFour_read_payload₁ [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) + (v : Fin r → M) (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : + Semiformula.Evalb (((partrecCodePayload₁ q : ℕ) : M) :> v) (code (codePartrecPayload₁ d)) := + eval_codeUnpair₁_natCast (codePartrecPayload d) _ v (tagFour_read_payload d q v hd) + +/-- The second subcode of a standard index, read inside a model. -/ +private theorem tagFour_read_payload₂ [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) + (v : Fin r → M) (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : + Semiformula.Evalb (((partrecCodePayload₂ q : ℕ) : M) :> v) (code (codePartrecPayload₂ d)) := + eval_codeUnpair₂_natCast (codePartrecPayload d) _ v (tagFour_read_payload d q v hd) + +/-! +### The pairing branch of the dispatcher -/ + +/-- A successful evaluator cell whose constructor number is `4` is the value of +its pairing branch. -/ +private theorem tagFour_pair_branch [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (dtable dn : Code r) + (v : Fin r → M) (z k tag : M) + (hk : Semiformula.Evalb (k :> v) (code (codeUnpair₁ (codeListLength dtable)))) + (hkpos : 0 < k) + (htag : + Semiformula.Evalb (tag :> v) + (code (codePartrecTag (codeUnpair₂ (codeListLength dtable))))) + (h4 : tag = ((4 : ℕ) : M)) + (hcell : Semiformula.Evalb (z :> v) (code (codeEvaluatorCell dtable dn))) : + Semiformula.Evalb (z :> v) + (code + (codePairEvaluatorCell dtable (codeUnpair₁ (codeListLength dtable)) + (codePartrecPayload₁ (codeUnpair₂ (codeListLength dtable))) + (codePartrecPayload₂ (codeUnpair₂ (codeListLength dtable))) dn)) := + by + have hval : + ∀ (m : ℕ) (x : M), + Semiformula.Evalb (x :> v) (code (codeConst (n := r) m)) → x = ((m : ℕ) : M) := + fun m x hx => eval_unique hx (eval_codeConst m v) + simp only [codeEvaluatorCell] at hcell + obtain ⟨f0, hf0, hc0⟩ := eval_codeIfPos_cases _ _ _ z v hcell + have hf0k : f0 = k := eval_unique hf0 hk + rcases hc0 with ⟨-, hbig⟩ | ⟨h0, -⟩ + swap + · exact absurd (hf0k ▸ h0 : k = 0) (ne_of_gt hkpos) + obtain ⟨e4, he4, hcase4⟩ := eval_codeIfPos_cases _ _ _ z v hbig + rw [eval_codeEq_iff] at he4 + obtain ⟨x, w, hx, hw, hxw⟩ := he4 + have hxt : x = tag := eval_unique hx htag + have hw4 : w = ((4 : ℕ) : M) := hval 4 w hw + have he41 : e4 = 1 := by + rcases hxw with ⟨-, h1⟩ | ⟨hne, -⟩ + · exact h1 + · exact absurd (by rw [hxt, hw4]; exact h4) hne + rcases hcase4 with ⟨-, hpair⟩ | ⟨h0, -⟩ + · exact hpair + · exact absurd (he41 ▸ h0 : (1 : M) = 0) _root_.one_ne_zero + +/-! +### Forward decomposition of a source tag-4 cell -/ + +/-- A successful source cell at a standard constructor-`4` index yields a +history success for each subcode at the same stage, and the Cantor pair of the +two outputs. -/ +private theorem tagFour_source_subcode_histories [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] (q : ℕ) (hq : partrecCodeTag q = 4) (s u y : M) (hs : 0 < s) + (hcell : + Semiformula.Evalb ((y + 1) :> ![s, ((q : ℕ) : M), u]) + (code (codeEvaluatorCell codeEvaluatorHistoryBeforeCell (Code.proj (2 : Fin 3))))) : + ∃ a b : M, + Semiformula.Evalb ![a + 1, s, ((partrecCodePayload₁ q : ℕ) : M), u] + (code codeHistoryEvaluator) ∧ + Semiformula.Evalb ![b + 1, s, ((partrecCodePayload₂ q : ℕ) : M), u] + (code codeHistoryEvaluator) ∧ + y = FFL.FirstOrder.Arithmetic.pair a b := + by + have hk := eval_codeEvaluatorCell_fuel s ((q : ℕ) : M) u + have hidx := eval_codeEvaluatorCell_index s ((q : ℕ) : M) u + have htag : + Semiformula.Evalb (((4 : ℕ) : M) :> ![s, ((q : ℕ) : M), u]) + (code (codePartrecTag (codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell)))) := + by + have h := tagFour_read_tag _ q ![s, ((q : ℕ) : M), u] hidx + rwa [hq] at h + have hbranch := + tagFour_pair_branch codeEvaluatorHistoryBeforeCell (Code.proj (2 : Fin 3)) + ![s, ((q : ℕ) : M), u] (y + 1) s (((4 : ℕ) : M)) hk hs htag rfl hcell + obtain ⟨a, b, hla, hlb, hy⟩ := + (eval_codePairEvaluatorCell_succ_iff codeEvaluatorHistoryBeforeCell + (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell)) + (codePartrecPayload₁ (codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell))) + (codePartrecPayload₂ (codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell))) + (Code.proj (2 : Fin 3)) y ![s, ((q : ℕ) : M), u]).mp + hbranch + have hp1 := tagFour_read_payload₁ _ q ![s, ((q : ℕ) : M), u] hidx + have hp2 := tagFour_read_payload₂ _ q ![s, ((q : ℕ) : M), u] hidx + have hq1 := eval_iff_codeConst_of_eval _ (partrecCodePayload₁ q) ![s, ((q : ℕ) : M), u] hp1 + have hq2 := eval_iff_codeConst_of_eval _ (partrecCodePayload₂ q) ![s, ((q : ℕ) : M), u] hp2 + have hlaC := + (eval_codeTableLookup_query_congr codeEvaluatorHistoryBeforeCell + (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell)) + (codePartrecPayload₁ (codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell))) + (codeConst (n := 3) (partrecCodePayload₁ q)) (Code.proj (2 : Fin 3)) (a + 1) + ![s, ((q : ℕ) : M), u] hq1).mp + hla + have hlbC := + (eval_codeTableLookup_congr_at (codeLift codeEvaluatorHistoryBeforeCell) + (codeLift (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell))) + (codeLift + (codePartrecPayload₂ (codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell)))) + (codeLift (Code.proj (2 : Fin 3))) codeEvaluatorHistoryBeforeCell + (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell)) + (codeConst (n := 3) (partrecCodePayload₂ q)) (Code.proj (2 : Fin 3)) (b + 1) + (a :> ![s, ((q : ℕ) : M), u]) ![s, ((q : ℕ) : M), u] + (fun z => eval_codeLift_iff _ z a _) (fun z => eval_codeLift_iff _ z a _) + (fun z => (eval_codeLift_iff _ z a _).trans (hq2 z)) + (fun z => eval_codeLift_iff _ z a _)).mp + hlb + have hlt := tagFour_payloads_lt q hq + have hpre1 : + FFL.FirstOrder.Arithmetic.pair s ((partrecCodePayload₁ q : ℕ) : M) < + FFL.FirstOrder.Arithmetic.pair s ((q : ℕ) : M) := + FFL.FirstOrder.Arithmetic.pair_lt_pair_right s (by exact_mod_cast hlt.1) + have hpre2 : + FFL.FirstOrder.Arithmetic.pair s ((partrecCodePayload₂ q : ℕ) : M) < + FFL.FirstOrder.Arithmetic.pair s ((q : ℕ) : M) := + FFL.FirstOrder.Arithmetic.pair_lt_pair_right s (by exact_mod_cast hlt.2) + exact + ⟨a, b, + eval_codeHistoryEvaluator_succ_of_prefix_lookup s ((q : ℕ) : M) u a + (partrecCodePayload₁ q) hpre1 hlaC, + eval_codeHistoryEvaluator_succ_of_prefix_lookup s ((q : ℕ) : M) u b + (partrecCodePayload₂ q) hpre2 hlbC, + hy⟩ + +/-! +### The tag-4 strong-induction case -/ + +/-- **Tag-4 induction case of certificate persistence.** For a standard index +`q` of constructor number `4`, persistence of the certificate for `q` from stage +`s` to any later stage `t` follows from persistence for every strictly smaller +standard index, whatever its constructor number. The persistence predicate is +written out in both the hypothesis and the conclusion. -/ +theorem evalnCertificateFormula_natCode_persist_of_tag_four [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + (q : ℕ) (hq : partrecCodeTag q = 4) + (ih : + ∀ p : ℕ, + p < q → + ∀ s t u y : M, + s ≤ t → + Semiformula.Evalb ![s, ((p : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) → + Semiformula.Evalb ![t, ((p : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4)) : + ∀ s t u y : M, + s ≤ t → + Semiformula.Evalb ![s, ((q : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) → + Semiformula.Evalb ![t, ((q : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) := by + let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := + models_of_subtheory + (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + -- (1) arbitrary stages, argument and output, and a source certificate + intro s t u y hst source_certificate + have source_history := + (evalnCertificateFormula_eval_history_iff s ((q : ℕ) : M) u y).mp source_certificate + obtain ⟨hus, source_cell⟩ := + (eval_codeHistoryEvaluator_succ_iff_cell s ((q : ℕ) : M) u y).mp source_history + have hs : (0 : M) < s := + lt_of_le_of_lt (FFL.FirstOrder.Arithmetic.zero_le u) hus + have ht : (0 : M) < t := lt_of_lt_of_le hs hst + obtain ⟨a, b, payload₁_history_at_s, payload₂_history_at_s, hy⟩ := + tagFour_source_subcode_histories q hq s u y hs source_cell + have payload₁_lt : partrecCodePayload₁ q < q := (tagFour_payloads_lt q hq).1 + have payload₂_lt : partrecCodePayload₂ q < q := + (tagFour_payloads_lt q hq).2 + -- (7) source payload histories to source payload certificates + have payload₁_certificate_at_s := + (evalnCertificateFormula_eval_history_iff s ((partrecCodePayload₁ q : ℕ) : M) u a).mpr + payload₁_history_at_s + have payload₂_certificate_at_s := + (evalnCertificateFormula_eval_history_iff s ((partrecCodePayload₂ q : ℕ) : M) u b).mpr + payload₂_history_at_s + have payload₁_certificate_at_t := + ih (partrecCodePayload₁ q) payload₁_lt s t u a hst payload₁_certificate_at_s + have payload₂_certificate_at_t := + ih (partrecCodePayload₂ q) payload₂_lt s t u b hst payload₂_certificate_at_s + have payload₁_history_at_t := + (evalnCertificateFormula_eval_history_iff t ((partrecCodePayload₁ q : ℕ) : M) u a).mp + payload₁_certificate_at_t + have payload₂_history_at_t := + (evalnCertificateFormula_eval_history_iff t ((partrecCodePayload₂ q : ℕ) : M) u b).mp + payload₂_certificate_at_t + have payload₁_prefix : + FFL.FirstOrder.Arithmetic.pair t + ((partrecCodePayload₁ q : ℕ) : M) < + FFL.FirstOrder.Arithmetic.pair t ((q : ℕ) : M) := + FFL.FirstOrder.Arithmetic.pair_lt_pair_right t + (by exact_mod_cast payload₁_lt) + have payload₂_prefix : + FFL.FirstOrder.Arithmetic.pair t + ((partrecCodePayload₂ q : ℕ) : M) < + FFL.FirstOrder.Arithmetic.pair t ((q : ℕ) : M) := + FFL.FirstOrder.Arithmetic.pair_lt_pair_right t + (by exact_mod_cast payload₂_lt) + -- (10) target prefix/table lookups through the public converse bridge + have payload₁_lookup_at_t := + eval_prefix_lookup_succ_of_codeHistoryEvaluator t ((q : ℕ) : M) u a (partrecCodePayload₁ q) + payload₁_prefix payload₁_history_at_t + have payload₂_lookup_at_t := + eval_prefix_lookup_succ_of_codeHistoryEvaluator t ((q : ℕ) : M) u b (partrecCodePayload₂ q) + payload₂_prefix payload₂_history_at_t + have target_cell := + eval_codeEvaluatorCell_succ_of_pair_component_lookups codeEvaluatorHistoryBeforeCell + (Code.proj (2 : Fin 3)) q hq a b ![t, ((q : ℕ) : M), u] + (eval_codeEvaluatorCell_index t ((q : ℕ) : M) u) + ⟨t, ht, eval_codeEvaluatorCell_fuel t ((q : ℕ) : M) u⟩ payload₁_lookup_at_t + payload₂_lookup_at_t + rw [← hy] at target_cell + have target_history := + (eval_codeHistoryEvaluator_succ_iff_cell t ((q : ℕ) : M) u y).mpr + ⟨lt_of_lt_of_le hus hst, target_cell⟩ + -- (15) target history success to the target certificate + exact (evalnCertificateFormula_eval_history_iff t ((q : ℕ) : M) u y).mpr target_history + +end Evaluator +end CategoricalRiceShapiro + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/PersistenceInduction.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/PersistenceInduction.lean new file mode 100644 index 000000000..a49092c4a --- /dev/null +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/PersistenceInduction.lean @@ -0,0 +1,172 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.Certificate + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# The conditional induction principle for certificate persistence + +For a standard index `q`, write `C(s, q, u, y)` for the raw evaluator certificate +`evalnCertificateFormula` at `![s, q, u, y]`, and `P_q(s)` for +`∀ t u y, s ≤ t → C(s, q, u, y) → C(t, q, u, y)`. + +`persistenceFormula q` is an explicit arithmetic formula in one variable, and +`persistenceFormula_eval_iff` proves that it defines `P_q` in every model of +`𝐈𝐎𝐩𝐞𝐧`. `models_inductionScheme_univ` proves that a model of `𝐏𝐀` satisfies +the full induction scheme that `𝐏𝐀` contains. +`certificate_persistence_of_stage_induction` applies successor induction from +that scheme to `persistenceFormula q`: from `P_q(0)` and +`∀ s, P_q(s) → P_q(s + 1)` it derives `P_q(s)` for every `s`. + +The successor premise is a hypothesis of that theorem. The stage-zero premise +is proved here, by `evalnCertificateFormula_natCode_persist_of_stage_zero`, for +every standard index and independently of its constructor number: at stage `0` +no evaluator history has a row, so the source certificate is refutable and the +implication holds vacuously. + +The file proves no conditional persistence case at a constructor number. The +constructor-`6` cases and the full tag-6 theorem are in +`Evaluator.PrimitiveRecursionPersistence`; persistence for every standard index, +which needs the external induction on the index, is not proved anywhere in the +library. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +open scoped FFL.FirstOrder.Arithmetic + +namespace CategoricalRiceShapiro +namespace Evaluator + +variable {M : Type*} [ORingStructure M] + +/-- The certificate formula as a plain four-place arithmetic semisentence. -/ +def certificateSentence : ArithmeticSemisentence 4 := + (evalnCertificateFormula : ArithmeticSemisentence 4) + +/-- The persistence predicate at the standard index `q`, as an arithmetic +formula in the source stage: +`∀ t u y, s ≤ t → C(s, q, u, y) → C(t, q, u, y)`. -/ +def persistenceFormula (q : ℕ) : ArithmeticSemisentence 1 := + “s. ∀ t, ∀ u, ∀ y, s ≤ t → !certificateSentence s↑q u y → !certificateSentence t↑q u y” + +/-- The persistence formula defines the actual persistence predicate. -/ +theorem persistenceFormula_eval_iff [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (q : ℕ) (s : M) : + Semiformula.Evalb ![s] (persistenceFormula q) ↔ + ∀ t u y : M, + s ≤ t → + Semiformula.Evalb ![s, ((q : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) → + Semiformula.Evalb ![t, ((q : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) := + by simp [persistenceFormula, certificateSentence, Semiformula.eval_substs, numeral_eq_natCast] + +/-- The full induction scheme of `𝐏𝐀` holds in every model of `𝐏𝐀`. -/ +theorem models_inductionScheme_univ [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] : M↓[ℒₒᵣ] ⊧* InductionScheme ℒₒᵣ Set.univ := + by + have : InductionScheme ℒₒᵣ Set.univ ≼ 𝐏𝐀 := + Entailment.WeakerThan.ofSubset Set.subset_union_right + exact models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + +/-- **Conditional internal induction for certificate persistence** at a fixed +standard index `q`. The base and successor premises are explicit; this is not +a proof of persistence. The induction is the successor induction of `𝐏𝐀` +applied to `persistenceFormula q`. -/ +theorem certificate_persistence_of_stage_induction [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (q : ℕ) + (hzero : + ∀ t u y : M, + (0 : M) ≤ t → + Semiformula.Evalb ![(0 : M), ((q : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) → + Semiformula.Evalb ![t, ((q : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4)) + (hsucc : + ∀ s : M, + (∀ t u y : M, + s ≤ t → + Semiformula.Evalb ![s, ((q : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) → + Semiformula.Evalb ![t, ((q : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4)) → + ∀ t u y : M, + s + 1 ≤ t → + Semiformula.Evalb ![s + 1, ((q : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) → + Semiformula.Evalb ![t, ((q : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4)) : + ∀ s t u y : M, + s ≤ t → + Semiformula.Evalb ![s, ((q : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) → + Semiformula.Evalb ![t, ((q : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) := + by + have := models_inductionScheme_univ (M := M) + have : Inhabited M := ⟨0⟩ + intro s + refine + InductionScheme.succ_induction (C := Set.univ) (P := fun s : M => + ∀ t u y : M, + s ≤ t → + Semiformula.Evalb ![s, ((q : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) → + Semiformula.Evalb ![t, ((q : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4)) + ⟨fun _ => default, Rew.emb ▹ persistenceFormula q, trivial, ?_⟩ hzero hsucc s + intro x + rw [← persistenceFormula_eval_iff q x] + simp [Semiformula.eval_emb] + +/-! +### The stage-zero premise + +At stage `0` no evaluator history has a row, so no certificate holds there and +the premise is vacuous. Its conclusion is the `hzero` hypothesis of +`certificate_persistence_of_stage_induction` verbatim. + +The theory assumptions are `𝐏𝐀` and `𝐏𝐀⁻`. The second is an elaboration +requirement of the statement, since the standard-index cast `((q : ℕ) : M)` +needs it; it is no additional strength, `𝐏𝐀` proving every axiom of `𝐏𝐀⁻`. +Wherever `𝐈𝐎𝐩𝐞𝐧` is in scope the instance is synthesized and the argument is +invisible. -/ + +/-- **Stage-zero persistence.** For a standard index `q`, a certificate at +stage `0` persists to every stage `t`, vacuously: at stage `0` the certificate +is refutable. The proof uses no persistence theorem, no induction, no +constructor-number hypothesis and no smaller-index hypothesis, so the theorem +holds at every standard index. -/ +theorem evalnCertificateFormula_natCode_persist_of_stage_zero [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] + (q : ℕ) : + ∀ t u y : M, + (0 : M) ≤ t → + Semiformula.Evalb ![(0 : M), ((q : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) → + Semiformula.Evalb ![t, ((q : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) := + by + intro t u y _ source_certificate + have source_history := + (evalnCertificateFormula_eval_history_iff (0 : M) ((q : ℕ) : M) u y).mp source_certificate + obtain ⟨hlt, -⟩ := + (eval_codeHistoryEvaluator_succ_iff_cell (0 : M) ((q : ℕ) : M) u y).mp source_history + exact absurd hlt (not_lt_of_ge (FFL.FirstOrder.Arithmetic.zero_le u)) + +end Evaluator +end CategoricalRiceShapiro + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/PrimitiveRecursionPersistence.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/PrimitiveRecursionPersistence.lean new file mode 100644 index 000000000..753373288 --- /dev/null +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/PrimitiveRecursionPersistence.lean @@ -0,0 +1,1026 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.Certificate +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.PersistenceInduction +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.PrimitiveRecursionStructuralBridges + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# Tag-6 certificate persistence + +Constructor number `6` is primitive recursion. This file proves conditional +certificate persistence at a standard index `q` with `partrecCodeTag q = 6`: +for arbitrary model stages `s ≤ t`, an arbitrary input and an arbitrary output, +a certificate for `q` at stage `s` persists to stage `t`, conditional on the +same persistence at every standard index `p < q`. The theory assumptions +throughout are `𝐏𝐀` and `𝐈𝐎𝐩𝐞𝐧`; the proofs obtain `𝐏𝐀⁻` from `𝐏𝐀` with +`models_of_subtheory`. + +The full theorem is assembled from two subcases distinguished by the recursion +argument of the input, and from the internal stage induction of +`Evaluator.PersistenceInduction`. + +Write `P_q(s)` for the fixed-stage predicate of `q` at a model stage `s`: every +certificate for `q` at stage `s`, on every input and every output, persists to +every stage `t ≥ s`. + +`evalnCertificateFormula_natCode_persist_of_tag_six_zero` concerns an input of +the form `pair z 0`, whose recursion argument is zero. It proves that the +certificate for `q` on that input persists from a stage `s` to every stage +`t ≥ s`, conditional on the same persistence for every standard index `p < q`, +whatever the constructor number of `p`. + +`evalnCertificateFormula_natCode_persist_of_tag_six_succ_step` concerns an input +of the form `pair z (a + 1)`, whose recursion argument is a successor. It +proves one step: a certificate at a stage `k + 1` persists to every stage +`t ≥ k + 1`, conditional on both `P_q(k)` and persistence for every standard +index `p < q`. The two hypotheses govern disjoint lookups. The predecessor +lookup has index `q`, and only `P_q(k)` governs it; the step-payload lookup has +index `partrecCodePayload₂ q < q`, and only the smaller-index hypothesis governs +it. The theorem performs no induction on a model element. + +The zero-argument proof derives the source history from the source certificate +and the source cell from the source history; the fuel `s` of that cell is +positive. It re-encodes `q` as the canonical primitive-recursion index of its +decoded payloads, reads the constructor number `6` and the two payloads inside +the model, and proves that the cell value is the value of the primitive- +recursion branch. By `eval_codePrecEvaluatorCell_succ_iff_of_zero`, at the +source stage the branch value is the value of the lookup of the base payload, +from which `eval_codeHistoryEvaluator_succ_of_prefix_lookup` derives a source +history of the base payload on `z`. The induction hypothesis is applied once, +at `partrecCodePayload₁ q`. At the target stage the reverse direction of the +same equivalence gives the branch its value; the target history value and +`eval_codeEvaluatorCell_exists_of_values` give the whole target cell a value, +and `eval_unique` identifies it with the branch value. The target cell then +gives the target history and the target certificate. + +The successor-argument proof follows the same outline through the cell and the +branch, but uses `eval_codePrecEvaluatorCell_succ_iff_of_succ`, whose forward +direction produces an intermediate value `x` together with the predecessor +lookup and the step-payload lookup. The predecessor lookup at the source stage +becomes a history of `q` on `pair z a` at stage `k`, to which `P_q(k)` applies, +with `k ≤ t - 1` derived from `k + 1 ≤ t`; the general earlier-row bridge +`eval_codeTableLookup_succ_iff_codeHistoryEvaluator_of_history` returns the +result to a lookup at the arbitrary target stage `t`, whose first environment +component is not a literal successor. The same general bridge, instantiated on +the lifted four-place environment of the step branch, relates both step-payload +lookups to histories of `partrecCodePayload₂ q` on `pair z (pair a x)`, to which +the smaller-index hypothesis applies. The reverse direction of the successor +equivalence, at the same `x`, gives the target branch its value, and the +remaining steps are those of the zero-argument proof. No new public structural +bridge is required. + +`evalnCertificateFormula_natCode_persist_of_tag_six_succ` assembles the complete +successor premise `P_q(k) → P_q(k + 1)` from the two subcases. An arbitrary +input `u` is `pair (π₁ u) (π₂ u)` by `pair_unpair`, and its recursion argument +`π₂ u` is split into the zero and positive cases by the dichotomy +`0 < π₂ u ∨ 0 = π₂ u`; the zero case is the zero-argument theorem at source +stage `k + 1`, and the positive case is the one-step successor theorem at +`π₂ u - 1`, the only case that uses `P_q(k)`. + +`evalnCertificateFormula_natCode_persist_of_tag_six` applies +`certificate_persistence_of_stage_induction` to that successor premise and to +the stage-zero premise `evalnCertificateFormula_natCode_persist_of_stage_zero` +of `Evaluator.PersistenceInduction`. The induction on the stage is internal to +the model and belongs to that interface; no induction on a model element occurs +in this file. + +The generic readings of the history, the fuel and the program index are the +public theorems of `Evaluator.HistoryEvaluation`; the fourteen private helpers +below are local to this file. + +Scope: + +* this file proves tag-6 certificate persistence for a standard index of + constructor number `6`, at arbitrary model stages, inputs and outputs, + conditional on persistence at every smaller standard index; +* that hypothesis is discharged only by the external induction on the standard + index, which is not proved in the library; +* it proves no persistence case at constructor numbers `0`–`3` or `7`; +* it proves no persistence theorem for every standard index; +* it proves no theorem of Appendix B. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +open scoped FFL.FirstOrder.Arithmetic + +open Nat.ArithPart₁ + +open CategoricalRiceShapiro.ArithmeticCode + +open CategoricalRiceShapiro.PartialRecursive + +namespace CategoricalRiceShapiro +namespace Evaluator + +variable {M : Type*} [ORingStructure M] + +/-! +### Re-encoding and readings at a standard tag-6 index -/ + +/-- A standard tag-6 index, cast into the model, is the canonical +primitive-recursion index of its decoded payloads. -/ +private theorem tagSix_canonical_cast [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] (q : ℕ) (hq : partrecCodeTag q = 6) : + ((q : ℕ) : M) = + ((canonicalPartrecPrecIndex (partrecCodePayload₁ q) (partrecCodePayload₂ q) : ℕ) : M) := + by conv_lhs => rw [partrecCode_eq_canonicalPartrecPrecIndex_of_tag_six q hq] + +/-- The constructor number `6`, read at a standard tag-6 index. -/ +private theorem tagSix_read_tag [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) + (hq : partrecCodeTag q = 6) (v : Fin r → M) + (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : + Semiformula.Evalb ((6 : M) :> v) (code (codePartrecTag d)) := + by + rw [tagSix_canonical_cast (M := M) q hq] at hd + exact + eval_codePartrecTag_canonicalPartrecPrecIndex d (partrecCodePayload₁ q) + (partrecCodePayload₂ q) v hd + +/-- The base payload, read at a standard tag-6 index. -/ +private theorem tagSix_read_payload₁ [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) + (hq : partrecCodeTag q = 6) (v : Fin r → M) + (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : + Semiformula.Evalb (((partrecCodePayload₁ q : ℕ) : M) :> v) (code (codePartrecPayload₁ d)) := + by + rw [tagSix_canonical_cast (M := M) q hq] at hd + exact + eval_codePartrecPayload₁_canonicalPartrecPrecIndex d (partrecCodePayload₁ q) + (partrecCodePayload₂ q) v hd + +/-- The step payload, read at a standard tag-6 index. -/ +private theorem tagSix_read_payload₂ [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) + (hq : partrecCodeTag q = 6) (v : Fin r → M) + (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : + Semiformula.Evalb (((partrecCodePayload₂ q : ℕ) : M) :> v) (code (codePartrecPayload₂ d)) := + by + rw [tagSix_canonical_cast (M := M) q hq] at hd + exact + eval_codePartrecPayload₂_canonicalPartrecPrecIndex d (partrecCodePayload₁ q) + (partrecCodePayload₂ q) v hd + +/-! +### The constructor-6 branch of the eager dispatcher -/ + +/-- With positive fuel and a tag reading of `6`, the cell value is the value of +the primitive-recursion branch. The first comparison of the dispatcher, with +`4`, and the second, with `5`, both fail, and the third, with `6`, succeeds. -/ +private theorem tagSix_prec_branch [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (dtable dn : Code r) (v : Fin r → M) + (z k : M) (hk : Semiformula.Evalb (k :> v) (code (codeUnpair₁ (codeListLength dtable)))) + (hkpos : 0 < k) + (htag : + Semiformula.Evalb ((6 : M) :> v) + (code (codePartrecTag (codeUnpair₂ (codeListLength dtable))))) + (hcell : Semiformula.Evalb (z :> v) (code (codeEvaluatorCell dtable dn))) : + Semiformula.Evalb (z :> v) + (code + (codePrecEvaluatorCell dtable + (codeSub (codeUnpair₁ (codeListLength dtable)) (codeConst 1)) + (codeUnpair₂ (codeListLength dtable)) + (codePartrecPayload₁ (codeUnpair₂ (codeListLength dtable))) + (codePartrecPayload₂ (codeUnpair₂ (codeListLength dtable))) dn)) := + by + have hconst : + ∀ (m : ℕ) (x : M), + Semiformula.Evalb (x :> v) (code (codeConst (n := r) m)) → x = ((m : ℕ) : M) := + fun m x hx => eval_unique hx (eval_codeConst m v) + have hcast4 : ((4 : ℕ) : M) = (4 : M) := by simp + have hcast5 : ((5 : ℕ) : M) = (5 : M) := by simp + have hcast6 : ((6 : ℕ) : M) = (6 : M) := by simp + have hne64 : ¬((6 : M) = ((4 : ℕ) : M)) := + by + rw [hcast4] + exact fun hc => + absurd hc.symm + (_root_.ne_of_lt + (by + simpa [FFL.FirstOrder.Arithmetic.numeral_eq_natCast] using + (FFL.FirstOrder.Arithmetic.numeral_lt_of_lt (M := M) (by omega : 4 < 6)))) + have hne65 : ¬((6 : M) = ((5 : ℕ) : M)) := + by + rw [hcast5] + exact fun hc => + absurd hc.symm + (_root_.ne_of_lt + (by + simpa [FFL.FirstOrder.Arithmetic.numeral_eq_natCast] using + (FFL.FirstOrder.Arithmetic.numeral_lt_of_lt (M := M) (by omega : 5 < 6)))) + simp only [codeEvaluatorCell] at hcell + obtain ⟨kf, hkf, hkcase⟩ := eval_codeIfPos_cases _ _ _ z v hcell + have hkfk : kf = k := eval_unique hkf hk + rcases hkcase with ⟨-, hafterFuel⟩ | ⟨h0, -⟩ + swap + · exact absurd (hkfk ▸ h0 : k = 0) (ne_of_gt hkpos) + obtain ⟨e4, he4, h4case⟩ := eval_codeIfPos_cases _ _ _ z v hafterFuel + rw [eval_codeEq_iff] at he4 + obtain ⟨a4, b4, ha4, hb4, hc4⟩ := he4 + have ha46 : a4 = (6 : M) := eval_unique ha4 htag + have hb44 : b4 = ((4 : ℕ) : M) := hconst 4 b4 hb4 + have he40 : e4 = 0 := by + rcases hc4 with ⟨heq, -⟩ | ⟨-, h0⟩ + · exact absurd (by rw [← ha46, ← hb44]; exact heq) hne64 + · exact h0 + rcases h4case with ⟨hpos, -⟩ | ⟨-, hafterFour⟩ + · exact absurd (he40 ▸ hpos) (_root_.lt_irrefl 0) + obtain ⟨e5, he5, h5case⟩ := eval_codeIfPos_cases _ _ _ z v hafterFour + rw [eval_codeEq_iff] at he5 + obtain ⟨a5, b5, ha5, hb5, hc5⟩ := he5 + have ha56 : a5 = (6 : M) := eval_unique ha5 htag + have hb55 : b5 = ((5 : ℕ) : M) := hconst 5 b5 hb5 + have he50 : e5 = 0 := by + rcases hc5 with ⟨heq, -⟩ | ⟨-, h0⟩ + · exact absurd (by rw [← ha56, ← hb55]; exact heq) hne65 + · exact h0 + rcases h5case with ⟨hpos, -⟩ | ⟨-, hafterFive⟩ + · exact absurd (he50 ▸ hpos) (_root_.lt_irrefl 0) + obtain ⟨e6, he6, h6case⟩ := eval_codeIfPos_cases _ _ _ z v hafterFive + rw [eval_codeEq_iff] at he6 + obtain ⟨a6, b6, ha6, hb6, hc6⟩ := he6 + have ha66 : a6 = (6 : M) := eval_unique ha6 htag + have hb66 : b6 = ((6 : ℕ) : M) := hconst 6 b6 hb6 + have he61 : e6 = 1 := by + rcases hc6 with ⟨-, h1⟩ | ⟨hne, -⟩ + · exact h1 + · exact absurd (by rw [ha66, hb66, hcast6]) hne + rcases h6case with ⟨-, hprec⟩ | ⟨h0, -⟩ + · exact hprec + · exact absurd (he61 ▸ h0 : (1 : M) = 0) _root_.one_ne_zero + +/-! +### Fuel arithmetic and the readings the branch uses -/ + +/-- The dispatcher evaluates the branch at the decremented fuel `k - 1`; for +positive `k`, its successor, the key of the base lookup, is `k`. -/ +private theorem tagSix_succ_pred [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : M} (hk : 0 < k) : k - 1 + 1 = k := + FFL.FirstOrder.Arithmetic.sub_add_self_of_le + (FFL.FirstOrder.Arithmetic.one_le_of_zero_lt k hk) + +/-- The decremented fuel, as the dispatcher computes it. -/ +private theorem tagSix_decremented_fuel [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] + (s qCode u : M) : + Semiformula.Evalb ((s - 1) :> ![s, qCode, u]) + (code + (codeSub (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell)) + (codeConst 1))) := + by + have hone : Semiformula.Evalb ((1 : M) :> ![s, qCode, u]) (code (codeConst (n := 3) 1)) := + by + have h := eval_codeConst (M := M) (k := 3) 1 ![s, qCode, u] + have hcast : (((1 : ℕ)) : M) = (1 : M) := by simp + rwa [hcast] at h + exact + eval_codeSub _ (codeConst 1) s (1 : M) ![s, qCode, u] + (eval_codeEvaluatorCell_fuel s qCode u) hone + +/-- The key of the base lookup is the fuel. -/ +private theorem tagSix_base_key [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] + (s qCode u : M) (hs : 0 < s) : + Semiformula.Evalb (s :> ![s, qCode, u]) + (code + (codeSucc + (codeSub (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell)) + (codeConst 1)))) := + by + refine (eval_codeSucc_iff _ _ _).mpr ⟨s - 1, tagSix_decremented_fuel s qCode u, ?_⟩ + exact (tagSix_succ_pred hs).symm + +/-! +### Relating the base lookup of the branch to the history bridges + +The branch reads its table, key, query and argument through decoded codes; the +history bridges use the fuel key, a constant query and the argument itself. The +four congruences below prove that the two forms have the same values. -/ + +private theorem tagSix_table_congr [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (s qCode u z x : M) : + Semiformula.Evalb (x :> ![s, qCode, u]) (code codeEvaluatorHistoryBeforeCell) ↔ + Semiformula.Evalb (x :> ![s, qCode, z]) (code codeEvaluatorHistoryBeforeCell) := + by + have hpair : + ∀ c : M, + Semiformula.Evalb (FFL.FirstOrder.Arithmetic.pair s qCode :> ![s, qCode, c]) + (code (codePair (Code.proj (0 : Fin 3)) (Code.proj (1 : Fin 3)))) := + fun c => + eval_codePair _ _ s qCode ![s, qCode, c] ((eval_proj_iff _ _ _).mpr rfl) + ((eval_proj_iff _ _ _).mpr rfl) + rw [codeEvaluatorHistoryBeforeCell, eval_comp_iff, eval_comp_iff] + constructor + · rintro ⟨w, hw, hcomp⟩ + refine ⟨w, hw, ?_⟩ + intro i + refine Fin.cases ?_ (fun j => Fin.elim0 j) i + have h0 := hcomp 0 + have : w 0 = FFL.FirstOrder.Arithmetic.pair s qCode := eval_unique h0 (hpair u) + simpa [this] using hpair z + · rintro ⟨w, hw, hcomp⟩ + refine ⟨w, hw, ?_⟩ + intro i + refine Fin.cases ?_ (fun j => Fin.elim0 j) i + have h0 := hcomp 0 + have : w 0 = FFL.FirstOrder.Arithmetic.pair s qCode := eval_unique h0 (hpair z) + simpa [this] using hpair u + +private theorem tagSix_key_congr [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] + (s qCode u z : M) (hs : 0 < s) (x : M) : + Semiformula.Evalb (x :> ![s, qCode, u]) + (code + (codeSucc + (codeSub (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell)) + (codeConst 1)))) ↔ + Semiformula.Evalb (x :> ![s, qCode, z]) + (code (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell))) := + by + constructor + · intro hx + have hxs : x = s := eval_unique hx (tagSix_base_key s qCode u hs) + rw [hxs] + exact eval_codeEvaluatorCell_fuel s qCode z + · intro hx + have hxs : x = s := eval_unique hx (eval_codeEvaluatorCell_fuel s qCode z) + rw [hxs] + exact tagSix_base_key s qCode u hs + +private theorem tagSix_query_congr [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] + (s u z : M) (q : ℕ) (hq : partrecCodeTag q = 6) (x : M) : + Semiformula.Evalb (x :> ![s, ((q : ℕ) : M), u]) + (code + (codePartrecPayload₁ (codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell)))) ↔ + Semiformula.Evalb (x :> ![s, ((q : ℕ) : M), z]) + (code (codeConst (n := 3) (partrecCodePayload₁ q))) := + by + have hleft := tagSix_read_payload₁ _ q hq _ (eval_codeEvaluatorCell_index s ((q : ℕ) : M) u) + have hright : + Semiformula.Evalb (((partrecCodePayload₁ q : ℕ) : M) :> ![s, ((q : ℕ) : M), z]) + (code (codeConst (n := 3) (partrecCodePayload₁ q))) := + eval_codeConst _ ![s, ((q : ℕ) : M), z] + constructor + · intro hx + have hxv : x = ((partrecCodePayload₁ q : ℕ) : M) := eval_unique hx hleft + rw [hxv] + exact hright + · intro hx + have hxv : x = ((partrecCodePayload₁ q : ℕ) : M) := eval_unique hx hright + rw [hxv] + exact hleft + +private theorem tagSix_argument_congr [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (s qCode z x : M) : + Semiformula.Evalb (x :> ![s, qCode, FFL.FirstOrder.Arithmetic.pair z 0]) + (code (codeUnpair₁ (Code.proj (2 : Fin 3)))) ↔ + Semiformula.Evalb (x :> ![s, qCode, z]) (code (Code.proj (2 : Fin 3))) := + by + have hleft : + Semiformula.Evalb (z :> ![s, qCode, FFL.FirstOrder.Arithmetic.pair z 0]) + (code (codeUnpair₁ (Code.proj (2 : Fin 3)))) := + by + have h := + eval_codeUnpair₁ (Code.proj (2 : Fin 3)) (FFL.FirstOrder.Arithmetic.pair z 0) + ![s, qCode, FFL.FirstOrder.Arithmetic.pair z 0] ((eval_proj_iff _ _ _).mpr rfl) + rwa [FFL.FirstOrder.Arithmetic.pi₁_pair] at h + have hright : Semiformula.Evalb (z :> ![s, qCode, z]) (code (Code.proj (2 : Fin 3))) := + (eval_proj_iff _ _ _).mpr rfl + constructor + · intro hx + have hxz : x = z := eval_unique hx hleft + rw [hxz] + exact hright + · intro hx + have hxz : x = z := eval_unique hx hright + rw [hxz] + exact hleft + +/-! +### The zero-argument case -/ + +/-- **Tag-6 certificate persistence on a zero recursion argument.** For a +standard index `q` of constructor number `6`, a certificate on an input +`pair z 0` persists from a stage `s` to any later stage `t`, given persistence +for every strictly smaller standard index. This is the zero-argument +induction subcase only; the successor argument is not treated here. -/ +theorem evalnCertificateFormula_natCode_persist_of_tag_six_zero [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] + [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (q : ℕ) (hq : partrecCodeTag q = 6) + (ih : + ∀ p : ℕ, + p < q → + ∀ s t u y : M, + s ≤ t → + Semiformula.Evalb ![s, ((p : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) → + Semiformula.Evalb ![t, ((p : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4)) : + ∀ s t z y : M, + s ≤ t → + Semiformula.Evalb + ![s, ((q : ℕ) : M), + FFL.FirstOrder.Arithmetic.pair z 0, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) → + Semiformula.Evalb + ![t, ((q : ℕ) : M), + FFL.FirstOrder.Arithmetic.pair z 0, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) := by + let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + intro s t z y hst source_certificate + set dtable : Code 3 := codeEvaluatorHistoryBeforeCell with hdtable + set dk' : Code 3 := + codeSub (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell)) (codeConst 1) with + hdk' + set dq : Code 3 := codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell) with hdq + set dcf : Code 3 := + codePartrecPayload₁ (codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell)) with hdcf + set dcg : Code 3 := + codePartrecPayload₂ (codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell)) with hdcg + set dn : Code 3 := Code.proj (2 : Fin 3) with hdn + have source_history := + (evalnCertificateFormula_eval_history_iff s ((q : ℕ) : M) + (FFL.FirstOrder.Arithmetic.pair z 0) y).mp + source_certificate + obtain ⟨hus, source_cell⟩ := + (eval_codeHistoryEvaluator_succ_iff_cell s ((q : ℕ) : M) + (FFL.FirstOrder.Arithmetic.pair z 0) y).mp + source_history + have hs : (0 : M) < s := + lt_of_le_of_lt + (FFL.FirstOrder.Arithmetic.zero_le + (FFL.FirstOrder.Arithmetic.pair z 0)) + hus + have ht : (0 : M) < t := lt_of_lt_of_le hs hst + obtain ⟨Hs, hHs, -⟩ := + eval_codeEvaluatorHistoryBeforeCell_exists s ((q : ℕ) : M) + (FFL.FirstOrder.Arithmetic.pair z 0) + have hidx_s := + eval_codeEvaluatorCell_index s ((q : ℕ) : M) + (FFL.FirstOrder.Arithmetic.pair z 0) + have htag_s := tagSix_read_tag _ q hq _ hidx_s + have hn_s : + Semiformula.Evalb + (FFL.FirstOrder.Arithmetic.pair z 0 :> + ![s, ((q : ℕ) : M), FFL.FirstOrder.Arithmetic.pair z 0]) + (code (Code.proj (2 : Fin 3))) := + (eval_proj_iff _ _ _).mpr rfl + have source_branch := + tagSix_prec_branch codeEvaluatorHistoryBeforeCell (Code.proj (2 : Fin 3)) + ![s, ((q : ℕ) : M), FFL.FirstOrder.Arithmetic.pair z 0] + (y + 1) s + (eval_codeEvaluatorCell_fuel s ((q : ℕ) : M) + (FFL.FirstOrder.Arithmetic.pair z 0)) + hs htag_s source_cell + have source_equivalence : + Semiformula.Evalb + ((y + 1) :> + ![s, ((q : ℕ) : M), FFL.FirstOrder.Arithmetic.pair z 0]) + (code (codePrecEvaluatorCell dtable dk' dq dcf dcg dn)) ↔ + Semiformula.Evalb + ((y + 1) :> + ![s, ((q : ℕ) : M), FFL.FirstOrder.Arithmetic.pair z 0]) + (code (codeTableLookup dtable (codeSucc dk') dcf (codeUnpair₁ dn))) := + eval_codePrecEvaluatorCell_succ_iff_of_zero dtable dk' dq dcf dcg dn Hs (s - 1) + ((q : ℕ) : M) ((partrecCodePayload₁ q : ℕ) : M) ((partrecCodePayload₂ q : ℕ) : M) z y + ![s, ((q : ℕ) : M), FFL.FirstOrder.Arithmetic.pair z 0] hHs + (tagSix_decremented_fuel s ((q : ℕ) : M) + (FFL.FirstOrder.Arithmetic.pair z 0)) + hidx_s (tagSix_read_payload₁ _ q hq _ hidx_s) (tagSix_read_payload₂ _ q hq _ hidx_s) hn_s + have source_base_lookup := source_equivalence.mp source_branch + have source_lookup_fuelled := + (eval_codeTableLookup_congr_at codeEvaluatorHistoryBeforeCell + (codeSucc + (codeSub (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell)) + (codeConst 1))) + (codePartrecPayload₁ (codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell))) + (codeUnpair₁ (Code.proj (2 : Fin 3))) codeEvaluatorHistoryBeforeCell + (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell)) + (codeConst (n := 3) (partrecCodePayload₁ q)) (Code.proj (2 : Fin 3)) (y + 1) + ![s, ((q : ℕ) : M), FFL.FirstOrder.Arithmetic.pair z 0] + ![s, ((q : ℕ) : M), z] + (tagSix_table_congr s ((q : ℕ) : M) + (FFL.FirstOrder.Arithmetic.pair z 0) z) + (tagSix_key_congr s ((q : ℕ) : M) + (FFL.FirstOrder.Arithmetic.pair z 0) z hs) + (tagSix_query_congr s + (FFL.FirstOrder.Arithmetic.pair z 0) z q hq) + (tagSix_argument_congr s ((q : ℕ) : M) z)).mp + source_base_lookup + have payload₁_lt : partrecCodePayload₁ q < q := (partrecCodePayloads_lt_of_tag_six q hq).1 + have prefix_s : + FFL.FirstOrder.Arithmetic.pair s + ((partrecCodePayload₁ q : ℕ) : M) < + FFL.FirstOrder.Arithmetic.pair s ((q : ℕ) : M) := + FFL.FirstOrder.Arithmetic.pair_lt_pair_right s + (by exact_mod_cast payload₁_lt) + -- (8, continued) the source lookup gives a source history for the base payload on `z` + have payload₁_history_at_s := + eval_codeHistoryEvaluator_succ_of_prefix_lookup s ((q : ℕ) : M) z y (partrecCodePayload₁ q) + prefix_s source_lookup_fuelled + have payload₁_certificate_at_s := + (evalnCertificateFormula_eval_history_iff s ((partrecCodePayload₁ q : ℕ) : M) z y).mpr + payload₁_history_at_s + have payload₁_certificate_at_t := + ih (partrecCodePayload₁ q) payload₁_lt s t z y hst payload₁_certificate_at_s + have payload₁_history_at_t := + (evalnCertificateFormula_eval_history_iff t ((partrecCodePayload₁ q : ℕ) : M) z y).mp + payload₁_certificate_at_t + have prefix_t : + FFL.FirstOrder.Arithmetic.pair t + ((partrecCodePayload₁ q : ℕ) : M) < + FFL.FirstOrder.Arithmetic.pair t ((q : ℕ) : M) := + FFL.FirstOrder.Arithmetic.pair_lt_pair_right t + (by exact_mod_cast payload₁_lt) + have target_lookup := + eval_prefix_lookup_succ_of_codeHistoryEvaluator t ((q : ℕ) : M) z y (partrecCodePayload₁ q) + prefix_t payload₁_history_at_t + obtain ⟨Ht, hHt, -⟩ := + eval_codeEvaluatorHistoryBeforeCell_exists t ((q : ℕ) : M) + (FFL.FirstOrder.Arithmetic.pair z 0) + have hidx_t := + eval_codeEvaluatorCell_index t ((q : ℕ) : M) + (FFL.FirstOrder.Arithmetic.pair z 0) + have htag_t := tagSix_read_tag _ q hq _ hidx_t + have hn_t : + Semiformula.Evalb + (FFL.FirstOrder.Arithmetic.pair z 0 :> + ![t, ((q : ℕ) : M), FFL.FirstOrder.Arithmetic.pair z 0]) + (code (Code.proj (2 : Fin 3))) := + (eval_proj_iff _ _ _).mpr rfl + have target_lookup_decoded := + (eval_codeTableLookup_congr_at codeEvaluatorHistoryBeforeCell + (codeSucc + (codeSub (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell)) + (codeConst 1))) + (codePartrecPayload₁ (codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell))) + (codeUnpair₁ (Code.proj (2 : Fin 3))) codeEvaluatorHistoryBeforeCell + (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell)) + (codeConst (n := 3) (partrecCodePayload₁ q)) (Code.proj (2 : Fin 3)) (y + 1) + ![t, ((q : ℕ) : M), FFL.FirstOrder.Arithmetic.pair z 0] + ![t, ((q : ℕ) : M), z] + (tagSix_table_congr t ((q : ℕ) : M) + (FFL.FirstOrder.Arithmetic.pair z 0) z) + (tagSix_key_congr t ((q : ℕ) : M) + (FFL.FirstOrder.Arithmetic.pair z 0) z ht) + (tagSix_query_congr t + (FFL.FirstOrder.Arithmetic.pair z 0) z q hq) + (tagSix_argument_congr t ((q : ℕ) : M) z)).mpr + target_lookup + have target_equivalence : + Semiformula.Evalb + ((y + 1) :> + ![t, ((q : ℕ) : M), FFL.FirstOrder.Arithmetic.pair z 0]) + (code (codePrecEvaluatorCell dtable dk' dq dcf dcg dn)) ↔ + Semiformula.Evalb + ((y + 1) :> + ![t, ((q : ℕ) : M), FFL.FirstOrder.Arithmetic.pair z 0]) + (code (codeTableLookup dtable (codeSucc dk') dcf (codeUnpair₁ dn))) := + eval_codePrecEvaluatorCell_succ_iff_of_zero dtable dk' dq dcf dcg dn Ht (t - 1) + ((q : ℕ) : M) ((partrecCodePayload₁ q : ℕ) : M) ((partrecCodePayload₂ q : ℕ) : M) z y + ![t, ((q : ℕ) : M), FFL.FirstOrder.Arithmetic.pair z 0] hHt + (tagSix_decremented_fuel t ((q : ℕ) : M) + (FFL.FirstOrder.Arithmetic.pair z 0)) + hidx_t (tagSix_read_payload₁ _ q hq _ hidx_t) (tagSix_read_payload₂ _ q hq _ hidx_t) hn_t + have target_branch := target_equivalence.mpr target_lookup_decoded + obtain ⟨w, hw⟩ := + eval_codeEvaluatorCell_exists_of_values dtable dn Ht + (FFL.FirstOrder.Arithmetic.pair z 0) + ![t, ((q : ℕ) : M), FFL.FirstOrder.Arithmetic.pair z 0] hHt + hn_t + have target_cell : + Semiformula.Evalb + ((y + 1) :> + ![t, ((q : ℕ) : M), FFL.FirstOrder.Arithmetic.pair z 0]) + (code (codeEvaluatorCell codeEvaluatorHistoryBeforeCell (Code.proj (2 : Fin 3)))) := + by + have hbranch := + tagSix_prec_branch codeEvaluatorHistoryBeforeCell (Code.proj (2 : Fin 3)) + ![t, ((q : ℕ) : M), FFL.FirstOrder.Arithmetic.pair z 0] w + t + (eval_codeEvaluatorCell_fuel t ((q : ℕ) : M) + (FFL.FirstOrder.Arithmetic.pair z 0)) + ht htag_t hw + have hwy : w = y + 1 := eval_unique hbranch target_branch + rwa [hwy] at hw + have target_history := + (eval_codeHistoryEvaluator_succ_iff_cell t ((q : ℕ) : M) + (FFL.FirstOrder.Arithmetic.pair z 0) y).mpr + ⟨lt_of_lt_of_le hus hst, target_cell⟩ + exact + (evalnCertificateFormula_eval_history_iff t ((q : ℕ) : M) + (FFL.FirstOrder.Arithmetic.pair z 0) y).mpr + target_history + +/-! +### The two argument readings of the successor branch -/ + +/-- The predecessor lookup reads the argument `pair z a` from `pair z (a + 1)`. -/ +private theorem tagSix_predecessor_argument [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + (s qCode z a : M) : + Semiformula.Evalb + ((FFL.FirstOrder.Arithmetic.pair z a) :> + ![s, qCode, FFL.FirstOrder.Arithmetic.pair z (a + 1)]) + (code + (codePair (codeUnpair₁ (Code.proj (2 : Fin 3))) + (codeSub (codeUnpair₂ (Code.proj (2 : Fin 3))) (codeConst 1)))) := + by + let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + have hproj : + Semiformula.Evalb + (FFL.FirstOrder.Arithmetic.pair z (a + 1) :> + ![s, qCode, FFL.FirstOrder.Arithmetic.pair z (a + 1)]) + (code (Code.proj (2 : Fin 3))) := + (eval_proj_iff _ _ _).mpr rfl + have h1 := eval_codeUnpair₁ (Code.proj (2 : Fin 3)) _ _ hproj + rw [FFL.FirstOrder.Arithmetic.pi₁_pair] at h1 + have h2 := eval_codeUnpair₂ (Code.proj (2 : Fin 3)) _ _ hproj + rw [FFL.FirstOrder.Arithmetic.pi₂_pair] at h2 + have hone : + Semiformula.Evalb ((1 : M) :> ![s, qCode, FFL.FirstOrder.Arithmetic.pair z (a + 1)]) + (code (codeConst (n := 3) 1)) := + by rw [eval_codeConst_iff]; simp + have h3 := eval_codeSub _ (codeConst 1) (a + 1) 1 _ h2 hone + rw [add_sub_self] at h3 + exact eval_codePair _ _ z a _ h1 h3 + +/-- The step lookup reads the argument `pair z (pair a x)` in the lifted +environment, where the intermediate value `x` is the new head. -/ +private theorem tagSix_step_argument [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (s qCode z a x : M) : + Semiformula.Evalb + ((FFL.FirstOrder.Arithmetic.pair z (FFL.FirstOrder.Arithmetic.pair a x)) :> + (x :> ![s, qCode, FFL.FirstOrder.Arithmetic.pair z (a + 1)])) + (code + (codePair (codeLift (codeUnpair₁ (Code.proj (2 : Fin 3)))) + (codePair (codeLift (codeSub (codeUnpair₂ (Code.proj (2 : Fin 3))) (codeConst 1))) + (codeHead (n := 3))))) := + by + let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + have hproj : + Semiformula.Evalb + (FFL.FirstOrder.Arithmetic.pair z (a + 1) :> + ![s, qCode, FFL.FirstOrder.Arithmetic.pair z (a + 1)]) + (code (Code.proj (2 : Fin 3))) := + (eval_proj_iff _ _ _).mpr rfl + have h1 := eval_codeUnpair₁ (Code.proj (2 : Fin 3)) _ _ hproj + rw [FFL.FirstOrder.Arithmetic.pi₁_pair] at h1 + have h2 := eval_codeUnpair₂ (Code.proj (2 : Fin 3)) _ _ hproj + rw [FFL.FirstOrder.Arithmetic.pi₂_pair] at h2 + have hone : + Semiformula.Evalb ((1 : M) :> ![s, qCode, FFL.FirstOrder.Arithmetic.pair z (a + 1)]) + (code (codeConst (n := 3) 1)) := + by rw [eval_codeConst_iff]; simp + have h3 := eval_codeSub _ (codeConst 1) (a + 1) 1 _ h2 hone + rw [add_sub_self] at h3 + have hz : + Semiformula.Evalb (z :> (x :> ![s, qCode, FFL.FirstOrder.Arithmetic.pair z (a + 1)])) + (code (codeLift (codeUnpair₁ (Code.proj (2 : Fin 3))))) := + (eval_codeLift_iff _ _ _ _).mpr h1 + have ha : + Semiformula.Evalb (a :> (x :> ![s, qCode, FFL.FirstOrder.Arithmetic.pair z (a + 1)])) + (code (codeLift (codeSub (codeUnpair₂ (Code.proj (2 : Fin 3))) (codeConst 1)))) := + (eval_codeLift_iff _ _ _ _).mpr h3 + have hx : + Semiformula.Evalb (x :> (x :> ![s, qCode, FFL.FirstOrder.Arithmetic.pair z (a + 1)])) + (code (codeHead (n := 3))) := + (eval_codeHead_iff _ _).mpr rfl + exact eval_codePair _ _ z _ _ hz (eval_codePair _ _ a x _ ha hx) + +/-! +### The successor-argument one-step persistence theorem -/ + +-- The history code contains the whole evaluator-cell code. + +/-- **Tag-6 certificate persistence on a successor recursion argument, one +step.** For a standard index `q` of constructor number `6`, assume persistence +for every smaller standard index (`ih`) and the whole fixed-stage predicate at a +model stage `k` (`hpred`). Then a certificate at stage `k + 1` on an input +`pair z (a + 1)` persists to every stage `t ≥ k + 1`. + +The predecessor lookup has index `q`, so it is governed by `hpred`; the +step-payload lookup has index `partrecCodePayload₂ q < q`, so it is governed by +`ih`. This theorem performs no induction and does not use +`certificate_persistence_of_stage_induction`. -/ +theorem evalnCertificateFormula_natCode_persist_of_tag_six_succ_step [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] + [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (q : ℕ) (hq : partrecCodeTag q = 6) + (ih : + ∀ p : ℕ, + p < q → + ∀ s t u y : M, + s ≤ t → + Semiformula.Evalb ![s, ((p : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) → + Semiformula.Evalb ![t, ((p : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4)) + (k : M) + (hpred : + ∀ t u y : M, + k ≤ t → + Semiformula.Evalb ![k, ((q : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) → + Semiformula.Evalb ![t, ((q : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4)) : + ∀ t z a y : M, + k + 1 ≤ t → + Semiformula.Evalb + ![k + 1, ((q : ℕ) : M), + FFL.FirstOrder.Arithmetic.pair z (a + 1), y] + (evalnCertificateFormula : ArithmeticSemisentence 4) → + Semiformula.Evalb + ![t, ((q : ℕ) : M), + FFL.FirstOrder.Arithmetic.pair z (a + 1), y] + (evalnCertificateFormula : ArithmeticSemisentence 4) := by + let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + intro t z a y hkt source_certificate + set dtable : Code 3 := codeEvaluatorHistoryBeforeCell with hdtable + set dk' : Code 3 := + codeSub (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell)) (codeConst 1) with + hdk' + set dq : Code 3 := codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell) with hdq + set dcf : Code 3 := + codePartrecPayload₁ (codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell)) with hdcf + set dcg : Code 3 := + codePartrecPayload₂ (codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell)) with hdcg + set dn : Code 3 := Code.proj (2 : Fin 3) with hdn + set u : M := FFL.FirstOrder.Arithmetic.pair z (a + 1) with hu + have source_history := + (evalnCertificateFormula_eval_history_iff (k + 1) ((q : ℕ) : M) u y).mp source_certificate + obtain ⟨hus, source_cell⟩ := + (eval_codeHistoryEvaluator_succ_iff_cell (k + 1) ((q : ℕ) : M) u y).mp source_history + have hs : (0 : M) < k + 1 := + lt_of_le_of_lt (FFL.FirstOrder.Arithmetic.zero_le k) + (lt_add_one k) + have ht : (0 : M) < t := lt_of_lt_of_le hs hkt + have hpredt : t - 1 + 1 = t := tagSix_succ_pred ht + have htpred_lt : t - 1 < t := + by + have h : t - 1 < t - 1 + 1 := lt_add_one (t - 1) + rwa [hpredt] at h + obtain ⟨Hs, hHs, hHistS⟩ := eval_codeEvaluatorHistoryBeforeCell_exists (k + 1) ((q : ℕ) : M) u + have hidx_s := eval_codeEvaluatorCell_index (k + 1) ((q : ℕ) : M) u + have htag_s := tagSix_read_tag _ q hq _ hidx_s + have hn_s : Semiformula.Evalb (u :> ![k + 1, ((q : ℕ) : M), u]) (code dn) := + (eval_proj_iff _ _ _).mpr rfl + have source_branch := + tagSix_prec_branch codeEvaluatorHistoryBeforeCell (Code.proj (2 : Fin 3)) + ![k + 1, ((q : ℕ) : M), u] (y + 1) (k + 1) + (eval_codeEvaluatorCell_fuel (k + 1) ((q : ℕ) : M) u) hs htag_s source_cell + have source_equivalence : + Semiformula.Evalb ((y + 1) :> ![k + 1, ((q : ℕ) : M), u]) + (code (codePrecEvaluatorCell dtable dk' dq dcf dcg dn)) ↔ + ∃ x : M, + Semiformula.Evalb ((x + 1) :> ![k + 1, ((q : ℕ) : M), u]) + (code + (codeTableLookup dtable dk' dq + (codePair (codeUnpair₁ dn) (codeSub (codeUnpair₂ dn) (codeConst 1))))) ∧ + Semiformula.Evalb ((y + 1) :> x :> ![k + 1, ((q : ℕ) : M), u]) + (code + (codeTableLookup (codeLift dtable) (codeLift (codeSucc dk')) (codeLift dcg) + (codePair (codeLift (codeUnpair₁ dn)) + (codePair (codeLift (codeSub (codeUnpair₂ dn) (codeConst 1))) + (codeHead (n := 3)))))) := + eval_codePrecEvaluatorCell_succ_iff_of_succ dtable dk' dq dcf dcg dn Hs (k + 1 - 1) + ((q : ℕ) : M) ((partrecCodePayload₁ q : ℕ) : M) ((partrecCodePayload₂ q : ℕ) : M) z a y + ![k + 1, ((q : ℕ) : M), u] hHs (tagSix_decremented_fuel (k + 1) ((q : ℕ) : M) u) hidx_s + (tagSix_read_payload₁ _ q hq _ hidx_s) (tagSix_read_payload₂ _ q hq _ hidx_s) hn_s + obtain ⟨x, source_pred_lookup, source_step_lookup⟩ := source_equivalence.mp source_branch + obtain ⟨Ht, hHt, hHistT⟩ := eval_codeEvaluatorHistoryBeforeCell_exists t ((q : ℕ) : M) u + have hidx_t := eval_codeEvaluatorCell_index t ((q : ℕ) : M) u + have htag_t := tagSix_read_tag _ q hq _ hidx_t + have hn_t : Semiformula.Evalb (u :> ![t, ((q : ℕ) : M), u]) (code dn) := + (eval_proj_iff _ _ _).mpr rfl + have hist_pred_src : + Semiformula.Evalb + ![x + 1, k, ((q : ℕ) : M), + FFL.FirstOrder.Arithmetic.pair z a] + (code codeHistoryEvaluator) := + (eval_prec_predecessor_lookup_succ_iff_codeHistoryEvaluator k z a x q).mp source_pred_lookup + have cert_pred_src := + (evalnCertificateFormula_eval_history_iff k ((q : ℕ) : M) + (FFL.FirstOrder.Arithmetic.pair z a) x).mpr + hist_pred_src + have hk_le : k ≤ t - 1 := + by + have h : k + 1 ≤ t - 1 + 1 := by rw [hpredt]; exact hkt + exact le_of_add_le_add_right h + have cert_pred_tgt := + hpred (t - 1) (FFL.FirstOrder.Arithmetic.pair z a) x hk_le + cert_pred_src + have hist_pred_tgt := + (evalnCertificateFormula_eval_history_iff (t - 1) ((q : ℕ) : M) + (FFL.FirstOrder.Arithmetic.pair z a) x).mp + cert_pred_tgt + have target_pred_lookup : + Semiformula.Evalb ((x + 1) :> ![t, ((q : ℕ) : M), u]) + (code + (codeTableLookup dtable dk' dq + (codePair (codeUnpair₁ dn) (codeSub (codeUnpair₂ dn) (codeConst 1))))) := + (eval_codeTableLookup_succ_iff_codeHistoryEvaluator_of_history dtable dk' dq _ + ![t, ((q : ℕ) : M), u] + (FFL.FirstOrder.Arithmetic.pair t ((q : ℕ) : M)) Ht + (t - 1) (FFL.FirstOrder.Arithmetic.pair z a) x q hHistT + (FFL.FirstOrder.Arithmetic.pair_lt_pair_left htpred_lt + _) + hHt (tagSix_decremented_fuel t ((q : ℕ) : M) u) hidx_t + (tagSix_predecessor_argument t ((q : ℕ) : M) z a)).mpr + hist_pred_tgt + have hpayload₂_lt : partrecCodePayload₂ q < q := (partrecCodePayloads_lt_of_tag_six q hq).2 + have hrow_step : + ∀ s : M, + FFL.FirstOrder.Arithmetic.pair s + ((partrecCodePayload₂ q : ℕ) : M) < + FFL.FirstOrder.Arithmetic.pair s ((q : ℕ) : M) := + fun s => + FFL.FirstOrder.Arithmetic.pair_lt_pair_right s + (by exact_mod_cast hpayload₂_lt) + have hstep_bridge : + ∀ s : M, + (0 : M) < s → + ∀ H : M, + Semiformula.Evalb (H :> ![s, ((q : ℕ) : M), u]) (code dtable) → + Semiformula.Evalb + ![H, + FFL.FirstOrder.Arithmetic.pair s ((q : ℕ) : M)] + (code codeEvaluatorHistory) → + (Semiformula.Evalb ((y + 1) :> x :> ![s, ((q : ℕ) : M), u]) + (code + (codeTableLookup (codeLift dtable) (codeLift (codeSucc dk')) (codeLift dcg) + (codePair (codeLift (codeUnpair₁ dn)) + (codePair (codeLift (codeSub (codeUnpair₂ dn) (codeConst 1))) + (codeHead (n := 3)))))) ↔ + Semiformula.Evalb + ![y + 1, s, ((partrecCodePayload₂ q : ℕ) : M), + FFL.FirstOrder.Arithmetic.pair z + (FFL.FirstOrder.Arithmetic.pair a x)] + (code codeHistoryEvaluator)) := + by + intro s hspos H hH hHist + exact + eval_codeTableLookup_succ_iff_codeHistoryEvaluator_of_history (codeLift dtable) + (codeLift (codeSucc dk')) (codeLift dcg) _ (x :> ![s, ((q : ℕ) : M), u]) + (FFL.FirstOrder.Arithmetic.pair s ((q : ℕ) : M)) H s + (FFL.FirstOrder.Arithmetic.pair z + (FFL.FirstOrder.Arithmetic.pair a x)) + y (partrecCodePayload₂ q) hHist (hrow_step s) ((eval_codeLift_iff _ _ _ _).mpr hH) + ((eval_codeLift_iff _ _ _ _).mpr (tagSix_base_key s ((q : ℕ) : M) u hspos)) + ((eval_codeLift_iff _ _ _ _).mpr + (tagSix_read_payload₂ _ q hq _ (eval_codeEvaluatorCell_index s ((q : ℕ) : M) u))) + (tagSix_step_argument s ((q : ℕ) : M) z a x) + have hist_step_src := (hstep_bridge (k + 1) hs Hs hHs hHistS).mp source_step_lookup + have cert_step_src := + (evalnCertificateFormula_eval_history_iff (k + 1) ((partrecCodePayload₂ q : ℕ) : M) + (FFL.FirstOrder.Arithmetic.pair z + (FFL.FirstOrder.Arithmetic.pair a x)) + y).mpr + hist_step_src + have cert_step_tgt := + ih (partrecCodePayload₂ q) hpayload₂_lt (k + 1) t + (FFL.FirstOrder.Arithmetic.pair z + (FFL.FirstOrder.Arithmetic.pair a x)) + y hkt cert_step_src + have hist_step_tgt := + (evalnCertificateFormula_eval_history_iff t ((partrecCodePayload₂ q : ℕ) : M) + (FFL.FirstOrder.Arithmetic.pair z + (FFL.FirstOrder.Arithmetic.pair a x)) + y).mp + cert_step_tgt + have target_step_lookup := (hstep_bridge t ht Ht hHt hHistT).mpr hist_step_tgt + have target_equivalence : + Semiformula.Evalb ((y + 1) :> ![t, ((q : ℕ) : M), u]) + (code (codePrecEvaluatorCell dtable dk' dq dcf dcg dn)) ↔ + ∃ x' : M, + Semiformula.Evalb ((x' + 1) :> ![t, ((q : ℕ) : M), u]) + (code + (codeTableLookup dtable dk' dq + (codePair (codeUnpair₁ dn) (codeSub (codeUnpair₂ dn) (codeConst 1))))) ∧ + Semiformula.Evalb ((y + 1) :> x' :> ![t, ((q : ℕ) : M), u]) + (code + (codeTableLookup (codeLift dtable) (codeLift (codeSucc dk')) (codeLift dcg) + (codePair (codeLift (codeUnpair₁ dn)) + (codePair (codeLift (codeSub (codeUnpair₂ dn) (codeConst 1))) + (codeHead (n := 3)))))) := + eval_codePrecEvaluatorCell_succ_iff_of_succ dtable dk' dq dcf dcg dn Ht (t - 1) + ((q : ℕ) : M) ((partrecCodePayload₁ q : ℕ) : M) ((partrecCodePayload₂ q : ℕ) : M) z a y + ![t, ((q : ℕ) : M), u] hHt (tagSix_decremented_fuel t ((q : ℕ) : M) u) hidx_t + (tagSix_read_payload₁ _ q hq _ hidx_t) (tagSix_read_payload₂ _ q hq _ hidx_t) hn_t + have target_branch := + target_equivalence.mpr + ⟨x, target_pred_lookup, target_step_lookup⟩ + -- (8) the whole target cell has a value, and it is the branch value + obtain ⟨w, hw⟩ := + eval_codeEvaluatorCell_exists_of_values dtable dn Ht u ![t, ((q : ℕ) : M), u] hHt hn_t + have target_cell : + Semiformula.Evalb ((y + 1) :> ![t, ((q : ℕ) : M), u]) + (code (codeEvaluatorCell codeEvaluatorHistoryBeforeCell (Code.proj (2 : Fin 3)))) := + by + have hbranch := + tagSix_prec_branch codeEvaluatorHistoryBeforeCell (Code.proj (2 : Fin 3)) + ![t, ((q : ℕ) : M), u] w t (eval_codeEvaluatorCell_fuel t ((q : ℕ) : M) u) ht htag_t hw + have hwy : w = y + 1 := eval_unique hbranch target_branch + rwa [hwy] at hw + have target_history := + (eval_codeHistoryEvaluator_succ_iff_cell t ((q : ℕ) : M) u y).mpr + ⟨lt_of_lt_of_le hus hkt, target_cell⟩ + exact (evalnCertificateFormula_eval_history_iff t ((q : ℕ) : M) u y).mpr target_history + +/-! +### The complete successor premise over arbitrary inputs -/ + +/-- **The complete successor premise at constructor number `6`.** Assume +persistence at every standard index `p < q` and the whole fixed-stage predicate +of `q` at a model stage `k`. Then the fixed-stage predicate of `q` holds at +`k + 1`, over arbitrary inputs. + +The arbitrary input `u` is decomposed by `pair_unpair` into +`pair (π₁ u) (π₂ u)`, and the recursion argument `π₂ u` is split into its zero +and positive cases by the ordered-semiring dichotomy `0 < π₂ u ∨ 0 = π₂ u`. The +zero case is the zero-argument theorem above, at source stage `k + 1`; the +positive case is the one-step successor theorem above, at `π₂ u - 1`, and is the +only case that uses the supplied predicate at `k`. The proof performs no +induction; that dichotomy is its only split. -/ +theorem evalnCertificateFormula_natCode_persist_of_tag_six_succ [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] + [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (q : ℕ) (hq : partrecCodeTag q = 6) + (ih : + ∀ p : ℕ, + p < q → + ∀ s t u y : M, + s ≤ t → + Semiformula.Evalb ![s, ((p : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) → + Semiformula.Evalb ![t, ((p : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4)) + (k : M) + (hpred : + ∀ t u y : M, + k ≤ t → + Semiformula.Evalb ![k, ((q : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) → + Semiformula.Evalb ![t, ((q : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4)) : + ∀ t u y : M, + k + 1 ≤ t → + Semiformula.Evalb ![k + 1, ((q : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) → + Semiformula.Evalb ![t, ((q : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) := by + let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + intro t u y hkt source_certificate + obtain ⟨z, b, rfl⟩ : + ∃ z b : M, u = FFL.FirstOrder.Arithmetic.pair z b := + ⟨FFL.FirstOrder.Arithmetic.pi₁ u, + FFL.FirstOrder.Arithmetic.pi₂ u, + (FFL.FirstOrder.Arithmetic.pair_unpair u).symm⟩ + -- the recursion argument is zero or positive + rcases (FFL.FirstOrder.Arithmetic.zero_le b).lt_or_eq with hb | + hb + · -- positive: `b = (b - 1) + 1`, and the one-step successor theorem applies + obtain ⟨a, rfl⟩ : ∃ a : M, b = a + 1 := ⟨b - 1, (tagSix_succ_pred hb).symm⟩ + exact + evalnCertificateFormula_natCode_persist_of_tag_six_succ_step q hq ih k hpred t z a y hkt + source_certificate + · -- zero: the zero-argument theorem applies, from source stage `k + 1` + subst hb + exact + evalnCertificateFormula_natCode_persist_of_tag_six_zero q hq ih (k + 1) t z y hkt + source_certificate + +/-! +### Full conditional tag-6 persistence -/ + +/-- **Tag-6 certificate persistence.** For a standard index `q` of constructor +number `6`, a certificate persists from every stage `s` to every stage `t ≥ s`, +on arbitrary input and output, conditional on persistence at every standard +index `p < q`. The internal induction on the stage is +`certificate_persistence_of_stage_induction`; this theorem supplies its two +premises, the stage-zero premise of `Evaluator.PersistenceInduction` and the +complete successor premise above, and does not reproduce the induction. -/ +theorem evalnCertificateFormula_natCode_persist_of_tag_six [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + (q : ℕ) (hq : partrecCodeTag q = 6) + (ih : + ∀ p : ℕ, + p < q → + ∀ s t u y : M, + s ≤ t → + Semiformula.Evalb ![s, ((p : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) → + Semiformula.Evalb ![t, ((p : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4)) : + ∀ s t u y : M, + s ≤ t → + Semiformula.Evalb ![s, ((q : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) → + Semiformula.Evalb ![t, ((q : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) := + certificate_persistence_of_stage_induction q + (evalnCertificateFormula_natCode_persist_of_stage_zero q) + (fun k hpred => evalnCertificateFormula_natCode_persist_of_tag_six_succ q hq ih k hpred) + +end Evaluator +end CategoricalRiceShapiro + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/PrimitiveRecursionStructuralBridges.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/PrimitiveRecursionStructuralBridges.lean new file mode 100644 index 000000000..0eda69e9d --- /dev/null +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/PrimitiveRecursionStructuralBridges.lean @@ -0,0 +1,512 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.PartialRecursive.CanonicalComposition +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.CellEvaluation +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.HistoryEvaluation + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# Structural bridges for the primitive-recursion constructor + +Constructor number `6` is primitive recursion. This file supplies structural +infrastructure for it, in two parts. + +The first part, in `CategoricalRiceShapiro.PartialRecursive`, defines +`canonicalPartrecPrecIndex fCode gCode`, the canonical index of the primitive +recursion whose base program is named by `fCode` and whose step program is named +by `gCode`. It proves the decoder and ranking facts for that index: its closed +form `2 * (2 * Nat.pair fCode gCode) + 1 + 4`, its constructor number `6`, its +payload `Nat.pair fCode gCode` with components `fCode` and `gCode`, and the strict +bounds `fCode < canonicalPartrecPrecIndex fCode gCode` and +`gCode < canonicalPartrecPrecIndex fCode gCode`. It also proves the +corresponding readings of the payload, the constructor number and the two +components inside a model of `𝐏𝐀⁻`. + +The second part, in `CategoricalRiceShapiro.Evaluator`, proves the zero and +successor success equivalences for the primitive-recursion evaluator cell +`codePrecEvaluatorCell`, over `𝐏𝐀` and `𝐈𝐎𝐩𝐞𝐧`. For a zero recursion argument, +when the argument evaluates to `⟪z, 0⟫`, the cell succeeds with `y + 1` exactly +when the base lookup does. For a successor recursion argument, when the argument +evaluates to `⟪z, a + 1⟫`, the cell succeeds with `y + 1` exactly when, for one +intermediate value `x`, the lookup of the same index at the previous fuel on +`⟪z, a⟫` succeeds with `x + 1` and the step-program lookup at the current fuel on +`⟪z, ⟪a, x⟫⟫` succeeds with `y + 1`. + +The first part also proves, for an arbitrary natural number `q` with +constructor number `6`, that `q` is the canonical primitive-recursion index of +its decoded payload components, `q = canonicalPartrecPrecIndex +(partrecCodePayload₁ q) (partrecCodePayload₂ q)`, and that both decoded payloads +are strictly smaller than `q`. + +`eval_prec_predecessor_lookup_succ_iff_codeHistoryEvaluator` identifies the +same-index lookup of the successor equivalence, in the history before the cell +at `k + 1, q` and at input `⟪z, a + 1⟫`, with a successful `codeHistoryEvaluator` +evaluation at stage `k` on `⟪z, a⟫`, through +`eval_predecessor_lookup_succ_iff_codeHistoryEvaluator`. + +This is structural infrastructure. The file proves neither tag-6 persistence of +the evaluator certificate nor persistence for every standard index. +-/ + +@[expose] public section + +namespace CategoricalRiceShapiro +namespace PartialRecursive + +open Encodable Denumerable + +open CategoricalRiceShapiro.ArithmeticCode + +/-- The index of the primitive recursion whose base program is named by `fCode` +and whose step program is named by `gCode`. -/ +def canonicalPartrecPrecIndex (fCode gCode : ℕ) : ℕ := + Encodable.encode + (Nat.Partrec.Code.prec (Denumerable.ofNat Nat.Partrec.Code fCode) + (Denumerable.ofNat Nat.Partrec.Code gCode)) + +/-- The closed form of the canonical primitive-recursion index. -/ +theorem canonicalPartrecPrecIndex_eq (fCode gCode : ℕ) : + canonicalPartrecPrecIndex fCode gCode = 2 * (2 * Nat.pair fCode gCode) + 1 + 4 := + by + unfold canonicalPartrecPrecIndex + rw [Nat.Partrec.Code.encodeCode_eq] + simp only [Nat.Partrec.Code.encodeCode] + simp only [← Nat.Partrec.Code.encodeCode_eq, Denumerable.encode_ofNat] + +/-- The base subindex is below the canonical primitive-recursion index. -/ +theorem canonicalPartrecPrecIndex_base_lt (fCode gCode : ℕ) : + fCode < canonicalPartrecPrecIndex fCode gCode := + by + unfold canonicalPartrecPrecIndex + simpa only [Denumerable.encode_ofNat] using + (Nat.Partrec.Code.encode_lt_prec (Denumerable.ofNat Nat.Partrec.Code fCode) + (Denumerable.ofNat Nat.Partrec.Code gCode)).1 + +/-- The step subindex is below the canonical primitive-recursion index. -/ +theorem canonicalPartrecPrecIndex_step_lt (fCode gCode : ℕ) : + gCode < canonicalPartrecPrecIndex fCode gCode := + by + unfold canonicalPartrecPrecIndex + simpa only [Denumerable.encode_ofNat] using + (Nat.Partrec.Code.encode_lt_prec (Denumerable.ofNat Nat.Partrec.Code fCode) + (Denumerable.ofNat Nat.Partrec.Code gCode)).2 + +/-- The payload of the canonical primitive-recursion index is the pair of the +base and step subindices. -/ +theorem partrecCodePayload_canonicalPartrecPrecIndex (fCode gCode : ℕ) : + partrecCodePayload (canonicalPartrecPrecIndex fCode gCode) = Nat.pair fCode gCode := + by + have hsub : canonicalPartrecPrecIndex fCode gCode - 4 = 2 * (2 * Nat.pair fCode gCode) + 1 := + by rw [canonicalPartrecPrecIndex_eq]; omega + simp only [partrecCodePayload, hsub, Nat.div2_val] + omega + +/-- The canonical primitive-recursion index has constructor number `6`. +`bodd.toNat` and `% 2` are related by `Nat.mod_two_of_bodd`. -/ +theorem canonicalPartrecPrecIndex_constructor_number (fCode gCode : ℕ) : + partrecCodeTag (canonicalPartrecPrecIndex fCode gCode) = 6 := + by + have hb : ∀ n : ℕ, n.bodd.toNat = n % 2 := fun n => by rw [Nat.mod_two_of_bodd] + have hlt : ¬(canonicalPartrecPrecIndex fCode gCode < 4) := by + rw [canonicalPartrecPrecIndex_eq]; omega + have hsub : canonicalPartrecPrecIndex fCode gCode - 4 = 2 * (2 * Nat.pair fCode gCode) + 1 := + by rw [canonicalPartrecPrecIndex_eq]; omega + simp only [partrecCodeTag, hlt, ite_false, hsub, hb, Nat.div2_val] + omega + +/-- The first subcode of the canonical primitive-recursion index is the base +program. -/ +theorem canonicalPartrecPrecIndex_base_index (fCode gCode : ℕ) : + partrecCodePayload₁ (canonicalPartrecPrecIndex fCode gCode) = fCode := by + simp only [partrecCodePayload₁, partrecCodePayload_canonicalPartrecPrecIndex, Nat.unpair_pair] + +/-- The second subcode of the canonical primitive-recursion index is the step +program. -/ +theorem canonicalPartrecPrecIndex_step_index (fCode gCode : ℕ) : + partrecCodePayload₂ (canonicalPartrecPrecIndex fCode gCode) = gCode := by + simp only [partrecCodePayload₂, partrecCodePayload_canonicalPartrecPrecIndex, Nat.unpair_pair] + +/-- A natural number `q` of constructor number `6` is the canonical +primitive-recursion index of its two payload components. -/ +theorem partrecCode_eq_canonicalPartrecPrecIndex_of_tag_six (q : ℕ) + (hq : partrecCodeTag q = 6) : + q = canonicalPartrecPrecIndex (partrecCodePayload₁ q) (partrecCodePayload₂ q) := + by + have hb : ∀ n : ℕ, n.bodd.toNat = n % 2 := fun n => by rw [Nat.mod_two_of_bodd] + have h4 : ¬q < 4 := by + intro hlt + simp only [partrecCodeTag, hlt, ite_true] at hq + omega + simp only [partrecCodeTag, h4, ite_false, hb, Nat.div2_val] at hq + rw [canonicalPartrecPrecIndex_eq] + simp only [partrecCodePayload₁, partrecCodePayload₂, Nat.pair_unpair, partrecCodePayload, + Nat.div2_val] + omega + +/-- Both payload components of a natural number `q` of constructor number `6` +are strictly smaller than `q`. -/ +theorem partrecCodePayloads_lt_of_tag_six (q : ℕ) (hq : partrecCodeTag q = 6) : + partrecCodePayload₁ q < q ∧ partrecCodePayload₂ q < q := + by + have hindex := partrecCode_eq_canonicalPartrecPrecIndex_of_tag_six q hq + have hbase := + canonicalPartrecPrecIndex_base_lt (partrecCodePayload₁ q) (partrecCodePayload₂ q) + have hstep := + canonicalPartrecPrecIndex_step_lt (partrecCodePayload₁ q) (partrecCodePayload₂ q) + rw [← hindex] at hbase hstep + exact ⟨hbase, hstep⟩ + +/-! +### Evaluation in an arbitrary model -/ + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +open scoped FFL.FirstOrder.Arithmetic + +open Nat.ArithPart₁ + +/-- The payload of the canonical primitive-recursion index, read inside a model. -/ +theorem eval_codePartrecPayload_canonicalPartrecPrecIndex {M : Type*} [ORingStructure M] + [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (fCode gCode : ℕ) (v : Fin r → M) + (hd : Semiformula.Evalb ((canonicalPartrecPrecIndex fCode gCode : M) :> v) (code d)) : + Semiformula.Evalb (((Nat.pair fCode gCode : ℕ) : M) :> v) (code (codePartrecPayload d)) := + by + have hrr := + eval_codeSub_natCast d (codeConst 4) (canonicalPartrecPrecIndex fCode gCode) 4 v hd + (by simpa using eval_codeConst (M := M) 4 v) + have hq2 := eval_codeDiv2_natCast _ _ v (eval_codeDiv2_natCast _ _ v hrr) + have hval : + Nat.div2 (Nat.div2 (canonicalPartrecPrecIndex fCode gCode - 4)) = Nat.pair fCode gCode := + partrecCodePayload_canonicalPartrecPrecIndex fCode gCode + rw [hval] at hq2 + simpa only [codePartrecPayload] using hq2 + +/-- The constructor number of the canonical primitive-recursion index, read +inside a model: it is `6`, the number of primitive recursion. -/ +theorem eval_codePartrecTag_canonicalPartrecPrecIndex {M : Type*} [ORingStructure M] + [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (fCode gCode : ℕ) (v : Fin r → M) + (hd : Semiformula.Evalb ((canonicalPartrecPrecIndex fCode gCode : M) :> v) (code d)) : + Semiformula.Evalb ((6 : M) :> v) (code (codePartrecTag d)) := + by + set c := canonicalPartrecPrecIndex fCode gCode with hcdef + have hceq : c = 2 * (2 * Nat.pair fCode gCode) + 1 + 4 := + canonicalPartrecPrecIndex_eq fCode gCode + have hsub : c - 4 = 2 * (2 * Nat.pair fCode gCode) + 1 := by rw [hceq]; omega + have hnlt : ¬c < 4 := by rw [hceq]; omega + have hb1 : (c - 4) % 2 = 1 := by rw [hsub]; omega + have hd2 : Nat.div2 (c - 4) = 2 * Nat.pair fCode gCode := + by + rw [hsub] + simp only [Nat.div2_val] + omega + have hb0 : Nat.div2 (c - 4) % 2 = 0 := by rw [hd2]; omega + have h4 : Semiformula.Evalb (((4 : ℕ) : M) :> v) (code (codeConst (n := r) 4)) := + eval_codeConst 4 v + have h2 : Semiformula.Evalb (((2 : ℕ) : M) :> v) (code (codeConst (n := r) 2)) := + eval_codeConst 2 v + have hrr := eval_codeSub_natCast d (codeConst 4) c 4 v hd (by simpa using h4) + have hboddLow : + Semiformula.Evalb (((1 : ℕ) : M) :> v) (code (codeBodd (codeSub d (codeConst 4)))) := + by + have := eval_codeBodd_natCast _ (c - 4) v hrr + rwa [hb1] at this + have hboddHigh : + Semiformula.Evalb (((0 : ℕ) : M) :> v) + (code (codeBodd (codeDiv2 (codeSub d (codeConst 4))))) := + by + have := eval_codeBodd_natCast _ (Nat.div2 (c - 4)) v (eval_codeDiv2_natCast _ (c - 4) v hrr) + rwa [hb0] at this + have hmul : + Semiformula.Evalb ((((2 * 1 : ℕ)) : M) :> v) + (code (codeMul (codeConst 2) (codeBodd (codeSub d (codeConst 4))))) := + by + refine (eval_codeMul_iff _ _ _ _).mpr ⟨_, _, h2, hboddLow, ?_⟩ + push_cast + norm_num + have hadd1 : + Semiformula.Evalb ((((4 + 2 * 1 : ℕ)) : M) :> v) + (code + (codeAdd (codeConst 4) (codeMul (codeConst 2) (codeBodd (codeSub d (codeConst 4)))))) := + by + refine (eval_codeAdd_iff _ _ _ _).mpr ⟨_, _, h4, hmul, ?_⟩ + push_cast + norm_num + have hbig : + Semiformula.Evalb ((((4 + 2 * 1 + 0 : ℕ)) : M) :> v) + (code + (codeAdd + (codeAdd (codeConst 4) (codeMul (codeConst 2) (codeBodd (codeSub d (codeConst 4))))) + (codeBodd (codeDiv2 (codeSub d (codeConst 4)))))) := + by + refine (eval_codeAdd_iff _ _ _ _).mpr ⟨_, _, hadd1, hboddHigh, ?_⟩ + push_cast + norm_num + have hsix : (((4 + 2 * 1 + 0 : ℕ)) : M) = (6 : M) := by norm_num + rw [hsix] at hbig + have hlt0 : Semiformula.Evalb ((0 : M) :> v) (code (codeLt d (codeConst 4))) := + by + refine (eval_codeLt_iff _ _ _ _).mpr ⟨_, _, hd, by simpa using h4, Or.inr ⟨?_, rfl⟩⟩ + intro hc + have : c < 4 := by exact_mod_cast hc + exact hnlt this + simp only [codePartrecTag] + exact + eval_codeIfPos_of _ _ _ (0 : M) ((c : ℕ) : M) (6 : M) _ v hlt0 hd hbig (Or.inr ⟨rfl, rfl⟩) + +/-- The base subcode of the canonical primitive-recursion index, read inside a +model. -/ +theorem eval_codePartrecPayload₁_canonicalPartrecPrecIndex {M : Type*} [ORingStructure M] + [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (fCode gCode : ℕ) (v : Fin r → M) + (hd : Semiformula.Evalb ((canonicalPartrecPrecIndex fCode gCode : M) :> v) (code d)) : + Semiformula.Evalb (((fCode : ℕ) : M) :> v) (code (codePartrecPayload₁ d)) := by + simpa only [codePartrecPayload₁, Nat.unpair_pair] using + eval_codeUnpair₁_natCast (M := M) (codePartrecPayload d) (Nat.pair fCode gCode) v + (eval_codePartrecPayload_canonicalPartrecPrecIndex d fCode gCode v hd) + +/-- The step subcode of the canonical primitive-recursion index, read inside a +model. -/ +theorem eval_codePartrecPayload₂_canonicalPartrecPrecIndex {M : Type*} [ORingStructure M] + [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (fCode gCode : ℕ) (v : Fin r → M) + (hd : Semiformula.Evalb ((canonicalPartrecPrecIndex fCode gCode : M) :> v) (code d)) : + Semiformula.Evalb (((gCode : ℕ) : M) :> v) (code (codePartrecPayload₂ d)) := by + simpa only [codePartrecPayload₂, Nat.unpair_pair] using + eval_codeUnpair₂_natCast (M := M) (codePartrecPayload d) (Nat.pair fCode gCode) v + (eval_codePartrecPayload_canonicalPartrecPrecIndex d fCode gCode v hd) + +end PartialRecursive +end CategoricalRiceShapiro + +/-! +### Part B: success semantics of the primitive-recursion cell -/ + +namespace CategoricalRiceShapiro +namespace Evaluator + +open CategoricalRiceShapiro.ArithmeticCode + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +open scoped FFL.FirstOrder.Arithmetic + +open Nat.ArithPart₁ + +variable {M : Type*} [ORingStructure M] + +/-- The eager conditional has a value once its test and both branches have one. -/ +private theorem precProbe_ifPos_exists [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {n : ℕ} (df dg dh : Code n) + (v : Fin n → M) (hf : ∃ f : M, Semiformula.Evalb (f :> v) (code df)) + (hg : ∃ g : M, Semiformula.Evalb (g :> v) (code dg)) + (hh : ∃ h : M, Semiformula.Evalb (h :> v) (code dh)) : + ∃ z : M, Semiformula.Evalb (z :> v) (code (codeIfPos df dg dh)) := + by + obtain ⟨f, hf⟩ := hf + obtain ⟨g, hg⟩ := hg + obtain ⟨h, hh⟩ := hh + by_cases hpos : 0 < f + · exact ⟨g, eval_codeIfPos_of _ _ _ f g h g v hf hg hh (Or.inl ⟨hpos, rfl⟩)⟩ + · exact + ⟨h, + eval_codeIfPos_of _ _ _ f g h h v hf hg hh + (Or.inr ⟨le_antisymm (not_lt.mp hpos) (by simp), rfl⟩)⟩ + +/-- The primitive-recursion cell has a value: both arms of its eager +conditional are evaluated from the supplied code values. -/ +private theorem precProbe_cell_exists [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] {r : ℕ} + (dtable dk' dq dcf dcg dn : Code r) (table k' qv cf cg index : M) (v : Fin r → M) + (htable : Semiformula.Evalb (table :> v) (code dtable)) + (hk' : Semiformula.Evalb (k' :> v) (code dk')) (hq : Semiformula.Evalb (qv :> v) (code dq)) + (hcf : Semiformula.Evalb (cf :> v) (code dcf)) + (hcg : Semiformula.Evalb (cg :> v) (code dcg)) + (hn : Semiformula.Evalb (index :> v) (code dn)) : + ∃ z : M, + Semiformula.Evalb (z :> v) (code (codePrecEvaluatorCell dtable dk' dq dcf dcg dn)) := + by + have hz := eval_codeUnpair₁ dn index v hn + have ht := eval_codeUnpair₂ dn index v hn + have hy := eval_codeSub (codeUnpair₂ dn) (codeConst 1) _ _ v ht (eval_codeConst 1 v) + have hdk : Semiformula.Evalb ((k' + 1) :> v) (code (codeSucc dk')) := + (eval_codeSucc_iff _ _ _).mpr ⟨k', hk', rfl⟩ + have hzy := + eval_codePair (codeUnpair₁ dn) (codeSub (codeUnpair₂ dn) (codeConst 1)) _ _ v hz hy + refine precProbe_ifPos_exists _ _ _ v ⟨_, ht⟩ ?_ ?_ + · obtain ⟨o₁, ho₁⟩ := + eval_codeTableLookup_exists_of_values dtable dk' dq + (codePair (codeUnpair₁ dn) (codeSub (codeUnpair₂ dn) (codeConst 1))) table k' qv _ v + htable hk' hq hzy + refine eval_codeOptionBind_exists_of_value _ _ o₁ v ho₁ ?_ + have hL : + ∀ (X : Code r) (x : M), + Semiformula.Evalb (x :> v) (code X) → + Semiformula.Evalb (x :> (o₁ - 1) :> v) (code (codeLift X)) := + fun X x hx => (eval_codeLift_iff X x (o₁ - 1) v).mpr hx + have hinner := + eval_codePair (codeLift (codeSub (codeUnpair₂ dn) (codeConst 1))) (codeHead (n := r)) _ + (o₁ - 1) ((o₁ - 1) :> v) (hL _ _ hy) ((eval_codeHead_iff _ _).mpr rfl) + exact + eval_codeTableLookup_exists_of_values (codeLift dtable) (codeLift (codeSucc dk')) + (codeLift dcg) + (codePair (codeLift (codeUnpair₁ dn)) + (codePair (codeLift (codeSub (codeUnpair₂ dn) (codeConst 1))) (codeHead (n := r)))) + table (k' + 1) cg _ ((o₁ - 1) :> v) (hL _ _ htable) (hL _ _ hdk) (hL _ _ hcg) + (eval_codePair _ _ _ _ ((o₁ - 1) :> v) (hL _ _ hz) hinner) + · exact + eval_codeTableLookup_exists_of_values dtable (codeSucc dk') dcf (codeUnpair₁ dn) table + (k' + 1) cf _ v htable hdk hcf hz + +/-- **Zero recursion argument.** When the argument code `dn` evaluates to +`⟪z, 0⟫`, the primitive-recursion cell succeeds with output `y + 1` exactly when +the base lookup succeeds with output `y + 1`: the table at fuel `k' + 1`, the +base program `dcf`, and input `z`. -/ +theorem eval_codePrecEvaluatorCell_succ_iff_of_zero [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] {r : ℕ} + (dtable dk' dq dcf dcg dn : Code r) (table k' qv cf cg z y : M) (v : Fin r → M) + (htable : Semiformula.Evalb (table :> v) (code dtable)) + (hk' : Semiformula.Evalb (k' :> v) (code dk')) (hq : Semiformula.Evalb (qv :> v) (code dq)) + (hcf : Semiformula.Evalb (cf :> v) (code dcf)) + (hcg : Semiformula.Evalb (cg :> v) (code dcg)) + (hn : Semiformula.Evalb (FFL.FirstOrder.Arithmetic.pair z 0 :> v) (code dn)) : + Semiformula.Evalb ((y + 1) :> v) (code (codePrecEvaluatorCell dtable dk' dq dcf dcg dn)) ↔ + Semiformula.Evalb ((y + 1) :> v) + (code (codeTableLookup dtable (codeSucc dk') dcf (codeUnpair₁ dn))) := + by + have ht : Semiformula.Evalb ((0 : M) :> v) (code (codeUnpair₂ dn)) := + by + have h := eval_codeUnpair₂ dn _ v hn + rwa [FFL.FirstOrder.Arithmetic.pi₂_pair] at h + constructor + · intro hcell + simp only [codePrecEvaluatorCell] at hcell + obtain ⟨f, hf, hcase⟩ := eval_codeIfPos_cases _ _ _ _ v hcell + have hf0 : f = 0 := eval_unique hf ht + rcases hcase with ⟨hpos, -⟩ | ⟨-, hbase⟩ + · exact absurd hpos (by rw [hf0]; exact _root_.lt_irrefl 0) + · exact hbase + · intro hbase + obtain ⟨w, hw⟩ := + precProbe_cell_exists dtable dk' dq dcf dcg dn table k' qv cf cg _ v htable hk' hq hcf hcg + hn + have hw' := hw + simp only [codePrecEvaluatorCell] at hw' + obtain ⟨f, hf, hcase⟩ := eval_codeIfPos_cases _ _ _ _ v hw' + have hf0 : f = 0 := eval_unique hf ht + rcases hcase with ⟨hpos, -⟩ | ⟨-, hwbase⟩ + · exact absurd hpos (by rw [hf0]; exact _root_.lt_irrefl 0) + · have hwy : w = y + 1 := eval_unique hwbase hbase + rw [hwy] at hw + exact hw + +/-- **Successor recursion argument.** When the argument code `dn` evaluates to +`⟪z, a + 1⟫`, the primitive-recursion cell succeeds with output `y + 1` exactly +when, for one intermediate value `x`, the predecessor lookup of the same index +`dq` at fuel `k'` on `⟪z, a⟫` succeeds with output `x + 1`, and the step lookup +of `dcg` at fuel `k' + 1` on `⟪z, ⟪a, x⟫⟫` succeeds with output `y + 1`. -/ +theorem eval_codePrecEvaluatorCell_succ_iff_of_succ [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] {r : ℕ} + (dtable dk' dq dcf dcg dn : Code r) (table k' qv cf cg z a y : M) (v : Fin r → M) + (htable : Semiformula.Evalb (table :> v) (code dtable)) + (hk' : Semiformula.Evalb (k' :> v) (code dk')) (hq : Semiformula.Evalb (qv :> v) (code dq)) + (hcf : Semiformula.Evalb (cf :> v) (code dcf)) + (hcg : Semiformula.Evalb (cg :> v) (code dcg)) + (hn : Semiformula.Evalb (FFL.FirstOrder.Arithmetic.pair z (a + 1) :> v) (code dn)) : + Semiformula.Evalb ((y + 1) :> v) (code (codePrecEvaluatorCell dtable dk' dq dcf dcg dn)) ↔ + ∃ x : M, + Semiformula.Evalb ((x + 1) :> v) + (code + (codeTableLookup dtable dk' dq + (codePair (codeUnpair₁ dn) (codeSub (codeUnpair₂ dn) (codeConst 1))))) ∧ + Semiformula.Evalb ((y + 1) :> x :> v) + (code + (codeTableLookup (codeLift dtable) (codeLift (codeSucc dk')) (codeLift dcg) + (codePair (codeLift (codeUnpair₁ dn)) + (codePair (codeLift (codeSub (codeUnpair₂ dn) (codeConst 1))) + (codeHead (n := r)))))) := + by + have ht : Semiformula.Evalb ((a + 1) :> v) (code (codeUnpair₂ dn)) := + by + have h := eval_codeUnpair₂ dn _ v hn + rwa [FFL.FirstOrder.Arithmetic.pi₂_pair] at h + have hnz : ¬(a + 1 = (0 : M)) := ne_of_gt (lt_of_lt_of_le _root_.zero_lt_one le_add_self) + constructor + · intro hcell + simp only [codePrecEvaluatorCell] at hcell + obtain ⟨f, hf, hcase⟩ := eval_codeIfPos_cases _ _ _ _ v hcell + have hfa : f = a + 1 := eval_unique hf ht + rcases hcase with ⟨-, hstep⟩ | ⟨hf0, -⟩ + · exact (eval_codeOptionBind_succ_iff _ _ y v).mp hstep + · exact absurd (by rw [← hfa]; exact hf0) hnz + · intro hx + have hstep := (eval_codeOptionBind_succ_iff _ _ y v).mpr hx + obtain ⟨w, hw⟩ := + precProbe_cell_exists dtable dk' dq dcf dcg dn table k' qv cf cg _ v htable hk' hq hcf hcg + hn + have hw' := hw + simp only [codePrecEvaluatorCell] at hw' + obtain ⟨f, hf, hcase⟩ := eval_codeIfPos_cases _ _ _ _ v hw' + have hfa : f = a + 1 := eval_unique hf ht + rcases hcase with ⟨-, hwstep⟩ | ⟨hf0, -⟩ + · have hwy : w = y + 1 := eval_unique hwstep hstep + rw [hwy] at hw + exact hw + · exact absurd (by rw [← hfa]; exact hf0) hnz + +/-! +### The same-index lookup of the successor branch -/ + +-- The history code contains the whole evaluator-cell code. + +/-- **The same-index lookup of the primitive-recursion successor branch.** With +the input `pair z (a + 1)`, the predecessor lookup of +`eval_codePrecEvaluatorCell_succ_iff_of_succ`, at the dispatcher's decremented +stage and program index and at the input `pair z a`, succeeds with output +`x + 1` exactly when `codeHistoryEvaluator` succeeds at `x + 1, k, q, pair z a`. -/ +theorem eval_prec_predecessor_lookup_succ_iff_codeHistoryEvaluator [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] + [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (k z a x : M) (q : ℕ) : + Semiformula.Evalb + ((x + 1) :> ![k + 1, ((q : ℕ) : M), FFL.FirstOrder.Arithmetic.pair z (a + 1)]) + (code + (codeTableLookup codeEvaluatorHistoryBeforeCell + (codeSub (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell)) + (codeConst 1)) + (codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell)) + (codePair (codeUnpair₁ (Code.proj (2 : Fin 3))) + (codeSub (codeUnpair₂ (Code.proj (2 : Fin 3))) (codeConst 1))))) ↔ + Semiformula.Evalb ![x + 1, k, ((q : ℕ) : M), FFL.FirstOrder.Arithmetic.pair z a] + (code codeHistoryEvaluator) := + by + let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + have hproj : + Semiformula.Evalb + (FFL.FirstOrder.Arithmetic.pair z (a + 1) :> + ![k + 1, ((q : ℕ) : M), FFL.FirstOrder.Arithmetic.pair z (a + 1)]) + (code (Code.proj (2 : Fin 3))) := + (eval_proj_iff _ _ _).mpr rfl + have h1 := eval_codeUnpair₁ (Code.proj (2 : Fin 3)) _ _ hproj + rw [FFL.FirstOrder.Arithmetic.pi₁_pair] at h1 + have h2 := eval_codeUnpair₂ (Code.proj (2 : Fin 3)) _ _ hproj + rw [FFL.FirstOrder.Arithmetic.pi₂_pair] at h2 + have hone : + Semiformula.Evalb + ((1 : M) :> ![k + 1, ((q : ℕ) : M), FFL.FirstOrder.Arithmetic.pair z (a + 1)]) + (code (codeConst (n := 3) 1)) := + by rw [eval_codeConst_iff]; simp + have h3 := eval_codeSub _ (codeConst 1) (a + 1) 1 _ h2 hone + rw [add_sub_self] at h3 + exact + eval_predecessor_lookup_succ_iff_codeHistoryEvaluator k _ _ x q _ + (eval_codePair _ _ z a _ h1 h3) + +end Evaluator +end CategoricalRiceShapiro + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/TableLookup.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/TableLookup.lean new file mode 100644 index 000000000..132cb5fd9 --- /dev/null +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/TableLookup.lean @@ -0,0 +1,67 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.EncodedList +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.Pairing + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# The table-lookup code + +`codeTableLookup dtable dk dq dn` reads entry `dn` of the row of the encoded +table `dtable` indexed by the Cantor pair of `dk` and `dq`. + +A row is stored as an encoded `Option (List (Option ℕ))`, so the row read out +of the table is an encoded `Option (Option ℕ)`, and the two layers are +flattened by `codeOptionJoin`. Subtracting `1` before the second lookup +replaces an absent row by the empty row. + +The literal construction matters: later results reason about this code itself, +not only about the function it realizes over the natural numbers, so it must not +be replaced by an extensionally equivalent one. +-/ + +@[expose] public section + +open _root_.Nat Nat Nat.ArithPart₁ + +namespace CategoricalRiceShapiro +namespace Evaluator + +open CategoricalRiceShapiro.ArithmeticCode + +/-- Flatten an encoded `Option (Option ℕ)` to an encoded `Option ℕ`. -/ +def codeOptionJoin {r : ℕ} (d : Code r) : Code r := + codeSub d (codeConst 1) + +/-- Entry `dn` of the row of `dtable` indexed by the pair of `dk` and `dq`. -/ +def codeTableLookup {r : ℕ} (dtable dk dq dn : Code r) : Code r := + codeOptionJoin + (codeListGetOptional (codeSub (codeListGetOptional dtable (codePair dk dq)) (codeConst 1)) + dn) + +/-- The table-lookup code written out without the private flattening helper. -/ +theorem codeTableLookup_eq {r : ℕ} (dtable dk dq dn : Code r) : + codeTableLookup dtable dk dq dn = + codeSub + (codeListGetOptional + (codeSub (codeListGetOptional dtable (codePair dk dq)) (codeConst 1)) dn) + (codeConst 1) := + rfl + +end Evaluator +end CategoricalRiceShapiro + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/TableLookupEvaluation.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/TableLookupEvaluation.lean new file mode 100644 index 000000000..7f6f86e17 --- /dev/null +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/TableLookupEvaluation.lean @@ -0,0 +1,128 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.TableLookup +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.EvaluationCongruence +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.EncodedListEvaluation + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# Evaluation of the table-lookup code + +This module states two results with different assumptions and different content. + +`eval_codeTableLookup_query_congr` assumes no more than `ORingStructure M`. The +query argument of `codeTableLookup` occurs only inside the Cantor pair that +indexes the table, and every constructor between that occurrence and the whole +code has a valuation-local congruence law. Composing those laws replaces the +query by an equivalent one. That statement is local in every respect: one +assignment `v`, one changed argument, and an equivalence quantified only over +the possible query values. The three remaining arguments are never evaluated +there, and it computes no value of the lookup. + +`eval_codeTableLookup_exists_of_values` assumes `𝐏𝐀` and does produce a value: +from values for all four arguments it builds one for the whole lookup, through +the two encoded-list reads and the two subtractions of the option offset. It +asserts existence only. The value is not identified with a decoded table entry, +and no list semantics is attached to an arbitrary element of the model. +-/ + +@[expose] public section + +open _root_.Nat Nat Nat.ArithPart₁ + +namespace CategoricalRiceShapiro +namespace Evaluator + +open CategoricalRiceShapiro.ArithmeticCode + +open Encodable FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +open scoped FFL.FirstOrder.Arithmetic + +/-- Replacing the query code by one with the same graph at `v` does not change +the graph of the lookup at `v`. -/ +theorem eval_codeTableLookup_query_congr {M : Type*} [ORingStructure M] {r : ℕ} + (dtable dk dq dq' dn : Code r) (z : M) (v : Fin r → M) + (hquery : + ∀ x : M, Semiformula.Evalb (x :> v) (code dq) ↔ Semiformula.Evalb (x :> v) (code dq')) : + Semiformula.Evalb (z :> v) (code (codeTableLookup dtable dk dq dn)) ↔ + Semiformula.Evalb (z :> v) (code (codeTableLookup dtable dk dq' dn)) := + by + have hpair : + ∀ x : M, + Semiformula.Evalb (x :> v) (code (codePair dk dq)) ↔ + Semiformula.Evalb (x :> v) (code (codePair dk dq')) := + fun x => eval_codePair_congr dk dk dq dq' x v (fun _ => Iff.rfl) hquery + have hrow : + ∀ x : M, + Semiformula.Evalb (x :> v) (code (codeListGetOptional dtable (codePair dk dq))) ↔ + Semiformula.Evalb (x :> v) (code (codeListGetOptional dtable (codePair dk dq'))) := + fun x => eval_codeListGetOptional_congr dtable dtable _ _ x v (fun _ => Iff.rfl) hpair + have hrow' : + ∀ x : M, + Semiformula.Evalb (x :> v) + (code (codeSub (codeListGetOptional dtable (codePair dk dq)) (codeConst 1))) ↔ + Semiformula.Evalb (x :> v) + (code (codeSub (codeListGetOptional dtable (codePair dk dq')) (codeConst 1))) := + fun x => eval_codeSub_congr _ _ _ _ x v hrow (fun _ => Iff.rfl) + have hentry : + ∀ x : M, + Semiformula.Evalb (x :> v) + (code + (codeListGetOptional + (codeSub (codeListGetOptional dtable (codePair dk dq)) (codeConst 1)) dn)) ↔ + Semiformula.Evalb (x :> v) + (code + (codeListGetOptional + (codeSub (codeListGetOptional dtable (codePair dk dq')) (codeConst 1)) dn)) := + fun x => eval_codeListGetOptional_congr _ _ dn dn x v hrow' (fun _ => Iff.rfl) + rw [codeTableLookup_eq, codeTableLookup_eq] + exact eval_codeSub_congr _ _ _ _ z v hentry (fun _ => Iff.rfl) + +/-- The table lookup has a value at any values of its four arguments. + +The Cantor pair indexing the table is reached through the public cons +existence theorem: `codeListCons dk dq` is `codeSucc (codePair dk dq)`, so +eliminating `eval_codeSucc_iff` hands back an evaluation of the pair itself +without a separate pairing lemma. The two encoded-list reads then supply the +optional row and the optional entry, and `eval_codeSub` removes each option +offset. Only existence is asserted. -/ +theorem eval_codeTableLookup_exists_of_values {M : Type*} [ORingStructure M] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] + {r : ℕ} (dtable dk dq dn : Code r) (table key query index : M) (v : Fin r → M) + (htable : Semiformula.Evalb (table :> v) (code dtable)) + (hkey : Semiformula.Evalb (key :> v) (code dk)) + (hquery : Semiformula.Evalb (query :> v) (code dq)) + (hindex : Semiformula.Evalb (index :> v) (code dn)) : + ∃ z : M, Semiformula.Evalb (z :> v) (code (codeTableLookup dtable dk dq dn)) := + by + let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + obtain ⟨c, hc⟩ := eval_codeListCons_exists_of_values dk dq key query v hkey hquery + obtain ⟨p, hp, -⟩ := (eval_codeSucc_iff (codePair dk dq) c v).mp hc + obtain ⟨row, hrow⟩ := + eval_codeListGetOptional_exists_of_values dtable (codePair dk dq) table p v htable hp + have hone : Semiformula.Evalb ((1 : M) :> v) (code (codeConst (n := r) 1)) := by + rw [eval_codeConst_iff]; simp + obtain ⟨e, he⟩ := + eval_codeListGetOptional_exists_of_values _ dn (row - 1) index v + (eval_codeSub _ _ row 1 v hrow hone) hindex + refine ⟨e - 1, ?_⟩ + rw [codeTableLookup_eq] + exact eval_codeSub _ _ e 1 v he hone + +end Evaluator +end CategoricalRiceShapiro + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/PartialRecursive/CanonicalComposition.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/PartialRecursive/CanonicalComposition.lean new file mode 100644 index 000000000..be05ced29 --- /dev/null +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/PartialRecursive/CanonicalComposition.lean @@ -0,0 +1,227 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.NumeralEvaluation + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# The canonical index of a composed partial-recursive program + +`canonicalPartrecCompIndex f g` is the Mathlib index of `Nat.Partrec.Code.comp` +applied to the programs those two indices name. Its constructor number is `5` +and its two subcodes are the given indices, which the three theorems below +record. Each rests on the same closed form, + +`canonicalPartrecCompIndex f g = 2 * (2 * Nat.pair f g + 1) + 4`, + +proved once in `canonicalPartrecCompIndex_eq`. + +The evaluation results then read those numbers off inside an arbitrary model of +`𝐏𝐀⁻`: a code whose graph holds at the canonical index has, at the same +assignment, the graph of the constructor number at `5` and of the two subcodes +at `fCode` and `gCode`. +-/ + +@[expose] public section + +namespace CategoricalRiceShapiro +namespace PartialRecursive + +open Encodable Denumerable + +open CategoricalRiceShapiro.ArithmeticCode + +/-- The index of the composition of the programs named by `fCode` and `gCode`. -/ +def canonicalPartrecCompIndex (fCode gCode : ℕ) : ℕ := + Encodable.encode + (Nat.Partrec.Code.comp (Denumerable.ofNat Nat.Partrec.Code fCode) + (Denumerable.ofNat Nat.Partrec.Code gCode)) + +/-- The closed form of the canonical composition index. -/ +theorem canonicalPartrecCompIndex_eq (fCode gCode : ℕ) : + canonicalPartrecCompIndex fCode gCode = 2 * (2 * Nat.pair fCode gCode + 1) + 4 := + by + unfold canonicalPartrecCompIndex + rw [Nat.Partrec.Code.encodeCode_eq] + simp only [Nat.Partrec.Code.encodeCode] + simp only [← Nat.Partrec.Code.encodeCode_eq, Denumerable.encode_ofNat] + +/-- The outer subindex is below the canonical composition index. -/ +theorem canonicalPartrecCompIndex_outer_lt (fCode gCode : ℕ) : + fCode < canonicalPartrecCompIndex fCode gCode := + by + unfold canonicalPartrecCompIndex + simpa only [Denumerable.encode_ofNat] using + (Nat.Partrec.Code.encode_lt_comp (Denumerable.ofNat Nat.Partrec.Code fCode) + (Denumerable.ofNat Nat.Partrec.Code gCode)).1 + +/-- The inner subindex is below the canonical composition index. -/ +theorem canonicalPartrecCompIndex_inner_lt (fCode gCode : ℕ) : + gCode < canonicalPartrecCompIndex fCode gCode := + by + unfold canonicalPartrecCompIndex + simpa only [Denumerable.encode_ofNat] using + (Nat.Partrec.Code.encode_lt_comp (Denumerable.ofNat Nat.Partrec.Code fCode) + (Denumerable.ofNat Nat.Partrec.Code gCode)).2 + +/-- The payload of the canonical composition index is the pair of subindices. -/ +theorem partrecCodePayload_canonicalPartrecCompIndex (fCode gCode : ℕ) : + partrecCodePayload (canonicalPartrecCompIndex fCode gCode) = Nat.pair fCode gCode := + by + have hsub : canonicalPartrecCompIndex fCode gCode - 4 = 2 * (2 * Nat.pair fCode gCode + 1) := + by rw [canonicalPartrecCompIndex_eq]; omega + simp only [partrecCodePayload, hsub] + simp + +/-- The canonical composition index has constructor number `5`. -/ +theorem canonicalPartrecCompIndex_constructor_number (fCode gCode : ℕ) : + partrecCodeTag (canonicalPartrecCompIndex fCode gCode) = 5 := + by + have hlt : ¬(canonicalPartrecCompIndex fCode gCode < 4) := by + rw [canonicalPartrecCompIndex_eq]; omega + have hsub : canonicalPartrecCompIndex fCode gCode - 4 = 2 * (2 * Nat.pair fCode gCode + 1) := + by rw [canonicalPartrecCompIndex_eq]; omega + simp only [partrecCodeTag, ite_eq_right hlt, hsub] + simp + +/-- The first subcode of the canonical composition index is the outer one. -/ +theorem canonicalPartrecCompIndex_outer_index (fCode gCode : ℕ) : + partrecCodePayload₁ (canonicalPartrecCompIndex fCode gCode) = fCode := by + simp only [partrecCodePayload₁, partrecCodePayload_canonicalPartrecCompIndex, Nat.unpair_pair] + +/-- The second subcode of the canonical composition index is the inner one. -/ +theorem canonicalPartrecCompIndex_inner_index (fCode gCode : ℕ) : + partrecCodePayload₂ (canonicalPartrecCompIndex fCode gCode) = gCode := by + simp only [partrecCodePayload₂, partrecCodePayload_canonicalPartrecCompIndex, Nat.unpair_pair] + +/-! +### Evaluation in an arbitrary model -/ + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +open scoped FFL.FirstOrder.Arithmetic + +open Nat.ArithPart₁ + +/-- The payload of the canonical composition index, read inside a model. -/ +theorem eval_codePartrecPayload_canonicalPartrecCompIndex {M : Type*} [ORingStructure M] + [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (fCode gCode : ℕ) (v : Fin r → M) + (hd : Semiformula.Evalb ((canonicalPartrecCompIndex fCode gCode : M) :> v) (code d)) : + Semiformula.Evalb (((Nat.pair fCode gCode : ℕ) : M) :> v) (code (codePartrecPayload d)) := + by + have hrr := + eval_codeSub_natCast d (codeConst 4) (canonicalPartrecCompIndex fCode gCode) 4 v hd + (by simpa using eval_codeConst (M := M) 4 v) + have hq2 := eval_codeDiv2_natCast _ _ v (eval_codeDiv2_natCast _ _ v hrr) + have hval : + Nat.div2 (Nat.div2 (canonicalPartrecCompIndex fCode gCode - 4)) = Nat.pair fCode gCode := + partrecCodePayload_canonicalPartrecCompIndex fCode gCode + rw [hval] at hq2 + simpa only [codePartrecPayload] using hq2 + +/-- The constructor number of the canonical composition index, read inside a +model: it is `5`, the number of composition. -/ +theorem eval_codePartrecTag_canonicalPartrecCompIndex {M : Type*} [ORingStructure M] + [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (fCode gCode : ℕ) (v : Fin r → M) + (hd : Semiformula.Evalb ((canonicalPartrecCompIndex fCode gCode : M) :> v) (code d)) : + Semiformula.Evalb ((5 : M) :> v) (code (codePartrecTag d)) := + by + set c := canonicalPartrecCompIndex fCode gCode with hcdef + have hceq : c = 2 * (2 * Nat.pair fCode gCode + 1) + 4 := + canonicalPartrecCompIndex_eq fCode gCode + have hsub : c - 4 = 2 * (2 * Nat.pair fCode gCode + 1) := by rw [hceq]; omega + have hnlt : ¬c < 4 := by rw [hceq]; omega + have hb0 : (c - 4) % 2 = 0 := by rw [hsub]; omega + have hd2 : Nat.div2 (c - 4) = 2 * Nat.pair fCode gCode + 1 := + by + rw [hsub] + simp only [Nat.div2_val] + omega + have hb1 : Nat.div2 (c - 4) % 2 = 1 := by rw [hd2]; omega + have h4 : Semiformula.Evalb (((4 : ℕ) : M) :> v) (code (codeConst (n := r) 4)) := + eval_codeConst 4 v + have h2 : Semiformula.Evalb (((2 : ℕ) : M) :> v) (code (codeConst (n := r) 2)) := + eval_codeConst 2 v + have hrr := eval_codeSub_natCast d (codeConst 4) c 4 v hd (by simpa using h4) + have hbodd0 : + Semiformula.Evalb (((0 : ℕ) : M) :> v) (code (codeBodd (codeSub d (codeConst 4)))) := + by + have := eval_codeBodd_natCast _ (c - 4) v hrr + rwa [hb0] at this + have hbodd1 : + Semiformula.Evalb (((1 : ℕ) : M) :> v) + (code (codeBodd (codeDiv2 (codeSub d (codeConst 4))))) := + by + have := eval_codeBodd_natCast _ (Nat.div2 (c - 4)) v (eval_codeDiv2_natCast _ (c - 4) v hrr) + rwa [hb1] at this + have hmul : + Semiformula.Evalb ((((2 * 0 : ℕ)) : M) :> v) + (code (codeMul (codeConst 2) (codeBodd (codeSub d (codeConst 4))))) := + by + refine (eval_codeMul_iff _ _ _ _).mpr ⟨_, _, h2, hbodd0, ?_⟩ + push_cast + norm_num + have hadd1 : + Semiformula.Evalb ((((4 + 2 * 0 : ℕ)) : M) :> v) + (code + (codeAdd (codeConst 4) (codeMul (codeConst 2) (codeBodd (codeSub d (codeConst 4)))))) := + by + refine (eval_codeAdd_iff _ _ _ _).mpr ⟨_, _, h4, hmul, ?_⟩ + push_cast + norm_num + have hbig : + Semiformula.Evalb ((((4 + 2 * 0 + 1 : ℕ)) : M) :> v) + (code + (codeAdd + (codeAdd (codeConst 4) (codeMul (codeConst 2) (codeBodd (codeSub d (codeConst 4))))) + (codeBodd (codeDiv2 (codeSub d (codeConst 4)))))) := + by + refine (eval_codeAdd_iff _ _ _ _).mpr ⟨_, _, hadd1, hbodd1, ?_⟩ + push_cast + norm_num + have hfive : (((4 + 2 * 0 + 1 : ℕ)) : M) = (5 : M) := by norm_num + rw [hfive] at hbig + have hlt0 : Semiformula.Evalb ((0 : M) :> v) (code (codeLt d (codeConst 4))) := + by + refine (eval_codeLt_iff _ _ _ _).mpr ⟨_, _, hd, by simpa using h4, Or.inr ⟨?_, rfl⟩⟩ + intro hc + have : c < 4 := by exact_mod_cast hc + exact hnlt this + simp only [codePartrecTag] + exact + eval_codeIfPos_of _ _ _ (0 : M) ((c : ℕ) : M) (5 : M) _ v hlt0 hd hbig (Or.inr ⟨rfl, rfl⟩) + +/-- The outer subcode of the canonical composition index, read inside a model. -/ +theorem eval_codePartrecPayload₁_canonicalPartrecCompIndex {M : Type*} [ORingStructure M] + [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (fCode gCode : ℕ) (v : Fin r → M) + (hd : Semiformula.Evalb ((canonicalPartrecCompIndex fCode gCode : M) :> v) (code d)) : + Semiformula.Evalb (((fCode : ℕ) : M) :> v) (code (codePartrecPayload₁ d)) := by + simpa only [codePartrecPayload₁, Nat.unpair_pair] using + eval_codeUnpair₁_natCast (M := M) (codePartrecPayload d) (Nat.pair fCode gCode) v + (eval_codePartrecPayload_canonicalPartrecCompIndex d fCode gCode v hd) + +/-- The inner subcode of the canonical composition index, read inside a model. -/ +theorem eval_codePartrecPayload₂_canonicalPartrecCompIndex {M : Type*} [ORingStructure M] + [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (fCode gCode : ℕ) (v : Fin r → M) + (hd : Semiformula.Evalb ((canonicalPartrecCompIndex fCode gCode : M) :> v) (code d)) : + Semiformula.Evalb (((gCode : ℕ) : M) :> v) (code (codePartrecPayload₂ d)) := by + simpa only [codePartrecPayload₂, Nat.unpair_pair] using + eval_codeUnpair₂_natCast (M := M) (codePartrecPayload d) (Nat.pair fCode gCode) v + (eval_codePartrecPayload_canonicalPartrecCompIndex d fCode gCode v hd) + +end PartialRecursive +end CategoricalRiceShapiro + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/ArithmeticCodeCompiler.lean b/LeanPool/PointwiseComposition/FailureOfComposition/ArithmeticCodeCompiler.lean new file mode 100644 index 000000000..68d4ecc83 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/ArithmeticCodeCompiler.lean @@ -0,0 +1,290 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.ProgramGraph +public import LeanPool.PointwiseComposition.FailureOfComposition.ArithmeticProgramOperations +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteMinimizationGraph + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +Compilation of Foundation's finite-arity arithmetic codes to unary Mathlib +program descriptions, with arithmetic proofs for the encoded inputs. +-/ + +@[expose] public section + +open Encodable FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +namespace FailureOfComposition +namespace ArithmeticCodeCompiler + +open ProgramGraph + +/-- The ACode construction in `FailureOfComposition.ArithmeticCodeCompiler`. -/ +abbrev ACode := + Nat.ArithPart₁.Code + +/-- Nested pairs ending in zero encode a fixed finite input vector. -/ +noncomputable def encodeVector {M : Type*} [ORingStructure M] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] : + {n : ℕ} → (Fin n → M) → M + | 0, _ => 0 + | n + 1, v => pair (v 0) (encodeVector (fun i : Fin n => v i.succ)) + +/-- The projection Code construction in `FailureOfComposition.ArithmeticCodeCompiler`. -/ +def projectionCode : (n : ℕ) → Fin n → PCode + | 0, i => Fin.elim0 i + | n + 1, i => Fin.cases .left (fun j => .comp (projectionCode n j) .right) i + +/-- The tuple Code construction in `FailureOfComposition.ArithmeticCodeCompiler`. -/ +def tupleCode : (n : ℕ) → (Fin n → PCode) → PCode + | 0, _ => .zero + | n + 1, d => .pair (d 0) (tupleCode n (fun i => d i.succ)) + +/-- The swap Code construction in `FailureOfComposition.ArithmeticCodeCompiler`. -/ +def swapCode : PCode := + .pair .right .left + +/-- The search Zero Code construction in `FailureOfComposition.ArithmeticCodeCompiler`. -/ +def searchZeroCode (c : PCode) : PCode := + .comp (.rfind' (.comp c swapCode)) (.pair Nat.Partrec.Code.id .zero) + +/-- Structural compilation preserves the finite vector coding at every +constructor; minimization prepends its candidate to that vector. -/ +def compile : {n : ℕ} → ACode n → PCode + | _, .zero _ => .zero + | _, .one _ => Nat.Partrec.Code.const 1 + | n, .add i j => + .comp ConcreteEvaluator.addProgram (.pair (projectionCode n i) (projectionCode n j)) + | n, .mul i j => + .comp ConcreteEvaluator.mulProgram (.pair (projectionCode n i) (projectionCode n j)) + | n, .proj i => projectionCode n i + | n, .equal i j => + .comp ConcreteEvaluator.eqProgram (.pair (projectionCode n i) (projectionCode n j)) + | n, .lt i j => + .comp ConcreteEvaluator.ltProgram (.pair (projectionCode n i) (projectionCode n j)) + | _, @Nat.ArithPart₁.Code.comp _ n c d => + .comp (compile c) (tupleCode n (fun i => compile (d i))) + | _, .rfind c => searchZeroCode (compile c) + +/-- Unary programs accept the ordinary input directly. -/ +def unaryCompile (c : ACode 1) : PCode := + .comp (compile c) (.pair Nat.Partrec.Code.id .zero) + +variable {M : Type*} [ORingStructure M] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + +theorem computes_projection : + {n : ℕ} → + ∀ (i : Fin n) (v : Fin n → M) (y : M), + Computes (projectionCode n i) (encodeVector v) y ↔ y = v i + | 0, i, _, _ => Fin.elim0 i + | n + 1, i, v, y => by + refine Fin.cases ?_ (fun j => ?_) i + · simp only [projectionCode, Fin.cases_zero, encodeVector, computes_left, pi₁_pair] + · rw [projectionCode, Fin.cases_succ] + rw [computes_comp] + simp_rw [computes_right] + simp only [encodeVector, pi₂_pair, exists_eq_left] + exact computes_projection j (fun k => v k.succ) y + +theorem computes_tuple : + (n : ℕ) → + ∀ (d : Fin n → PCode) (x z : M), + Computes (tupleCode n d) x z ↔ + ∃ w : Fin n → M, z = encodeVector w ∧ ∀ i, Computes (d i) x (w i) + | 0, d, x, z => by + rw [tupleCode, computes_zero] + simp only [encodeVector] + constructor + · intro h + exact ⟨Fin.elim0, h, fun i => Fin.elim0 i⟩ + · rintro ⟨_, h, _⟩ + exact h + | n + 1, d, x, z => by + rw [tupleCode, computes_pair] + constructor + · rintro ⟨a, b, ha, hb, hz⟩ + obtain ⟨w, rfl, hw⟩ := (computes_tuple n (fun i => d i.succ) x b).mp hb + refine ⟨a :> w, ?_, ?_⟩ + · simpa only [encodeVector, Matrix.cons_val_zero, Matrix.cons_val_succ] using hz + · intro i + exact Fin.cases ha (fun j => hw j) i + · rintro ⟨w, rfl, hw⟩ + refine ⟨w 0, encodeVector (fun i : Fin n => w i.succ), hw 0, ?_, rfl⟩ + exact + (computes_tuple n (fun i => d i.succ) x _).mpr + ⟨(fun i => w i.succ), rfl, fun i => hw i.succ⟩ + +theorem computes_binary_application {n : ℕ} (p : PCode) (i j : Fin n) (v : Fin n → M) (y : M) : + Computes (.comp p (.pair (projectionCode n i) (projectionCode n j))) (encodeVector v) y ↔ + Computes p (pair (v i) (v j)) y := + by + rw [computes_comp] + constructor + · rintro ⟨u, hu, hp⟩ + obtain ⟨a, b, ha, hb, rfl⟩ := (computes_pair _ _ _ _).mp hu + rw [(computes_projection i v a).mp ha, (computes_projection j v b).mp hb] at hp + exact hp + · intro hp + refine ⟨pair (v i) (v j), ?_, hp⟩ + exact + (computes_pair _ _ _ _).mpr + ⟨v i, v j, (computes_projection i v _).mpr rfl, (computes_projection j v _).mpr rfl, + rfl⟩ + +theorem computes_swap (a b z : M) : Computes swapCode (pair a b) z ↔ z = pair b a := + by + rw [swapCode, computes_pair] + simp only [computes_right, computes_left, pi₁_pair, pi₂_pair] + constructor + · rintro ⟨a', b', rfl, rfl, h⟩ + exact h + · intro h + exact ⟨b, a, rfl, rfl, h⟩ + +theorem computes_candidate_swap (c : PCode) (a b z : M) : + Computes (.comp c swapCode) (pair a b) z ↔ Computes c (pair b a) z := + by + rw [computes_comp] + simp only [computes_swap, exists_eq_left] + +omit [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] in +private theorem arithmetic_eval_iff_aux {n : ℕ} (c : ACode n) (z : M) (v : Fin n → M) : + Semiformula.Evalb (z :> v) (FFL.FirstOrder.Arithmetic.code c) ↔ + Semiformula.Evalf (M := M) (z :> v) (FFL.FirstOrder.Arithmetic.codeAux c) := + by + simp [FFL.FirstOrder.Arithmetic.code, Semiformula.eval_rew, Matrix.empty_eq, + Function.comp_def] + +omit [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] in +private theorem arithmetic_rfind_eval {n : ℕ} (c : ACode (n + 1)) (z : M) (v : Fin n → M) : + Semiformula.Evalb (z :> v) (FFL.FirstOrder.Arithmetic.code (.rfind c)) ↔ + Semiformula.Evalb ((0 : M) :> z :> v) (FFL.FirstOrder.Arithmetic.code c) ∧ + ∀ t : M, + t < z → + ∃ w : M, + w ≠ 0 ∧ Semiformula.Evalb (w :> t :> v) (FFL.FirstOrder.Arithmetic.code c) := + by + simp only [arithmetic_eval_iff_aux] + simp [FFL.FirstOrder.Arithmetic.codeAux, Semiformula.eval_rew, Function.comp_def, + Matrix.empty_eq, Matrix.comp_vecCons'] + +theorem computes_pair_zero (x z : M) : + Computes (.pair Nat.Partrec.Code.id .zero) x z ↔ z = pair x 0 := + by + rw [computes_pair] + simp only [computes_id, computes_zero] + constructor + · rintro ⟨a, b, rfl, rfl, h⟩ + exact h + · intro h + exact ⟨x, 0, rfl, rfl, h⟩ + +theorem computes_searchZero (c : PCode) (x y : M) : + Computes (searchZeroCode c) x y ↔ + Computes c (pair y x) 0 ∧ ∀ k : M, k < y → ∃ z : M, z ≠ 0 ∧ Computes c (pair k x) z := + by + rw [searchZeroCode, computes_comp] + simp only [computes_pair_zero, exists_eq_left] + have h := ConcreteEvaluator.eventualGraph_rfind_code_eval (.comp c swapCode) x y + change + Computes (.rfind' (.comp c swapCode)) (pair x 0) y ↔ + Computes (.comp c swapCode) (pair x y) 0 ∧ + ∀ k : M, k < y → ∃ z : M, z ≠ 0 ∧ Computes (.comp c swapCode) (pair x k) z at h + simpa only [computes_candidate_swap] using h + +/-- The structural compiler preserves the graph in every PA model. All input +components and outputs may be nonstandard elements of that model. -/ +theorem computes_compile {n : ℕ} (c : ACode n) (v : Fin n → M) (y : M) : + Computes (compile c) (encodeVector v) y ↔ + Semiformula.Evalb (y :> v) (FFL.FirstOrder.Arithmetic.code c) := + by + induction c generalizing y with + | zero n => rw [compile, computes_zero, CategoricalRiceShapiro.ArithmeticCode.eval_zero_iff] + | one + n => + rw [compile, computes_const, CategoricalRiceShapiro.ArithmeticCode.eval_one_iff] + simp only [Nat.cast_one] + | add i j => + rw [compile, computes_binary_application, ConcreteEvaluator.computes_add_iff, + CategoricalRiceShapiro.ArithmeticCode.eval_add_iff] + | mul i j => + rw [compile, computes_binary_application, ConcreteEvaluator.computes_mul_iff, + CategoricalRiceShapiro.ArithmeticCode.eval_mul_iff] + | proj i => + rw [compile, computes_projection, CategoricalRiceShapiro.ArithmeticCode.eval_proj_iff] + | equal i j => + rw [compile, computes_binary_application, ConcreteEvaluator.computes_eq_iff, + CategoricalRiceShapiro.ArithmeticCode.eval_equal_iff] + | lt i j => + rw [compile, computes_binary_application, ConcreteEvaluator.computes_lt_iff, + CategoricalRiceShapiro.ArithmeticCode.eval_lt_iff] + | comp c d ihc + ihd => + rw [compile, computes_comp, CategoricalRiceShapiro.ArithmeticCode.eval_comp_iff] + constructor + · rintro ⟨u, hu, hc⟩ + obtain ⟨w, rfl, hw⟩ := (computes_tuple _ _ _ _).mp hu + exact ⟨w, (ihc w y).mp hc, fun i => (ihd i v (w i)).mp (hw i)⟩ + · rintro ⟨w, hc, hd⟩ + refine ⟨encodeVector w, ?_, (ihc w y).mpr hc⟩ + exact (computes_tuple _ _ _ _).mpr ⟨w, rfl, fun i => (ihd i v (w i)).mpr (hd i)⟩ + | rfind c ih => + rw [compile, computes_searchZero, arithmetic_rfind_eval] + have hi (k z : M) := ih (k :> v) z + simp only [encodeVector, Matrix.cons_val_zero, Matrix.cons_val_succ] at hi + exact + and_congr (hi y 0) + (forall_congr' fun k => + imp_congr_right fun _ => exists_congr fun z => and_congr_right fun _ => hi k z) + +/-- Unary compilation realizes the source arithmetic graph on the ordinary +input, without exposing the tuple representation. -/ +theorem computes_unaryCompile (c : ACode 1) (x y : M) : + Computes (unaryCompile c) x y ↔ + Semiformula.Evalb ![y, x] (FFL.FirstOrder.Arithmetic.code c) := + by + rw [unaryCompile, computes_comp] + simp only [computes_pair_zero, exists_eq_left] + have h := computes_compile c ![x] y + simpa only [encodeVector, Matrix.cons_val_zero] using h + +/-- The source arithmetic-code graph, in input-output argument order. -/ +def sourceGraph (c : ACode 1) : ProofSearch.Graph := + ((.mkSigma (FFL.FirstOrder.Arithmetic.code c) (code_sigma_one c)) : Σ₁.Semisentence 2).rew + (Rew.subst ![(#1 : ArithmeticSemiterm Empty 2), #0]) + +omit [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] in +theorem sourceGraph_eval (c : ACode 1) (x y : M) : + (sourceGraph c).val.Evalb ![x, y] ↔ + Semiformula.Evalb ![y, x] (FFL.FirstOrder.Arithmetic.code c) := + by simp [sourceGraph] + +/-- PA proves the uniform realization equation for this explicit compiler. -/ +theorem unaryCompile_realizes (c : ACode 1) : + ProofSearch.Uniform 𝐏𝐀 (ConcreteEvaluator.eventualGraph (encode (unaryCompile c))) + (sourceGraph c) := + by + apply complete.{0} 𝐏𝐀 + intro V _ _ + have : V↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + rw [models_iff, ProofSearch.uniformSentence_eval] + intro x y + rw [sourceGraph_eval] + exact computes_unaryCompile c x y + +end ArithmeticCodeCompiler +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/ArithmeticFormulaAtoms.lean b/LeanPool/PointwiseComposition/FailureOfComposition/ArithmeticFormulaAtoms.lean new file mode 100644 index 000000000..949edebb6 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/ArithmeticFormulaAtoms.lean @@ -0,0 +1,189 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.NumeralEvaluation + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +Arithmetic terms and atomic formulas compiled to arithmetic programs. Evaluation +is proved in arbitrary arithmetic structures for terms and positive atoms, +and in arbitrary models of PA⁻ for their Boolean complements. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +open Nat.ArithPart₁ + +open CategoricalRiceShapiro.ArithmeticCode + +namespace FailureOfComposition +namespace ArithmeticFormulaAtoms + +/-- Compilation of arithmetic terms with no free variables. -/ +def termCode {n : ℕ} : ArithmeticSemiterm Empty n → Code n + | .bvar i => .proj i + | .fvar x => nomatch x + | .func .zero _ => .zero n + | .func .one _ => .one n + | .func .add ts => codeAdd (termCode (ts 0)) (termCode (ts 1)) + | .func .mul ts => codeMul (termCode (ts 0)) (termCode (ts 1)) + +variable {M : Type*} [ORingStructure M] + +/-- The compiled term returns exactly its semantic value. -/ +theorem termCode_eval {n : ℕ} (t : ArithmeticSemiterm Empty n) (y : M) (v : Fin n → M) : + Semiformula.Evalb (y :> v) (code (termCode t)) ↔ y = t.valb v := by + induction t generalizing y with + | bvar i => exact eval_proj_iff i y v + | fvar x => exact x.elim + | func f ts ih => + cases f with + | zero => + change Semiformula.Evalb (y :> v) (code (Code.zero n)) ↔ y = 0 + exact eval_zero_iff y v + | one => + change Semiformula.Evalb (y :> v) (code (Code.one n)) ↔ y = 1 + exact eval_one_iff y v + | + add => + change + Semiformula.Evalb (y :> v) (code (codeAdd (termCode (ts 0)) (termCode (ts 1)))) ↔ + y = (ts 0).valb v + (ts 1).valb v + simp [eval_codeAdd_iff, ih] + | + mul => + change + Semiformula.Evalb (y :> v) (code (codeMul (termCode (ts 0)) (termCode (ts 1)))) ↔ + y = (ts 0).valb v * (ts 1).valb v + simp [eval_codeMul_iff, ih] + +/-- Term programs terminate at every internal input tuple. -/ +theorem termCode_total {n : ℕ} (t : ArithmeticSemiterm Empty n) (v : Fin n → M) : + ∃ y : M, Semiformula.Evalb (y :> v) (code (termCode t)) := + ⟨t.valb v, (termCode_eval t _ v).mpr rfl⟩ + +/-- Boolean programs return 1 for truth and 0 for falsehood. -/ +def BoolValue (P : Prop) (y : M) : Prop := + (P ∧ y = 1) ∨ (¬P ∧ y = 0) + +/-- Boolean compilation of an equality or strict-order atom. -/ +def atomCode {n k : ℕ} : + (r : Language.ORing.Rel k) → (Fin k → ArithmeticSemiterm Empty n) → Code n + | .eq, ts => codeEq (termCode (ts 0)) (termCode (ts 1)) + | .lt, ts => codeLt (termCode (ts 0)) (termCode (ts 1)) + +/-- Boolean compilation of the negation of an arithmetic atom. -/ +def negAtomCode {n k : ℕ} (r : Language.ORing.Rel k) (ts : Fin k → ArithmeticSemiterm Empty n) : + Code n := + codeInv (atomCode r ts) + +/-- Positive atomic formulas have total Boolean programs with the exact +internal semantics of the original formula. -/ +theorem atomCode_eval {n k : ℕ} (r : Language.ORing.Rel k) + (ts : Fin k → ArithmeticSemiterm Empty n) (y : M) (v : Fin n → M) : + Semiformula.Evalb (y :> v) (code (atomCode r ts)) ↔ + BoolValue ((Semiformula.rel r ts).Evalb v) y := + by + cases r with + | + eq => + change + Semiformula.Evalb (y :> v) (code (codeEq (termCode (ts 0)) (termCode (ts 1)))) ↔ + BoolValue ((ts 0).valb v = (ts 1).valb v) y + simp [eval_codeEq_iff, termCode_eval, BoolValue] + | + lt => + change + Semiformula.Evalb (y :> v) (code (codeLt (termCode (ts 0)) (termCode (ts 1)))) ↔ + BoolValue ((ts 0).valb v < (ts 1).valb v) y + simp [eval_codeLt_iff, termCode_eval, BoolValue] + +/-- An exact Boolean specification always supplies a value. -/ +theorem bool_total {n : ℕ} (c : Code n) (v : Fin n → M) (P : Prop) + (hc : ∀ y : M, Semiformula.Evalb (y :> v) (code c) ↔ BoolValue P y) : + ∃ y : M, Semiformula.Evalb (y :> v) (code c) := by + classical + by_cases hp : P + · exact ⟨1, (hc 1).mpr (Or.inl ⟨hp, rfl⟩)⟩ + · exact ⟨0, (hc 0).mpr (Or.inr ⟨hp, rfl⟩)⟩ + +theorem atomCode_total {n k : ℕ} (r : Language.ORing.Rel k) + (ts : Fin k → ArithmeticSemiterm Empty n) (v : Fin n → M) : + ∃ y : M, Semiformula.Evalb (y :> v) (code (atomCode r ts)) := + bool_total _ v _ (fun y => atomCode_eval r ts y v) + +/-- Arithmetic inversion exchanges the two Boolean values. -/ +theorem bool_inverse_eval [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {n : ℕ} (c : Code n) (v : Fin n → M) (P : Prop) + (hc : ∀ y : M, Semiformula.Evalb (y :> v) (code c) ↔ BoolValue P y) (z : M) : + Semiformula.Evalb (z :> v) (code (codeInv c)) ↔ BoolValue (¬P) z := + by + rw [eval_codeInv_iff] + simp only [hc, BoolValue] + by_cases hp : P <;> simp [hp] + +/-- Negated atomic formulas have the exact complementary Boolean graph. -/ +theorem negAtomCode_eval [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {n k : ℕ} (r : Language.ORing.Rel k) + (ts : Fin k → ArithmeticSemiterm Empty n) (y : M) (v : Fin n → M) : + Semiformula.Evalb (y :> v) (code (negAtomCode r ts)) ↔ + BoolValue ((Semiformula.nrel r ts).Evalb v) y := + by + have h := + bool_inverse_eval (atomCode r ts) v ((Semiformula.rel r ts).Evalb v) + (fun z => atomCode_eval r ts z v) y + simpa [negAtomCode] using h + +theorem negAtomCode_total [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {n k : ℕ} (r : Language.ORing.Rel k) + (ts : Fin k → ArithmeticSemiterm Empty n) (v : Fin n → M) : + ∃ y : M, Semiformula.Evalb (y :> v) (code (negAtomCode r ts)) := + bool_total _ v _ (fun y => negAtomCode_eval r ts y v) + +/-- A Boolean graph returns 1 exactly when its proposition holds. -/ +@[simp] +theorem boolValue_one [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] (P : Prop) : BoolValue P (1 : M) ↔ P := by + simp [BoolValue] + +/-- A Boolean graph returns 0 exactly when its proposition fails. -/ +@[simp] +theorem boolValue_zero [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] (P : Prop) : BoolValue P (0 : M) ↔ ¬P := by + simp [BoolValue] + +theorem atomCode_one_iff [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {n k : ℕ} (r : Language.ORing.Rel k) + (ts : Fin k → ArithmeticSemiterm Empty n) (v : Fin n → M) : + Semiformula.Evalb ((1 : M) :> v) (code (atomCode r ts)) ↔ (Semiformula.rel r ts).Evalb v := + by rw [atomCode_eval, boolValue_one] + +theorem atomCode_zero_iff [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {n k : ℕ} (r : Language.ORing.Rel k) + (ts : Fin k → ArithmeticSemiterm Empty n) (v : Fin n → M) : + Semiformula.Evalb ((0 : M) :> v) (code (atomCode r ts)) ↔ ¬(Semiformula.rel r ts).Evalb v := + by rw [atomCode_eval, boolValue_zero] + +theorem negAtomCode_one_iff [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {n k : ℕ} (r : Language.ORing.Rel k) + (ts : Fin k → ArithmeticSemiterm Empty n) (v : Fin n → M) : + Semiformula.Evalb ((1 : M) :> v) (code (negAtomCode r ts)) ↔ + (Semiformula.nrel r ts).Evalb v := + by rw [negAtomCode_eval, boolValue_one] + +theorem negAtomCode_zero_iff [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {n k : ℕ} (r : Language.ORing.Rel k) + (ts : Fin k → ArithmeticSemiterm Empty n) (v : Fin n → M) : + Semiformula.Evalb ((0 : M) :> v) (code (negAtomCode r ts)) ↔ + ¬(Semiformula.nrel r ts).Evalb v := + by rw [negAtomCode_eval, boolValue_zero] + +end ArithmeticFormulaAtoms +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/ArithmeticProgramOperations.lean b/LeanPool/PointwiseComposition/FailureOfComposition/ArithmeticProgramOperations.lean new file mode 100644 index 000000000..3a0e52011 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/ArithmeticProgramOperations.lean @@ -0,0 +1,309 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.ProgramGraph +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteConstructorGraphs +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteRecursionGraph + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +Arithmetic correctness of the compiled program operations. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +open scoped FFL.FirstOrder.Arithmetic + +open CategoricalRiceShapiro.Evaluator + +open Encodable _root_.Nat.Partrec + +namespace FailureOfComposition +namespace ConcreteEvaluator + +/-- Mathlib program performing addition on the two components of its input. -/ +def addProgram : Code := + .prec Code.id (.comp .succ (.comp .right .right)) + +/-- Mathlib program performing multiplication on the two input components. -/ +def mulProgram : Code := + .prec .zero (.comp addProgram (.pair .left (.comp .right .right))) + +/-- Mathlib program for truncated predecessor. -/ +def predProgram : Code := + .comp (.prec .zero (.comp .left .right)) (.pair .zero Code.id) + +/-- Mathlib program for truncated subtraction of the input components. -/ +def subProgram : Code := + .prec Code.id (.comp predProgram (.comp .right .right)) + +/-- Mathlib program returning one at zero and zero at positive inputs. -/ +def isZeroProgram : Code := + .comp (.prec (Code.const 1) .zero) (.pair .zero Code.id) + +/-- Mathlib program deciding strict order of the input components. -/ +def ltProgram : Code := + .comp isZeroProgram (.comp subProgram (.pair (.comp .succ .left) .right)) + +/-- Mathlib program deciding equality of the input components. -/ +def eqProgram : Code := + .comp isZeroProgram + (.comp addProgram (.pair subProgram (.comp subProgram (.pair .right .left)))) + +open ProgramGraph + +variable {M : Type*} [ORingStructure M] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] + +/-- Full PA induction with arbitrary model parameters in its defining formula. -/ +theorem pa_formula_induction {P : M → Prop} (φ : ArithmeticSemiformula M 1) + (hφ : ∀ x, P x ↔ φ.Eval ![x] id) (hz : P 0) (hs : ∀ x, P x → P (x + 1)) : ∀ x, P x := by + classical + have := models_inductionScheme_univ (M := M) + have : Inhabited M := ⟨0⟩ + exact + InductionScheme.succ_induction (C := Set.univ) + (by + refine ⟨φ.enumerateFVar, Rew.rewriteMap φ.idxOfFVar ▹ φ, trivial, ?_⟩ + intro x + simp only [hφ, Nat.succ_eq_add_one, Nat.reduceAdd, Semiformula.eval_rewriteMap] + exact + Semiformula.eval_iff_of_funEqOn φ + (by + intro z hz + simp [Semiformula.enumerateFVar_idxOfFVar + (Semiformula.mem_fvarList_iff_hasFreeVariable.mpr hz)])) + hz hs + +variable [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + +@[simp] +theorem runs_pair (f g : Code) (x z : M) : + Computes (.pair f g) x z ↔ ∃ a b, Computes f x a ∧ Computes g x b ∧ z = pair a b := + eventualGraph_pair_code_eval f g x z + +attribute [local simp] computes_zero computes_succ computes_left computes_right computes_comp + computes_id computes_const + +@[simp] +theorem runs_prec_zero (f g : Code) (a y : M) : + Computes (.prec f g) (pair a 0) y ↔ Computes f a y := by + simpa only [Computes, ProgramGraph.Computes, + CategoricalRiceShapiro.PartialRecursive.canonicalPartrecPrecIndex, + Denumerable.ofNat_encode] using + eventualGraph_prec_zero_eval (M := M) (encode f) (encode g) a y + +@[simp] +theorem runs_prec_succ (f g : Code) (a b y : M) : + Computes (.prec f g) (pair a (b + 1)) y ↔ + ∃ z, Computes (.prec f g) (pair a b) z ∧ Computes g (pair a (pair b z)) y := + by + simpa only [Computes, ProgramGraph.Computes, + CategoricalRiceShapiro.PartialRecursive.canonicalPartrecPrecIndex, + Denumerable.ofNat_encode] using + eventualGraph_prec_succ_eval (M := M) (encode f) (encode g) a b y + +private theorem runs_add_induction (c : Code) (a : M) (hz : Computes c (pair a 0) a) + (hs : ∀ b, Computes c (pair a b) (a + b) → Computes c (pair a (b + 1)) (a + b + 1)) : + ∀ b, Computes c (pair a b) (a + b) := + by + let G : ArithmeticSemiformula M 2 := Rew.emb ▹ (eventualGraph (encode c)).val + let B : ArithmeticSemiformula M 3 := Rew.emb ▹ pairDef.val + refine + pa_formula_induction (P := fun b : M => Computes c (pair a b) (a + b)) + (“b. ∃ w, !B w&a b ∧ !G w(&a + b)”) ?_ ?_ ?_ + · intro b + simp [Computes, ProgramGraph.Computes, G, B, Semiformula.eval_emb, pair_defined.iff] + · simpa using hz + · intro b hb + simpa [add_assoc] using hs b hb + +theorem computes_add (a b : M) : Computes addProgram (pair a b) (a + b) := + by + apply runs_add_induction addProgram a + · simp only [addProgram, runs_prec_zero, computes_id] + · intro b hb + apply (runs_prec_succ _ _ _ _ _).mpr + refine ⟨a + b, hb, ?_⟩ + simp only [computes_comp, computes_succ, computes_right, pi₂_pair, exists_eq_left] + +@[simp] +theorem computes_add_iff (a b z : M) : Computes addProgram (pair a b) z ↔ z = a + b := + ⟨fun h => computes_unique _ _ _ _ h (computes_add a b), fun h => h ▸ computes_add a b⟩ + +theorem computes_mul (a b : M) : Computes mulProgram (pair a b) (a * b) := + by + let G : ArithmeticSemiformula M 2 := Rew.emb ▹ (eventualGraph (encode mulProgram)).val + let B : ArithmeticSemiformula M 3 := Rew.emb ▹ pairDef.val + have h : ∀ b : M, Computes mulProgram (pair a b) (a * b) := + by + refine + pa_formula_induction (P := fun b : M => Computes mulProgram (pair a b) (a * b)) + (“b. ∃ w, !B w&a b ∧ !G w(&a * b)”) ?_ ?_ ?_ + · intro b + simp [Computes, ProgramGraph.Computes, G, B, Semiformula.eval_emb, pair_defined.iff] + · simp only [mulProgram, runs_prec_zero, computes_zero, mul_zero] + · intro b hb + apply (runs_prec_succ _ _ _ _ _).mpr + refine ⟨a * b, hb, ?_⟩ + simp only [computes_comp, computes_pair, computes_left, computes_right, pi₁_pair, + pi₂_pair, exists_eq_left] + simp [mul_add, add_comm] + exact h b + +@[simp] +theorem computes_mul_iff (a b z : M) : Computes mulProgram (pair a b) z ↔ z = a * b := + ⟨fun h => computes_unique _ _ _ _ h (computes_mul a b), fun h => h ▸ computes_mul a b⟩ + +private theorem computes_pred_rec (b : M) : + Computes (.prec .zero (.comp .left .right)) (pair 0 b) (b - 1) := + by + let c : Code := .prec .zero (.comp .left .right) + let G : ArithmeticSemiformula M 2 := Rew.emb ▹ (eventualGraph (encode c)).val + let B : ArithmeticSemiformula M 3 := Rew.emb ▹ pairDef.val + let S : ArithmeticSemiformula M 3 := Rew.emb ▹ subDef.val + have h : ∀ b : M, Computes c (pair 0 b) (b - 1) := + by + refine + pa_formula_induction (P := fun b : M => Computes c (pair 0 b) (b - 1)) + (“b. ∃ w z, !B w 0 b ∧ !S z b 1 ∧ !G w z”) ?_ ?_ ?_ + · intro b + simp [Computes, ProgramGraph.Computes, G, B, S, Semiformula.eval_emb, pair_defined.iff, + sub_defined.iff] + · simp only [c, runs_prec_zero, computes_zero, Arithmetic.zero_sub] + · intro b hb + apply (runs_prec_succ _ _ _ _ _).mpr + refine ⟨b - 1, hb, ?_⟩ + simp only [computes_comp, computes_left, computes_right, pi₁_pair, pi₂_pair, + exists_eq_left, add_sub_self] + exact h b + +theorem computes_pred (b : M) : Computes predProgram b (b - 1) := + by + rw [predProgram, computes_comp] + refine ⟨pair 0 b, ?_, computes_pred_rec b⟩ + simp only [computes_pair, computes_zero, computes_id] + exact ⟨0, _, rfl, rfl, rfl⟩ + +@[simp] +theorem computes_pred_iff (b z : M) : Computes predProgram b z ↔ z = b - 1 := + ⟨fun h => computes_unique _ _ _ _ h (computes_pred b), fun h => h ▸ computes_pred b⟩ + +theorem computes_sub (a b : M) : Computes subProgram (pair a b) (a - b) := + by + let G : ArithmeticSemiformula M 2 := Rew.emb ▹ (eventualGraph (encode subProgram)).val + let B : ArithmeticSemiformula M 3 := Rew.emb ▹ pairDef.val + let S : ArithmeticSemiformula M 3 := Rew.emb ▹ subDef.val + have h : ∀ b : M, Computes subProgram (pair a b) (a - b) := + by + refine + pa_formula_induction (P := fun b : M => Computes subProgram (pair a b) (a - b)) + (“b. ∃ w z, !B w&a b ∧ !S z&a b ∧ !G w z”) ?_ ?_ ?_ + · intro b + simp [Computes, ProgramGraph.Computes, G, B, S, Semiformula.eval_emb, pair_defined.iff, + sub_defined.iff] + · simp only [subProgram, runs_prec_zero, computes_id, Arithmetic.sub_zero] + · intro b hb + apply (runs_prec_succ _ _ _ _ _).mpr + refine ⟨a - b, hb, ?_⟩ + simp only [computes_comp, computes_right, pi₂_pair, exists_eq_left, computes_pred_iff, + Arithmetic.sub_sub] + exact h b + +@[simp] +theorem computes_sub_iff (a b z : M) : Computes subProgram (pair a b) z ↔ z = a - b := + ⟨fun h => computes_unique _ _ _ _ h (computes_sub a b), fun h => h ▸ computes_sub a b⟩ + +private theorem computes_isZero_rec_total (b : M) : + ∃ z, Computes (.prec (Code.const 1) .zero) (pair 0 b) z := + by + let c : Code := .prec (Code.const 1) .zero + let G : ArithmeticSemiformula M 2 := Rew.emb ▹ (eventualGraph (encode c)).val + let B : ArithmeticSemiformula M 3 := Rew.emb ▹ pairDef.val + have h : ∀ b : M, ∃ z, Computes c (pair 0 b) z := + by + refine + pa_formula_induction (P := fun b : M => ∃ z, Computes c (pair 0 b) z) + (“b. ∃ z w, !B w 0 b ∧ !G w z”) ?_ ?_ ?_ + · intro b + simp [Computes, ProgramGraph.Computes, G, B, Semiformula.eval_emb, pair_defined.iff] + · exact ⟨1, by simp only [c, runs_prec_zero, computes_const, Nat.cast_one]⟩ + · intro b hb + obtain ⟨z, hz⟩ := hb + exact ⟨0, (runs_prec_succ _ _ _ _ _).mpr ⟨z, hz, (computes_zero _ _).mpr rfl⟩⟩ + exact h b + +theorem computes_isZero_zero : Computes isZeroProgram (0 : M) 1 := + by + rw [isZeroProgram, computes_comp] + refine ⟨pair 0 0, ?_, ?_⟩ + · simp only [computes_pair, computes_zero, computes_id] + exact ⟨0, _, rfl, rfl, rfl⟩ + · simp only [runs_prec_zero, computes_const, Nat.cast_one] + +theorem computes_isZero_succ (b : M) : Computes isZeroProgram (b + 1) 0 := + by + rw [isZeroProgram, computes_comp] + refine ⟨pair 0 (b + 1), ?_, ?_⟩ + · simp only [computes_pair, computes_zero, computes_id] + exact ⟨0, _, rfl, rfl, rfl⟩ + · obtain ⟨z, hz⟩ := computes_isZero_rec_total b + exact (runs_prec_succ _ _ _ _ _).mpr ⟨z, hz, (computes_zero _ _).mpr rfl⟩ + +@[simp] +theorem computes_isZero_iff (b z : M) : + Computes isZeroProgram b z ↔ (b = 0 ∧ z = 1) ∨ (b ≠ 0 ∧ z = 0) := + by + rcases zero_or_succ b with rfl | ⟨b, rfl⟩ + · simp only [true_and, ne_eq, not_true_eq_false, false_and, or_false] + exact + ⟨fun h => computes_unique _ _ _ _ h computes_isZero_zero, fun h => + h ▸ computes_isZero_zero⟩ + · have hn : b + 1 ≠ 0 := ne_of_gt (lt_of_le_of_lt (Arithmetic.zero_le b) (lt_add_one b)) + simp only [ne_eq, hn, false_and, not_false_eq_true, true_and, false_or] + exact + ⟨fun h => computes_unique _ _ _ _ h (computes_isZero_succ b), fun h => + h ▸ computes_isZero_succ b⟩ + +@[simp] +theorem computes_lt_iff (a b z : M) : + Computes ltProgram (pair a b) z ↔ (a < b ∧ z = 1) ∨ (¬a < b ∧ z = 0) := by + simp [ltProgram, computes_comp, computes_left, computes_right, computes_succ, pi₁_pair, + pi₂_pair, exists_eq_left, computes_sub_iff, computes_isZero_iff, sub_eq_zero_iff_le, + ← lt_iff_succ_le] + +@[simp] +theorem computes_eq_iff (a b z : M) : + Computes eqProgram (pair a b) z ↔ (a = b ∧ z = 1) ∨ (a ≠ b ∧ z = 0) := + by + have hz : (a - b) + (b - a) = 0 ↔ a = b := + by + constructor + · intro h + have h₁ : a - b = 0 := + le_antisymm (h ▸ (show a - b ≤ a - b + (b - a) from le_self_add)) (Arithmetic.zero_le _) + have h₂ : b - a = 0 := + le_antisymm (h ▸ (show b - a ≤ a - b + (b - a) from le_add_self)) (Arithmetic.zero_le _) + exact le_antisymm (sub_eq_zero_iff_le.mp h₁) (sub_eq_zero_iff_le.mp h₂) + · rintro rfl + simp + simp [eqProgram, computes_comp, computes_left, computes_right, pi₁_pair, pi₂_pair, + exists_eq_left, computes_sub_iff, computes_add_iff, computes_isZero_iff, hz] + +end ConcreteEvaluator +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/AxiomEnumeration.lean b/LeanPool/PointwiseComposition/FailureOfComposition/AxiomEnumeration.lean new file mode 100644 index 000000000..9982b0e27 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/AxiomEnumeration.lean @@ -0,0 +1,62 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.TheoryEnumerability +public import LeanPool.PointwiseComposition.FailureOfComposition.KleeneNormalForm + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +From a partial-recursive axiom enumerator in Mathlib's fixed program numbering +to enumerability of theorem codes. The enumerator may diverge on inputs; its +range, rather than totality, specifies the axioms. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +namespace FailureOfComposition + +/-- The range of a numbered partial-recursive program is enumerable. -/ +theorem partial_program_range_re (a : ℕ) : REPred (fun n : ℕ => ∃ x : ℕ, n ∈ Kleene.eval a x) := + by + have hT : PrimrecPred (fun p : ℕ × (ℕ × ℕ) => Kleene.T₁ a p.2.1 p.2.2) := + Kleene.T₁_primrec.comp + (((Primrec.const a).pair (Primrec.fst.comp Primrec.snd)).pair + (Primrec.snd.comp Primrec.snd)) + have hU : PrimrecPred (fun p : ℕ × (ℕ × ℕ) => Kleene.U p.2.2 = p.1) := + Primrec.eq.comp (Kleene.U_primrec.comp (Primrec.snd.comp Primrec.snd)) Primrec.fst + have hr := + (PointwiseComposition.REPred.projection + ((PointwiseComposition.REPred.and hT.computablePred.to_re) hU.computablePred.to_re)) + apply REPred.of_eq hr + intro n + change (∃ p : ℕ × ℕ, Kleene.T₁ a p.1 p.2 ∧ Kleene.U p.2 = n) ↔ _ + simp only [Prod.exists] + exact exists_congr fun x => (Kleene.normal_form a x n).symm + +/-- The manuscript's partial recursive axiom enumeration makes AxiomCodes r.e. -/ +theorem axiom_codes_re_of_program_enumerator (T : ArithmeticTheory) (a : ℕ) + (ha : ∀ n : ℕ, AxiomCodes T n ↔ ∃ x : ℕ, n ∈ Kleene.eval a x) : REPred (AxiomCodes T) := + (partial_program_range_re a).of_eq (fun n => (ha n).symm) + +/-- An axiom enumerator suffices to enumerate the deductive closure. -/ +theorem theorem_codes_re_of_program_enumerator (T : ArithmeticTheory) (a : ℕ) + (ha : ∀ n : ℕ, AxiomCodes T n ↔ ∃ x : ℕ, n ∈ Kleene.eval a x) : REPred (TheoremCodes T) := + theorem_codes_re_of_axiom_codes T (axiom_codes_re_of_program_enumerator T a ha) + +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/BoundedSemidecision.lean b/LeanPool/PointwiseComposition/FailureOfComposition/BoundedSemidecision.lean new file mode 100644 index 000000000..0dd59734d --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/BoundedSemidecision.lean @@ -0,0 +1,156 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.ArithmeticProgramOperations +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteMinimizationGraph + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +Sequential bounded universal semidecision in arbitrary models of PA. +Each body call must return zero. A primitive-recursion program combines these +calls, and PA induction proves its graph equation also at nonstandard bounds. -/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +open scoped FFL.FirstOrder.Arithmetic + +open Encodable _root_.Nat.Partrec + +namespace FailureOfComposition +namespace BoundedSemidecision + +open ProgramGraph ConcreteEvaluator + +private theorem forall_lt_succ_iff {M : Type*} [ORingStructure M] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + (P : M → Prop) (b : M) : (∀ k : M, k < b + 1 → P k) ↔ (∀ k : M, k < b → P k) ∧ P b := + by + constructor + · intro h + exact ⟨fun k hk => h k (lt_trans hk (lt_add_one b)), h b (lt_add_one b)⟩ + · rintro ⟨h, hb⟩ k hk + rcases lt_or_eq_of_le (Arithmetic.lt_succ_iff_le.mp hk) with hlt | rfl + · exact h k hlt + · exact hb + +/-- Return zero precisely on input zero; diverge on every other input. -/ +def zeroOnlyProgram : Code := + .comp (.rfind' .left) (.pair Code.id .zero) + +/-- Run a program and accept precisely its zero output. -/ +def acceptZeroProgram (c : Code) : Code := + .comp zeroOnlyProgram c + +/-- The recursion step supplies `pair candidate environment` to the body. -/ +def boundedStepProgram (c : Code) : Code := + .comp (acceptZeroProgram c) (.pair (.comp .left .right) .left) + +/-- Check every candidate below the bound, with input `pair environment bound`. -/ +def boundedAllProgram (c : Code) : Code := + .prec .zero (boundedStepProgram c) + +variable {M : Type*} [ORingStructure M] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + +@[simp] +theorem computes_zeroOnly (x y : M) : Computes zeroOnlyProgram x y ↔ x = 0 ∧ y = 0 := + by + have hr := eventualGraph_rfind_code_eval (M := M) .left x y + change + Computes (.rfind' .left) (pair x 0) y ↔ + Computes .left (pair x y) 0 ∧ + ∀ k : M, k < y → ∃ z : M, z ≠ 0 ∧ Computes .left (pair x k) z at hr + simp only [computes_left, pi₁_pair] at hr + rw [zeroOnlyProgram, computes_comp] + simp only [computes_pair, computes_id, computes_zero] + simp only [exists_and_left, exists_eq_left] + rw [hr] + constructor + · rintro ⟨hx, hall⟩ + refine ⟨hx.symm, ?_⟩ + by_contra hy + have hpos : (0 : M) < y := lt_of_le_of_ne (Arithmetic.zero_le y) (Ne.symm hy) + obtain ⟨z, hz, rfl⟩ := hall 0 hpos + exact hz hx.symm + · rintro ⟨rfl, rfl⟩ + exact ⟨rfl, fun k hk => False.elim ((not_lt_of_ge (Arithmetic.zero_le k)) hk)⟩ + +@[simp] +theorem computes_acceptZero (c : Code) (x y : M) : + Computes (acceptZeroProgram c) x y ↔ y = 0 ∧ Computes c x 0 := + by + simp only [acceptZeroProgram, computes_comp, computes_zeroOnly] + constructor + · rintro ⟨z, hz, rfl, rfl⟩ + exact ⟨rfl, hz⟩ + · rintro ⟨rfl, h⟩ + exact ⟨0, h, rfl, rfl⟩ + +@[simp] +theorem computes_boundedStep (c : Code) (a k z y : M) : + Computes (boundedStepProgram c) (pair a (pair k z)) y ↔ y = 0 ∧ Computes c (pair k a) 0 := + by + simp only [boundedStepProgram, computes_comp, computes_pair, computes_left, computes_right, + pi₁_pair, pi₂_pair, exists_eq_left, computes_acceptZero] + simp only [exists_and_left, exists_eq_left] + +/-- The complete graph equation for bounded universal semidecision. No +termination or zero-output assumption on the body program is required. -/ +theorem computes_boundedAll (c : Code) (a b y : M) : + Computes (boundedAllProgram c) (pair a b) y ↔ + y = 0 ∧ ∀ k : M, k < b → Computes c (pair k a) 0 := + by + let F : ArithmeticSemiformula M 2 := + Rew.emb ▹ (eventualGraph (encode (boundedAllProgram c))).val + let G : ArithmeticSemiformula M 2 := Rew.emb ▹ (eventualGraph (encode c)).val + let B : ArithmeticSemiformula M 3 := Rew.emb ▹ pairDef.val + have h : + ∀ b : M, + ∀ y : M, + Computes (boundedAllProgram c) (pair a b) y ↔ + y = 0 ∧ ∀ k : M, k < b → Computes c (pair k a) 0 := + by + refine + pa_formula_induction (P := fun b : M => + ∀ y : M, + Computes (boundedAllProgram c) (pair a b) y ↔ + y = 0 ∧ ∀ k : M, k < b → Computes c (pair k a) 0) + (“b. ∀ y, (∃ w, !B w&a b ∧ !F w y) ↔ y = 0 ∧ ∀ k < b, ∃ w, !B w k&a ∧ !G w 0”) ?_ ?_ ?_ + · intro b + simp [ProgramGraph.Computes, F, G, B, Semiformula.eval_emb, pair_defined.iff] + · intro y + simp only [boundedAllProgram, runs_prec_zero, computes_zero] + exact + ⟨fun hy => ⟨hy, fun k hk => False.elim ((not_lt_of_ge (Arithmetic.zero_le k)) hk)⟩, + And.left⟩ + · intro b ih y + rw [boundedAllProgram, runs_prec_succ] + change + (∃ z, + Computes (boundedAllProgram c) (pair a b) z ∧ + Computes (boundedStepProgram c) (pair a (pair b z)) y) ↔ + _ + simp only [ih, computes_boundedStep, forall_lt_succ_iff] + constructor + · rintro ⟨z, ⟨rfl, hprev⟩, hy, hb⟩ + exact ⟨hy, hprev, hb⟩ + · rintro ⟨hy, hprev, hb⟩ + exact ⟨0, ⟨rfl, hprev⟩, hy, hb⟩ + exact h b y + +end BoundedSemidecision +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/CompositionClosure.lean b/LeanPool/PointwiseComposition/FailureOfComposition/CompositionClosure.lean new file mode 100644 index 000000000..e4dfb14b8 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/CompositionClosure.lean @@ -0,0 +1,111 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import Mathlib.Init + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +The least congruence containing a relation, defined as the intersection of +all equivalence relations compatible with the given binary operation. +No associativity, identity, or arithmetic hypothesis is required. +-/ + +@[expose] public section + +namespace FailureOfComposition +namespace CompositionClosure + +universe u v + +variable {A : Type u} + +/-- The Is Congruence construction in `FailureOfComposition.CompositionClosure`. -/ +def IsCongruence (op : A → A → A) (R : A → A → Prop) : Prop := + Equivalence R ∧ ∀ a a' b b', R a a' → R b b' → R (op a b) (op a' b') + +/-- The Generated construction in `FailureOfComposition.CompositionClosure`. -/ +def Generated (op : A → A → A) (r : A → A → Prop) (a b : A) : Prop := + ∀ R : A → A → Prop, IsCongruence op R → (∀ x y, r x y → R x y) → R a b + +theorem base (op : A → A → A) (r : A → A → Prop) {a b : A} (h : r a b) : Generated op r a b := + fun _ _ hr => hr a b h + +theorem refl (op : A → A → A) (r : A → A → Prop) (a : A) : Generated op r a a := fun _ hR _ => + hR.1.refl a + +theorem symm {op : A → A → A} {r : A → A → Prop} {a b : A} (h : Generated op r a b) : + Generated op r b a := fun R hR hr => hR.1.symm (h R hR hr) + +theorem trans {op : A → A → A} {r : A → A → Prop} {a b c : A} (hab : Generated op r a b) + (hbc : Generated op r b c) : Generated op r a c := fun R hR hr => + hR.1.trans (hab R hR hr) (hbc R hR hr) + +theorem comp {op : A → A → A} {r : A → A → Prop} {a a' b b' : A} (ha : Generated op r a a') + (hb : Generated op r b b') : Generated op r (op a b) (op a' b') := fun R hR hr => + hR.2 a a' b b' (ha R hR hr) (hb R hR hr) + +theorem comp_left (op : A → A → A) (r : A → A → Prop) (c : A) {a b : A} + (h : Generated op r a b) : Generated op r (op c a) (op c b) := + comp (refl op r c) h + +theorem comp_right (op : A → A → A) (r : A → A → Prop) (c : A) {a b : A} + (h : Generated op r a b) : Generated op r (op a c) (op b c) := + comp h (refl op r c) + +/-- Every congruence containing the generators contains the generated relation. -/ +theorem least {op : A → A → A} {r R : A → A → Prop} (hR : IsCongruence op R) + (hr : ∀ x y, r x y → R x y) {a b : A} (h : Generated op r a b) : R a b := + h R hR hr + +theorem isCongruence (op : A → A → A) (r : A → A → Prop) : IsCongruence op (Generated op r) := + ⟨⟨refl op r, fun h => symm h, fun h h' => trans h h'⟩, fun _ _ _ _ ha hb => comp ha hb⟩ + +/-- The setoid construction in `FailureOfComposition.CompositionClosure`. -/ +def setoid (op : A → A → A) (r : A → A → Prop) : Setoid A + where + r := Generated op r + iseqv := (isCongruence op r).1 + +theorem monotone {op : A → A → A} {r s : A → A → Prop} (hrs : ∀ x y, r x y → s x y) {a b : A} + (h : Generated op r a b) : Generated op s a b := fun R hR hs => + h R hR (fun x y hxy => hs x y (hrs x y hxy)) + +theorem iff_of_isCongruence {op : A → A → A} {r : A → A → Prop} (hr : IsCongruence op r) + (a b : A) : Generated op r a b ↔ r a b := + ⟨least hr (fun _ _ h => h), base op r⟩ + +theorem idempotent (op : A → A → A) (r : A → A → Prop) (a b : A) : + Generated op (Generated op r) a b ↔ Generated op r a b := + iff_of_isCongruence (isCongruence op r) a b + +/-- A homomorphism carrying generators into generators preserves their +generated congruences, even between different universes. -/ +theorem map {B : Type v} (opA : A → A → A) (opB : B → B → B) (r : A → A → Prop) + (s : B → B → Prop) (f : A → B) (hop : ∀ x y, f (opA x y) = opB (f x) (f y)) + (hrs : ∀ x y, r x y → s (f x) (f y)) {a b : A} (h : Generated opA r a b) : + Generated opB s (f a) (f b) := by + intro R hR hs + apply h (fun x y => R (f x) (f y)) + · constructor + · exact ⟨fun x => hR.1.refl (f x), fun h => hR.1.symm h, fun h h' => hR.1.trans h h'⟩ + · intro x x' y y' hxx' hyy' + rw [hop x y, hop x' y'] + exact hR.2 _ _ _ _ hxx' hyy' + · exact fun x y hxy => hs (f x) (f y) (hrs x y hxy) + +end CompositionClosure +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/ComputationSearchIndices.lean b/LeanPool/PointwiseComposition/FailureOfComposition/ComputationSearchIndices.lean new file mode 100644 index 000000000..2c3910e60 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/ComputationSearchIndices.lean @@ -0,0 +1,138 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.KleeneNormalForm + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +Concrete natural-number indices for the direct computation-search construction. +The graph equations proved here are standard-model equations. Their PA-provable +counterparts for the repository's arithmetized evaluator remain a separate task. +-/ + +@[expose] public section + +namespace FailureOfComposition +namespace Kleene + +open Encodable Denumerable _root_.Nat.Partrec + +/-- The index Of construction in `FailureOfComposition.Kleene`. -/ +noncomputable def indexOf (f : ℕ → Part ℕ) (hf : Partrec f) : ℕ := + encode (Classical.choose (Code.exists_code.mp (Partrec.nat_iff.mp hf))) + +theorem eval_indexOf (f : ℕ → Part ℕ) (hf : Partrec f) (x : ℕ) : eval (indexOf f hf) x = f x := + by + simp only [eval, indexOf, Denumerable.ofNat_encode] + exact congrFun (Classical.choose_spec (Code.exists_code.mp (Partrec.nat_iff.mp hf))) x + +/-- The guard Eval construction in `FailureOfComposition.Kleene`. -/ +def guardEval (d n : ℕ) : Part ℕ := + ((if T₁ d d n then none else some n) : Option ℕ) + +/-- The search Eval construction in `FailureOfComposition.Kleene`. -/ +def searchEval (d : ℕ) (_x : ℕ) : Part ℕ := + Nat.rfind (fun n => Part.some (decide (T₁ d d n))) + +theorem check_primrec (d : ℕ) : PrimrecPred (T₁ d d) := + T₁_primrec.comp ((Primrec.const (d, d)).pair Primrec.id) + +theorem guardEval_partrec (d : ℕ) : Partrec (guardEval d) := + (Primrec.ite (check_primrec d) (Primrec.const none) Primrec.option_some).to_comp.ofOption + +theorem searchEval_partrec (d : ℕ) : Partrec (searchEval d) := + Partrec.rfind (((check_primrec d).decide.to_comp.comp Computable.snd).to₂) + +/-- The guard Index construction in `FailureOfComposition.Kleene`. -/ +noncomputable def guardIndex (d : ℕ) : ℕ := + indexOf (guardEval d) (guardEval_partrec d) + +/-- The search Index construction in `FailureOfComposition.Kleene`. -/ +noncomputable def searchIndex (d : ℕ) : ℕ := + indexOf (searchEval d) (searchEval_partrec d) + +/-- The identity Index construction in `FailureOfComposition.Kleene`. -/ +def identityIndex : ℕ := + encode Code.id + +/-- The empty Index construction in `FailureOfComposition.Kleene`. -/ +noncomputable def emptyIndex : ℕ := + indexOf (fun _ => Part.none) Partrec.none + +@[simp] +theorem guardIndex_spec (d x y : ℕ) : y ∈ eval (guardIndex d) x ↔ ¬T₁ d d x ∧ y = x := + by + rw [guardIndex, eval_indexOf] + by_cases h : T₁ d d x <;> simp [guardEval, h, eq_comm] + +@[simp] +theorem searchIndex_spec (d x y : ℕ) : + y ∈ eval (searchIndex d) x ↔ T₁ d d y ∧ ∀ r < y, ¬T₁ d d r := + by + rw [searchIndex, eval_indexOf] + change y ∈ Nat.rfind (fun n ↦ Part.some (decide (T₁ d d n))) ↔ _ + constructor + · intro hy + have h := Nat.mem_rfind.mp hy + exact ⟨by simpa using h.1, fun r hr ↦ by simpa using h.2 hr⟩ + · rintro ⟨hy, hmin⟩ + apply Nat.mem_rfind.mpr + exact ⟨by simpa using hy, fun {r} hr ↦ by simpa using hmin r hr⟩ + +@[simp] +theorem identityIndex_spec (x : ℕ) : eval identityIndex x = Part.some x := by + simp [eval, identityIndex] + +@[simp] +theorem emptyIndex_spec (x : ℕ) : eval emptyIndex x = Part.none := + eval_indexOf _ _ x + +theorem guard_after_search (d x : ℕ) : + eval (compIndex (guardIndex d) (searchIndex d)) x = Part.none := + by + apply Part.ext + intro y + simp only [eval_compIndex, Part.mem_bind_iff, guardIndex_spec, searchIndex_spec, + Part.notMem_none, iff_false] + rintro ⟨z, ⟨hz, _⟩, hn, _⟩ + exact hn hz + +theorem identity_after_search (d x : ℕ) : + eval (compIndex identityIndex (searchIndex d)) x = eval (searchIndex d) x := + by + apply Part.ext + intro y + simp [eval_compIndex] + +theorem guard_eq_identity_of_divergence (d : ℕ) (hd : ¬FailureOfComposition.diagonalHalts d) + (x : ℕ) : eval (guardIndex d) x = eval identityIndex x := + by + apply Part.ext + intro y + have hn : ¬T₁ d d x := fun hx => hd ((diagonalHalts_iff d).mpr ⟨x, hx⟩) + simp [hn] + +theorem search_diverges_of_divergence (d : ℕ) (hd : ¬FailureOfComposition.diagonalHalts d) + (x : ℕ) : eval (searchIndex d) x = Part.none := + by + apply Part.ext + intro y + have hn : ¬T₁ d d y := fun hy => hd ((diagonalHalts_iff d).mpr ⟨y, hy⟩) + simp [hn] + +end Kleene +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteAdequacy.lean b/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteAdequacy.lean new file mode 100644 index 000000000..149cc8e6f --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteAdequacy.lean @@ -0,0 +1,248 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteConstructorGraphs +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteRecursionGraph +public import LeanPool.PointwiseComposition.FailureOfComposition.KleeneNormalForm + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +Standard-model adequacy of the concrete evaluator graph. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +open scoped FFL.FirstOrder.Arithmetic + +open Encodable Denumerable + +open CategoricalRiceShapiro.Evaluator CategoricalRiceShapiro.ArithmeticCode + +open CategoricalRiceShapiro.PartialRecursive + +open FailureOfComposition.ConcreteWitnessGraphs + +namespace FailureOfComposition +namespace ConcreteEvaluator + +/-- The accepted computation formula interpreted over the natural numbers. -/ +def stageComputation (s q x y : ℕ) : Prop := + Semiformula.Evalb ![s, q, x, y] (evalnCertificateFormula : ArithmeticSemisentence 4) + +private theorem nat_pi₁ (x : ℕ) : FFL.FirstOrder.Arithmetic.pi₁ x = x.unpair.1 := + by + have h : FFL.FirstOrder.Arithmetic.pair x.unpair.1 x.unpair.2 = x := by + rw [nat_pair_eq, Nat.pair_unpair] + rw [← h, FFL.FirstOrder.Arithmetic.pi₁_pair] + rw [h] + +private theorem nat_pi₂ (x : ℕ) : FFL.FirstOrder.Arithmetic.pi₂ x = x.unpair.2 := + by + have h : FFL.FirstOrder.Arithmetic.pair x.unpair.1 x.unpair.2 = x := by + rw [nat_pair_eq, Nat.pair_unpair] + rw [← h, FFL.FirstOrder.Arithmetic.pi₂_pair] + rw [h] + +private theorem rfind_tag (c : Nat.Partrec.Code) : + partrecCodeTag (encode (Nat.Partrec.Code.rfind' c)) = 7 := + by + have hb (n : ℕ) : n.bodd.toNat = n % 2 := by rw [Nat.mod_two_of_bodd] + simp only [Nat.Partrec.Code.encodeCode_eq, Nat.Partrec.Code.encodeCode] + have h : ¬2 * (2 * Nat.Partrec.Code.encodeCode c + 1) + 1 + 4 < 4 := by omega + simp only [partrecCodeTag, h, ite_false, hb, Nat.div2_val] + omega + +private theorem rfind_payload (c : Nat.Partrec.Code) : + partrecCodePayload (encode (Nat.Partrec.Code.rfind' c)) = encode c := + by + simp only [Nat.Partrec.Code.encodeCode_eq, Nat.Partrec.Code.encodeCode, partrecCodePayload, + Nat.div2_val] + omega + +private theorem stage_zero (q x y : ℕ) : ¬stageComputation 0 q x y := + by + intro h + have hh := (evalnCertificateFormula_eval_history_iff (0 : ℕ) q x y).mp h + have hx := ((eval_codeHistoryEvaluator_succ_iff_cell (0 : ℕ) q x y).mp hh).1 + exact Nat.not_lt_zero x hx + +private theorem stage_rfind_succ (c : Nat.Partrec.Code) (k x y : ℕ) : + stageComputation (k + 1) (encode (Nat.Partrec.Code.rfind' c)) x y ↔ + x ≤ k ∧ + ∃ v : ℕ, + stageComputation (k + 1) (encode c) x v ∧ + ((v ≠ 0 ∧ + stageComputation k (encode (Nat.Partrec.Code.rfind' c)) + (Nat.pair x.unpair.1 (x.unpair.2 + 1)) y) ∨ + (v = 0 ∧ y = x.unpair.2)) := + by + have h := + evalnCertificateFormula_tag_seven_iff (M := ℕ) (encode (Nat.Partrec.Code.rfind' c)) + (rfind_tag c) (k + 1) x y (by omega) + simp only [rfind_payload, natCast_nat, add_sub_self, nat_pi₁, nat_pi₂, nat_pair_eq, + Nat.lt_succ_iff, Nat.pos_iff_ne_zero] at h + exact h + +private theorem stage_base (q : ℕ) (hq : q < 4) (s x y : ℕ) : + stageComputation s q x y ↔ x < s ∧ y = baseOutput q x := + by + have h := base_computation_iff (M := ℕ) q hq s x y + simp only [natCast_nat] at h + exact h + +private theorem stage_pair (f g : Nat.Partrec.Code) (s x y : ℕ) : + stageComputation s (encode (Nat.Partrec.Code.pair f g)) x y ↔ + ∃ a b : ℕ, + stageComputation s (encode f) x a ∧ + stageComputation s (encode g) x b ∧ y = Nat.pair a b := + by + have h := evalnCertificateFormula_pair_iff (M := ℕ) f g s x y + simp only [natCast_nat, nat_pair_eq] at h + exact h + +private theorem stage_comp (f g : Nat.Partrec.Code) (s x y : ℕ) : + stageComputation s (encode (Nat.Partrec.Code.comp f g)) x y ↔ + ∃ a : ℕ, stageComputation s (encode g) x a ∧ stageComputation s (encode f) a y := + by + have h := + evalnCertificateFormula_canonicalPartrecCompIndex_iff (M := ℕ) s x y (encode f) (encode g) + simp only [numeral_eq_natCast_app, natCast_nat, canonicalPartrecCompIndex, + Denumerable.ofNat_encode] at h + exact h + +private theorem stage_prec_zero (f g : Nat.Partrec.Code) (k a y : ℕ) : + stageComputation (k + 1) (encode (Nat.Partrec.Code.prec f g)) (Nat.pair a 0) y ↔ + Nat.pair a 0 ≤ k ∧ stageComputation (k + 1) (encode f) a y := + by + have h := + evaln_tag_six_zero_iff (M := ℕ) (canonicalPartrecPrecIndex (encode f) (encode g)) + (canonicalPartrecPrecIndex_constructor_number _ _) (k + 1) a y (by omega) + simp only [canonicalPartrecPrecIndex_base_index, natCast_nat, nat_pair_eq, + Nat.lt_succ_iff] at h + simp only [canonicalPartrecPrecIndex, Denumerable.ofNat_encode] at h + exact h + +private theorem stage_prec_succ (f g : Nat.Partrec.Code) (k a b y : ℕ) : + stageComputation (k + 1) (encode (Nat.Partrec.Code.prec f g)) (Nat.pair a (b + 1)) y ↔ + Nat.pair a (b + 1) ≤ k ∧ + ∃ v : ℕ, + stageComputation k (encode (Nat.Partrec.Code.prec f g)) (Nat.pair a b) v ∧ + stageComputation (k + 1) (encode g) (Nat.pair a (Nat.pair b v)) y := + by + have h := + evaln_tag_six_succ_iff (M := ℕ) (canonicalPartrecPrecIndex (encode f) (encode g)) + (canonicalPartrecPrecIndex_constructor_number _ _) k a b y + simp only [canonicalPartrecPrecIndex_step_index, natCast_nat, nat_pair_eq, ] at h + simp only [canonicalPartrecPrecIndex, Denumerable.ofNat_encode] at h + exact h.trans (and_congr (by omega) Iff.rfl) + +/-- Exact finite-stage correspondence with Mathlib's evaluator. -/ +theorem stageComputation_iff_evaln (s : ℕ) (c : Nat.Partrec.Code) (x y : ℕ) : + stageComputation s (encode c) x y ↔ y ∈ Nat.Partrec.Code.evaln s c x := by + induction s generalizing c x y with + | zero => simp [stage_zero, Nat.Partrec.Code.evaln] + | succ k ih => + induction c generalizing x y with + | zero => + rw [show encode Nat.Partrec.Code.zero = 0 from rfl, stage_base 0 (by decide)] + simp [baseOutput, Nat.Partrec.Code.evaln, bind, Option.bind_eq_some_iff, + Option.guard_eq_some', Option.some.injEq] + omega + | succ => + rw [show encode Nat.Partrec.Code.succ = 1 from rfl, stage_base 1 (by decide)] + simp [baseOutput, Nat.Partrec.Code.evaln, bind, Option.bind_eq_some_iff, + Option.guard_eq_some', Option.some.injEq] + omega + | left => + rw [show encode Nat.Partrec.Code.left = 2 from rfl, stage_base 2 (by decide)] + simp [baseOutput, nat_pi₁, Nat.Partrec.Code.evaln, bind, Option.bind_eq_some_iff, + Option.guard_eq_some', Option.some.injEq] + omega + | + right => + rw [show encode Nat.Partrec.Code.right = 3 from rfl, stage_base 3 (by decide)] + simp [baseOutput, nat_pi₂, Nat.Partrec.Code.evaln, bind, Option.bind_eq_some_iff, + Option.guard_eq_some', Option.some.injEq] + omega + | pair f g hf hg => + rw [stage_pair] + simp only [hf, hg] + simp only [Nat.Partrec.Code.evaln, bind, Option.mem_def, Option.bind_eq_some_iff, + Option.guard_eq_some', exists_and_left, exists_const, Option.map_eq_some_iff, Seq.seq, + bind, Functor.map, Option.map_eq_some_iff] + constructor + · rintro ⟨a, ha, b, hb, hy⟩ + have hx : x ≤ k := Nat.le_of_lt_succ (Nat.Partrec.Code.evaln_bound ha) + exact ⟨hx, Nat.pair a, ⟨a, ha, rfl⟩, b, hb, hy.symm⟩ + · rintro ⟨_, _, ⟨a, ha, rfl⟩, b, hb, hy⟩ + exact ⟨a, ha, b, hb, hy.symm⟩ + | comp f g hf hg => + rw [stage_comp] + simp only [hf, hg] + simp only [Nat.Partrec.Code.evaln, bind, Option.mem_def, Option.bind_eq_some_iff, + Option.guard_eq_some', exists_and_left, exists_const] + constructor + · rintro ⟨a, ha, hy⟩ + exact ⟨Nat.le_of_lt_succ (Nat.Partrec.Code.evaln_bound ha), a, ha, hy⟩ + · rintro ⟨_, a, ha, hy⟩ + exact ⟨a, ha, hy⟩ + | prec f g hf + hg => + obtain ⟨a, b, rfl⟩ : ∃ a b, x = Nat.pair a b := + ⟨x.unpair.1, x.unpair.2, (Nat.pair_unpair x).symm⟩ + cases b with + | zero => + rw [stage_prec_zero] + simp [hf, Nat.Partrec.Code.evaln, Option.bind_eq_some_iff] + | succ b => + rw [stage_prec_succ] + simp [ih, hg, Nat.Partrec.Code.evaln, Option.bind_eq_some_iff] + | rfind' f hf => + rw [stage_rfind_succ] + simp only [hf, ih] + simp only [Nat.Partrec.Code.evaln, bind, Nat.unpaired, Nat.pair_unpair, Option.mem_def, + Option.bind_eq_some_iff, Option.guard_eq_some', exists_and_left, exists_const] + apply and_congr_right + intro _ + apply exists_congr + intro v + apply and_congr_right + intro _ + by_cases hv : v = 0 <;> simp [hv, eq_comm] + +/-- Standard-model adequacy of the PA-arithmetized graph for the actual Mathlib +program numbering. Every direction is proved for every program index. -/ +theorem eventualGraph_adequate (q x y : ℕ) : + (eventualGraph q).val.Evalb ![x, y] ↔ y ∈ Kleene.eval q x := + by + rw [eventualGraph_eval] + simp only [numeral_eq_natCast_app, natCast_nat, Matrix.cons_val_zero, Matrix.cons_val_one] + change (∃ s : ℕ, stageComputation s q x y) ↔ y ∈ Kleene.eval q x + have h := exists_congr fun s => stageComputation_iff_evaln s (ofNat Nat.Partrec.Code q) x y + rw [Denumerable.encode_ofNat] at h + exact h.trans Nat.Partrec.Code.evaln_complete.symm + +/-- The graph arithmetized in PA has precisely the existing Kleene `T₁,U` +normal form over the standard natural numbers. -/ +theorem eventualGraph_normal_form (q x y : ℕ) : + (eventualGraph q).val.Evalb ![x, y] ↔ ∃ w, Kleene.T₁ q x w ∧ Kleene.U w = y := + (eventualGraph_adequate q x y).trans (Kleene.normal_form q x y) + +end ConcreteEvaluator +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteConstructorGraphs.lean b/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteConstructorGraphs.lean new file mode 100644 index 000000000..e62c9a7b7 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteConstructorGraphs.lean @@ -0,0 +1,444 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteEvaluatorGraph + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +Constructor equations for the concrete evaluator over arbitrary models of PA. +The local decoder and forward pairing helpers are reproduced from production +PairPersistence; the new public results remove fuel and synchronize component +computations using unconditional persistence. +-/ + +@[expose] public section + +open _root_.Nat Nat Nat.ArithPart₁ + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +open scoped FFL.FirstOrder.Arithmetic + +open CategoricalRiceShapiro.ArithmeticCode CategoricalRiceShapiro.Evaluator + +open CategoricalRiceShapiro.PartialRecursive + +namespace FailureOfComposition +namespace ConcreteEvaluator + +variable {M : Type*} [ORingStructure M] + +/-! +### Decoder bridge and ranking, over `ℕ` -/ + +/-- Production's tag decoder, written with remainders. `bodd.toNat` and `% 2` +are related by `Nat.mod_two_of_bodd`, not assumed definitionally equal. -/ +private theorem tagFour_tag_remainders (q : ℕ) : + partrecCodeTag q = if q < 4 then q else 4 + 2 * ((q - 4) % 2) + Nat.div2 (q - 4) % 2 := + by + have hb : ∀ n : ℕ, n.bodd.toNat = n % 2 := fun n => by rw [Nat.mod_two_of_bodd] + simp only [partrecCodeTag, hb] + +/-- Both subcodes of a standard constructor-`4` index lie strictly below it. -/ +private theorem tagFour_payloads_lt (q : ℕ) (hq : partrecCodeTag q = 4) : + partrecCodePayload₁ q < q ∧ partrecCodePayload₂ q < q := + by + have h4 : 4 ≤ q := by + rcases Nat.lt_or_ge q 4 with hlt | hge + · rw [tagFour_tag_remainders, ite_eq_left hlt] at hq + omega + · exact hge + have hdd : partrecCodePayload q ≤ q - 4 := + by + simp only [partrecCodePayload, Nat.div2_val] + exact le_trans (Nat.div_le_self ((q - 4) / 2) 2) (Nat.div_le_self (q - 4) 2) + have h1 : partrecCodePayload₁ q ≤ partrecCodePayload q := + Nat.unpair_left_le (partrecCodePayload q) + have h2 : partrecCodePayload₂ q ≤ partrecCodePayload q := + Nat.unpair_right_le (partrecCodePayload q) + omega + +/-! +### Decoder readings inside a model -/ + +/-- The constructor number of a standard index, read inside a model. -/ +private theorem tagFour_read_tag [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) (v : Fin r → M) + (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : + Semiformula.Evalb (((partrecCodeTag q : ℕ) : M) :> v) (code (codePartrecTag d)) := + by + have h4 : Semiformula.Evalb (((4 : ℕ) : M) :> v) (code (codeConst (n := r) 4)) := + eval_codeConst 4 v + have h2 : Semiformula.Evalb (((2 : ℕ) : M) :> v) (code (codeConst (n := r) 2)) := + eval_codeConst 2 v + have hrr := eval_codeSub_natCast d (codeConst 4) q 4 v hd (by simpa using h4) + have hbodd0 := eval_codeBodd_natCast (codeSub d (codeConst 4)) (q - 4) v hrr + have hbodd1 := + eval_codeBodd_natCast (codeDiv2 (codeSub d (codeConst 4))) (Nat.div2 (q - 4)) v + (eval_codeDiv2_natCast _ (q - 4) v hrr) + have hmul : + Semiformula.Evalb ((((2 * ((q - 4) % 2) : ℕ)) : M) :> v) + (code (codeMul (codeConst 2) (codeBodd (codeSub d (codeConst 4))))) := + by + refine (eval_codeMul_iff _ _ _ v).mpr ⟨_, _, h2, hbodd0, ?_⟩ + push_cast + norm_num + have hadd1 : + Semiformula.Evalb ((((4 + 2 * ((q - 4) % 2) : ℕ)) : M) :> v) + (code + (codeAdd (codeConst 4) (codeMul (codeConst 2) (codeBodd (codeSub d (codeConst 4)))))) := + by + refine (eval_codeAdd_iff _ _ _ v).mpr ⟨_, _, h4, hmul, ?_⟩ + push_cast + norm_num + have hbig : + Semiformula.Evalb ((((4 + 2 * ((q - 4) % 2) + Nat.div2 (q - 4) % 2 : ℕ)) : M) :> v) + (code + (codeAdd + (codeAdd (codeConst 4) (codeMul (codeConst 2) (codeBodd (codeSub d (codeConst 4))))) + (codeBodd (codeDiv2 (codeSub d (codeConst 4)))))) := + by + refine (eval_codeAdd_iff _ _ _ v).mpr ⟨_, _, hadd1, hbodd1, ?_⟩ + push_cast + norm_num + rw [tagFour_tag_remainders] + simp only [codePartrecTag] + by_cases hq : q < 4 + · have hlt1 : Semiformula.Evalb ((1 : M) :> v) (code (codeLt d (codeConst 4))) := + by + refine (eval_codeLt_iff _ _ _ v).mpr ⟨_, _, hd, by simpa using h4, Or.inl ⟨?_, rfl⟩⟩ + exact_mod_cast hq + rw [ite_eq_left hq] + exact + eval_codeIfPos_of _ _ _ (1 : M) (((q : ℕ)) : M) _ _ v hlt1 hd hbig + (Or.inl ⟨_root_.zero_lt_one, rfl⟩) + · have hlt0 : Semiformula.Evalb ((0 : M) :> v) (code (codeLt d (codeConst 4))) := + by + refine (eval_codeLt_iff _ _ _ v).mpr ⟨_, _, hd, by simpa using h4, Or.inr ⟨?_, rfl⟩⟩ + intro hc + exact hq (by exact_mod_cast hc) + rw [ite_eq_right hq] + exact eval_codeIfPos_of _ _ _ (0 : M) (((q : ℕ)) : M) _ _ v hlt0 hd hbig (Or.inr ⟨rfl, rfl⟩) + +/-- The payload of a standard index, read inside a model. -/ +private theorem tagFour_read_payload [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) + (v : Fin r → M) (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : + Semiformula.Evalb (((partrecCodePayload q : ℕ) : M) :> v) (code (codePartrecPayload d)) := + by + have h4 : Semiformula.Evalb (((4 : ℕ) : M) :> v) (code (codeConst (n := r) 4)) := + eval_codeConst 4 v + have hrr := eval_codeSub_natCast d (codeConst 4) q 4 v hd (by simpa using h4) + simpa only [codePartrecPayload, partrecCodePayload] using + eval_codeDiv2_natCast _ _ v (eval_codeDiv2_natCast _ (q - 4) v hrr) + +/-- The first subcode of a standard index, read inside a model. -/ +private theorem tagFour_read_payload₁ [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) + (v : Fin r → M) (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : + Semiformula.Evalb (((partrecCodePayload₁ q : ℕ) : M) :> v) (code (codePartrecPayload₁ d)) := + eval_codeUnpair₁_natCast (codePartrecPayload d) _ v (tagFour_read_payload d q v hd) + +/-- The second subcode of a standard index, read inside a model. -/ +private theorem tagFour_read_payload₂ [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) + (v : Fin r → M) (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : + Semiformula.Evalb (((partrecCodePayload₂ q : ℕ) : M) :> v) (code (codePartrecPayload₂ d)) := + eval_codeUnpair₂_natCast (codePartrecPayload d) _ v (tagFour_read_payload d q v hd) + +/-! +### The pairing branch of the dispatcher -/ + +/-- A successful evaluator cell whose constructor number is `4` is the value of +its pairing branch. -/ +private theorem tagFour_pair_branch [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (dtable dn : Code r) + (v : Fin r → M) (z k tag : M) + (hk : Semiformula.Evalb (k :> v) (code (codeUnpair₁ (codeListLength dtable)))) + (hkpos : 0 < k) + (htag : + Semiformula.Evalb (tag :> v) + (code (codePartrecTag (codeUnpair₂ (codeListLength dtable))))) + (h4 : tag = ((4 : ℕ) : M)) + (hcell : Semiformula.Evalb (z :> v) (code (codeEvaluatorCell dtable dn))) : + Semiformula.Evalb (z :> v) + (code + (codePairEvaluatorCell dtable (codeUnpair₁ (codeListLength dtable)) + (codePartrecPayload₁ (codeUnpair₂ (codeListLength dtable))) + (codePartrecPayload₂ (codeUnpair₂ (codeListLength dtable))) dn)) := + by + have hval : + ∀ (m : ℕ) (x : M), + Semiformula.Evalb (x :> v) (code (codeConst (n := r) m)) → x = ((m : ℕ) : M) := + fun m x hx => eval_unique hx (eval_codeConst m v) + simp only [codeEvaluatorCell] at hcell + obtain ⟨f0, hf0, hc0⟩ := eval_codeIfPos_cases _ _ _ z v hcell + have hf0k : f0 = k := eval_unique hf0 hk + rcases hc0 with ⟨-, hbig⟩ | ⟨h0, -⟩ + swap + · exact absurd (hf0k ▸ h0 : k = 0) (ne_of_gt hkpos) + obtain ⟨e4, he4, hcase4⟩ := eval_codeIfPos_cases _ _ _ z v hbig + rw [eval_codeEq_iff] at he4 + obtain ⟨x, w, hx, hw, hxw⟩ := he4 + have hxt : x = tag := eval_unique hx htag + have hw4 : w = ((4 : ℕ) : M) := hval 4 w hw + have he41 : e4 = 1 := by + rcases hxw with ⟨-, h1⟩ | ⟨hne, -⟩ + · exact h1 + · exact absurd (by rw [hxt, hw4]; exact h4) hne + rcases hcase4 with ⟨-, hpair⟩ | ⟨h0, -⟩ + · exact hpair + · exact absurd (he41 ▸ h0 : (1 : M) = 0) _root_.one_ne_zero + +/-! +### Forward decomposition of a source tag-4 cell -/ + +/-- A successful source cell at a standard constructor-`4` index yields a +history success for each subcode at the same stage, and the Cantor pair of the +two outputs. -/ +private theorem tagFour_source_subcode_histories [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] (q : ℕ) (hq : partrecCodeTag q = 4) (s u y : M) (hs : 0 < s) + (hcell : + Semiformula.Evalb ((y + 1) :> ![s, ((q : ℕ) : M), u]) + (code (codeEvaluatorCell codeEvaluatorHistoryBeforeCell (Code.proj (2 : Fin 3))))) : + ∃ a b : M, + Semiformula.Evalb ![a + 1, s, ((partrecCodePayload₁ q : ℕ) : M), u] + (code codeHistoryEvaluator) ∧ + Semiformula.Evalb ![b + 1, s, ((partrecCodePayload₂ q : ℕ) : M), u] + (code codeHistoryEvaluator) ∧ + y = FFL.FirstOrder.Arithmetic.pair a b := + by + have hk := eval_codeEvaluatorCell_fuel s ((q : ℕ) : M) u + have hidx := eval_codeEvaluatorCell_index s ((q : ℕ) : M) u + have htag : + Semiformula.Evalb (((4 : ℕ) : M) :> ![s, ((q : ℕ) : M), u]) + (code (codePartrecTag (codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell)))) := + by + have h := tagFour_read_tag _ q ![s, ((q : ℕ) : M), u] hidx + rwa [hq] at h + have hbranch := + tagFour_pair_branch codeEvaluatorHistoryBeforeCell (Code.proj (2 : Fin 3)) + ![s, ((q : ℕ) : M), u] (y + 1) s (((4 : ℕ) : M)) hk hs htag rfl hcell + obtain ⟨a, b, hla, hlb, hy⟩ := + (eval_codePairEvaluatorCell_succ_iff codeEvaluatorHistoryBeforeCell + (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell)) + (codePartrecPayload₁ (codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell))) + (codePartrecPayload₂ (codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell))) + (Code.proj (2 : Fin 3)) y ![s, ((q : ℕ) : M), u]).mp + hbranch + have hp1 := tagFour_read_payload₁ _ q ![s, ((q : ℕ) : M), u] hidx + have hp2 := tagFour_read_payload₂ _ q ![s, ((q : ℕ) : M), u] hidx + have hq1 := eval_iff_codeConst_of_eval _ (partrecCodePayload₁ q) ![s, ((q : ℕ) : M), u] hp1 + have hq2 := eval_iff_codeConst_of_eval _ (partrecCodePayload₂ q) ![s, ((q : ℕ) : M), u] hp2 + have hlaC := + (eval_codeTableLookup_query_congr codeEvaluatorHistoryBeforeCell + (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell)) + (codePartrecPayload₁ (codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell))) + (codeConst (n := 3) (partrecCodePayload₁ q)) (Code.proj (2 : Fin 3)) (a + 1) + ![s, ((q : ℕ) : M), u] hq1).mp + hla + have hlbC := + (eval_codeTableLookup_congr_at (codeLift codeEvaluatorHistoryBeforeCell) + (codeLift (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell))) + (codeLift + (codePartrecPayload₂ (codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell)))) + (codeLift (Code.proj (2 : Fin 3))) codeEvaluatorHistoryBeforeCell + (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell)) + (codeConst (n := 3) (partrecCodePayload₂ q)) (Code.proj (2 : Fin 3)) (b + 1) + (a :> ![s, ((q : ℕ) : M), u]) ![s, ((q : ℕ) : M), u] + (fun z => eval_codeLift_iff _ z a _) (fun z => eval_codeLift_iff _ z a _) + (fun z => (eval_codeLift_iff _ z a _).trans (hq2 z)) + (fun z => eval_codeLift_iff _ z a _)).mp + hlb + have hlt := tagFour_payloads_lt q hq + have hpre1 : + FFL.FirstOrder.Arithmetic.pair s ((partrecCodePayload₁ q : ℕ) : M) < + FFL.FirstOrder.Arithmetic.pair s ((q : ℕ) : M) := + FFL.FirstOrder.Arithmetic.pair_lt_pair_right s (by exact_mod_cast hlt.1) + have hpre2 : + FFL.FirstOrder.Arithmetic.pair s ((partrecCodePayload₂ q : ℕ) : M) < + FFL.FirstOrder.Arithmetic.pair s ((q : ℕ) : M) := + FFL.FirstOrder.Arithmetic.pair_lt_pair_right s (by exact_mod_cast hlt.2) + exact + ⟨a, b, + eval_codeHistoryEvaluator_succ_of_prefix_lookup s ((q : ℕ) : M) u a + (partrecCodePayload₁ q) hpre1 hlaC, + eval_codeHistoryEvaluator_succ_of_prefix_lookup s ((q : ℕ) : M) u b + (partrecCodePayload₂ q) hpre2 hlbC, + hy⟩ + +/-- At a common stage, pairing computes the pair of its component outputs. -/ +theorem evalnCertificateFormula_tag_four_iff [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (q : ℕ) + (hq : partrecCodeTag q = 4) (s u y : M) : + Semiformula.Evalb ![s, (q : M), u, y] (evalnCertificateFormula : ArithmeticSemisentence 4) ↔ + ∃ a b : M, + Semiformula.Evalb ![s, (partrecCodePayload₁ q : M), u, a] + (evalnCertificateFormula : ArithmeticSemisentence 4) ∧ + Semiformula.Evalb ![s, (partrecCodePayload₂ q : M), u, b] + (evalnCertificateFormula : ArithmeticSemisentence 4) ∧ + y = FFL.FirstOrder.Arithmetic.pair a b := + by + constructor + · intro h + have hh := (evalnCertificateFormula_eval_history_iff s (q : M) u y).mp h + obtain ⟨hus, hcell⟩ := (eval_codeHistoryEvaluator_succ_iff_cell s (q : M) u y).mp hh + have hs : 0 < s := lt_of_le_of_lt (FFL.FirstOrder.Arithmetic.zero_le u) hus + obtain ⟨a, b, ha, hb, hy⟩ := tagFour_source_subcode_histories q hq s u y hs hcell + exact + ⟨a, b, (evalnCertificateFormula_eval_history_iff _ _ _ _).mpr ha, + (evalnCertificateFormula_eval_history_iff _ _ _ _).mpr hb, hy⟩ + · rintro ⟨a, b, ha, hb, rfl⟩ + have ha' := + (evalnCertificateFormula_eval_history_iff s (partrecCodePayload₁ q : M) u a).mp ha + have hb' := + (evalnCertificateFormula_eval_history_iff s (partrecCodePayload₂ q : M) u b).mp hb + have hus := + ((eval_codeHistoryEvaluator_succ_iff_cell s (partrecCodePayload₁ q : M) u a).mp ha').1 + have hs : 0 < s := lt_of_le_of_lt (FFL.FirstOrder.Arithmetic.zero_le u) hus + have hlt := tagFour_payloads_lt q hq + have hp₁ : + FFL.FirstOrder.Arithmetic.pair s (partrecCodePayload₁ q : M) < + FFL.FirstOrder.Arithmetic.pair s (q : M) := + FFL.FirstOrder.Arithmetic.pair_lt_pair_right s (by exact_mod_cast hlt.1) + have hp₂ : + FFL.FirstOrder.Arithmetic.pair s (partrecCodePayload₂ q : M) < + FFL.FirstOrder.Arithmetic.pair s (q : M) := + FFL.FirstOrder.Arithmetic.pair_lt_pair_right s (by exact_mod_cast hlt.2) + have hl₁ := eval_prefix_lookup_succ_of_codeHistoryEvaluator s (q : M) u a _ hp₁ ha' + have hl₂ := eval_prefix_lookup_succ_of_codeHistoryEvaluator s (q : M) u b _ hp₂ hb' + have hc := + eval_codeEvaluatorCell_succ_of_pair_component_lookups codeEvaluatorHistoryBeforeCell + (Code.proj (2 : Fin 3)) q hq a b ![s, (q : M), u] + (eval_codeEvaluatorCell_index s (q : M) u) + ⟨s, hs, eval_codeEvaluatorCell_fuel s (q : M) u⟩ hl₁ hl₂ + exact + (evalnCertificateFormula_eval_history_iff _ _ _ _).mpr + ((eval_codeHistoryEvaluator_succ_iff_cell _ _ _ _).mpr ⟨hus, hc⟩) + +/-- Mathlib's pairing constructor, in its fixed natural-number encoding. -/ +def canonicalPartrecPairIndex (fCode gCode : ℕ) : ℕ := + Encodable.encode + (Nat.Partrec.Code.pair (Denumerable.ofNat Nat.Partrec.Code fCode) + (Denumerable.ofNat Nat.Partrec.Code gCode)) + +theorem canonicalPartrecPairIndex_eq (f g : ℕ) : + canonicalPartrecPairIndex f g = 4 * Nat.pair f g + 4 := + by + unfold canonicalPartrecPairIndex + rw [Nat.Partrec.Code.encodeCode_eq] + simp only [Nat.Partrec.Code.encodeCode, ← Nat.Partrec.Code.encodeCode_eq, + Denumerable.encode_ofNat] + omega + +theorem canonicalPartrecPairIndex_tag (f g : ℕ) : + partrecCodeTag (canonicalPartrecPairIndex f g) = 4 := + by + have hb : ∀ n : ℕ, n.bodd.toNat = n % 2 := fun n => by rw [Nat.mod_two_of_bodd] + rw [canonicalPartrecPairIndex_eq] + simp only [partrecCodeTag, hb, Nat.div2_val] + split_ifs <;> omega + +theorem canonicalPartrecPairIndex_payload (f g : ℕ) : + partrecCodePayload (canonicalPartrecPairIndex f g) = Nat.pair f g := + by + rw [canonicalPartrecPairIndex_eq] + simp only [partrecCodePayload, Nat.div2_val] + omega + +theorem canonicalPartrecPairIndex_left (f g : ℕ) : + partrecCodePayload₁ (canonicalPartrecPairIndex f g) = f := by + simp only [partrecCodePayload₁, canonicalPartrecPairIndex_payload, Nat.unpair_pair] + +theorem canonicalPartrecPairIndex_right (f g : ℕ) : + partrecCodePayload₂ (canonicalPartrecPairIndex f g) = g := by + simp only [partrecCodePayload₂, canonicalPartrecPairIndex_payload, Nat.unpair_pair] + +/-- Pairing equation with component stages synchronized internally in PA. -/ +theorem eventualGraph_pair_eval [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (f g : ℕ) (u y : M) : + (eventualGraph (canonicalPartrecPairIndex f g)).val.Evalb ![u, y] ↔ + ∃ a b : M, + (eventualGraph f).val.Evalb ![u, a] ∧ + (eventualGraph g).val.Evalb ![u, b] ∧ y = FFL.FirstOrder.Arithmetic.pair a b := + by + have : M↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + constructor + · intro h + obtain ⟨s, hs⟩ := (eventualGraph_eval _ _).mp h + simp only [numeral_eq_natCast_app, Matrix.cons_val_zero, Matrix.cons_val_one] at hs + obtain ⟨a, b, ha, hb, hy⟩ := + (evalnCertificateFormula_tag_four_iff (canonicalPartrecPairIndex f g) + (canonicalPartrecPairIndex_tag f g) s u y).mp + hs + rw [canonicalPartrecPairIndex_left] at ha + rw [canonicalPartrecPairIndex_right] at hb + refine + ⟨a, b, (eventualGraph_eval _ _).mpr ⟨s, ?_⟩, (eventualGraph_eval _ _).mpr ⟨s, ?_⟩, hy⟩ + · simpa only [numeral_eq_natCast_app, Matrix.cons_val_zero, Matrix.cons_val_one] using ha + · simpa only [numeral_eq_natCast_app, Matrix.cons_val_zero, Matrix.cons_val_one] using hb + · rintro ⟨a, b, ha, hb, hy⟩ + obtain ⟨s, hs⟩ := (eventualGraph_eval _ _).mp ha + obtain ⟨t, ht⟩ := (eventualGraph_eval _ _).mp hb + simp only [numeral_eq_natCast_app, Matrix.cons_val_zero, Matrix.cons_val_one] at hs ht + have hs' := evalnCertificateFormula_natCode_persist f s (s + t) u a le_self_add hs + have ht' := evalnCertificateFormula_natCode_persist g t (s + t) u b le_add_self ht + apply (eventualGraph_eval _ _).mpr + refine ⟨s + t, ?_⟩ + simp only [numeral_eq_natCast_app, Matrix.cons_val_zero, Matrix.cons_val_one] + apply (evalnCertificateFormula_tag_four_iff _ (canonicalPartrecPairIndex_tag f g) _ _ _).mpr + simpa only [canonicalPartrecPairIndex_left, canonicalPartrecPairIndex_right] using + (show + ∃ a b : M, + Semiformula.Evalb ![s + t, (f : M), u, a] + (evalnCertificateFormula : ArithmeticSemisentence 4) ∧ + Semiformula.Evalb ![s + t, (g : M), u, b] + (evalnCertificateFormula : ArithmeticSemisentence 4) ∧ + y = FFL.FirstOrder.Arithmetic.pair a b + from ⟨a, b, hs', ht', hy⟩) + +/-- The natural encoding of a pair constructor is the canonical pairing index. -/ +theorem encode_pair_eq (f g : Nat.Partrec.Code) : + Encodable.encode (Nat.Partrec.Code.pair f g) = + canonicalPartrecPairIndex (Encodable.encode f) (Encodable.encode g) := + by simp only [canonicalPartrecPairIndex, Denumerable.ofNat_encode] + +/-- Same-stage pairing equation in terms of the actual syntax constructors. -/ +theorem evalnCertificateFormula_pair_iff [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + (f g : Nat.Partrec.Code) (s u y : M) : + Semiformula.Evalb ![s, (Encodable.encode (Nat.Partrec.Code.pair f g) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) ↔ + ∃ a b : M, + Semiformula.Evalb ![s, (Encodable.encode f : M), u, a] + (evalnCertificateFormula : ArithmeticSemisentence 4) ∧ + Semiformula.Evalb ![s, (Encodable.encode g : M), u, b] + (evalnCertificateFormula : ArithmeticSemisentence 4) ∧ + y = FFL.FirstOrder.Arithmetic.pair a b := + by + rw [encode_pair_eq] + simpa only [canonicalPartrecPairIndex_left, canonicalPartrecPairIndex_right] using + evalnCertificateFormula_tag_four_iff + (canonicalPartrecPairIndex (Encodable.encode f) (Encodable.encode g)) + (canonicalPartrecPairIndex_tag _ _) s u y + +/-- Eventual pairing equation for Mathlib's actual syntax constructors. -/ +theorem eventualGraph_pair_code_eval [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (f g : Nat.Partrec.Code) + (u y : M) : + (eventualGraph (Encodable.encode (Nat.Partrec.Code.pair f g))).val.Evalb ![u, y] ↔ + ∃ a b : M, + (eventualGraph (Encodable.encode f)).val.Evalb ![u, a] ∧ + (eventualGraph (Encodable.encode g)).val.Evalb ![u, b] ∧ + y = FFL.FirstOrder.Arithmetic.pair a b := + by + rw [encode_pair_eq] + exact eventualGraph_pair_eval _ _ _ _ + +end ConcreteEvaluator +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteDiagonal.lean b/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteDiagonal.lean new file mode 100644 index 000000000..fb69127a9 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteDiagonal.lean @@ -0,0 +1,179 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteAdequacy +public import LeanPool.PointwiseComposition.FailureOfComposition.ProductiveDivergence + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +Productiveness for the diagonal halting formula of the actual history +evaluator. The formula is built directly from `evalnCertificateFormula`; +no representation chosen by `codeOfREPred` occurs in its definition. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +open FFL.FirstOrder.Arithmetic.Bootstrapping FFL.Entailment + +namespace FailureOfComposition +namespace ConcreteEvaluator + +noncomputable section + +/-- The diagonal computation of the actual arithmetized history evaluator. -/ +def diagonalHistoryFormula : ArithmeticSemisentence 1 := + “q. ∃ s y, !CategoricalRiceShapiro.Evaluator.evalnCertificateFormula.val s q q y” + +theorem diagonalHistoryFormula_sigma : Hierarchy Σ 1 diagonalHistoryFormula := by + simp [diagonalHistoryFormula] + +/-- The diagonal formula quantifies over all model stages and outputs. -/ +theorem diagonalHistoryFormula_eval_model {M : Type*} [ORingStructure M] (q : M) : + diagonalHistoryFormula.Evalb ![q] ↔ + ∃ s y : M, + Semiformula.Evalb ![s, q, q, y] + (CategoricalRiceShapiro.Evaluator.evalnCertificateFormula : + ArithmeticSemisentence 4) := + by simp [diagonalHistoryFormula] + +/-- Specializing the program parameter is the same as its fixed-index graph. -/ +theorem diagonalHistoryFormula_eval (n : ℕ) : + diagonalHistoryFormula.Evalb ![n] ↔ ∃ y : ℕ, (eventualGraph n).val.Evalb ![n, y] := + by + simp only [diagonalHistoryFormula, eventualGraph_eval] + simp only [Nat.succ_eq_add_one, Nat.reduceAdd, Fin.isValue, Semiformula.eval_ex, + Semiformula.eval_substs, Matrix.comp₄, Semiterm.val_bvar, Matrix.cons_val_one, + Matrix.cons_val_zero, Matrix.cons_app_two, Fin.Fin1.eq_one, Matrix.cons_val_fin_one, + Nat.numeral_eq] + constructor + · rintro ⟨s, y, h⟩ + exact ⟨y, s, h⟩ + · rintro ⟨y, s, h⟩ + exact ⟨s, y, h⟩ + +/-- The represented divergence sentences provable in T. -/ +def provableHistoryDivergence (T : ArithmeticTheory) (n : ℕ) : Prop := + T ⊢ ∼diagonalHistoryFormula/[n] + +/-- The theorem-code assumption directly enumerates these concrete sentences. -/ +theorem provableHistoryDivergence_re_of_theorem_codes (T : ArithmeticTheory) + (hT : REPred (FailureOfComposition.TheoremCodes T)) : + REPred (provableHistoryDivergence T) := + by + let code : ℕ → ℕ := fun n => + neg ℒₒᵣ (subst ℒₒᵣ ?[Bootstrapping.ObjectArithmetic.numeral n] ⌜diagonalHistoryFormula⌝) + have hcode : Computable code := + computable_iff_sigma1.mpr + (by + dsimp [code] + definability) + apply REPred.of_eq (hT.comp hcode) + intro n + have heq : code n = (⌜(∼diagonalHistoryFormula/[n] : ArithmeticSentence)⌝ : ℕ) := by + simp [code, Sentence.quote_def, Semiformula.quote_def, Rewriting.emb_subst_eq_subst_coe₁] + simp [FailureOfComposition.TheoremCodes, heq, provableHistoryDivergence] + +/-- A Delta-one theory presentation also enumerates the concrete sentences. -/ +theorem provableHistoryDivergence_re (T : ArithmeticTheory) [T.Δ₁] : + REPred (provableHistoryDivergence T) := + by + have h : + Σ₁-Predicate fun n : ℕ => + Bootstrapping.Provable T + (neg ℒₒᵣ + (subst ℒₒᵣ ?[Bootstrapping.ObjectArithmetic.numeral n] ⌜diagonalHistoryFormula⌝)) := + by definability + apply REPred.of_eq (rePred_iff_sigma1.mpr h) + intro n + constructor + · intro hp + apply Bootstrapping.Provable.sound + simpa [Sentence.quote_def, Semiformula.quote_def, Rewriting.emb_subst_eq_subst_coe₁] using + hp + · intro hp + simpa [Sentence.quote_def, Semiformula.quote_def, Rewriting.emb_subst_eq_subst_coe₁] using + internalize_provability (V := ℕ) hp + +/-- Consistency excludes a proved divergence when this concrete Sigma-one +halting formula is true. No Sigma-one soundness assumption on T is needed. -/ +theorem provableHistoryDivergence_sound_eval (T : ArithmeticTheory) [𝐑₀ ≼ T] [Consistent T] + (n : ℕ) : provableHistoryDivergence T n → ¬diagonalHistoryFormula.Evalb ![n] := + by + intro hn hhalt + have hp : T ⊢ diagonalHistoryFormula/[n] := + by + apply sigma_one_completeness (by simp [diagonalHistoryFormula_sigma]) + simpa [models_iff, Semiformula.eval_substs, Matrix.constant_eq_singleton] using hhalt + apply Consistent.not_bot (𝓢 := T) + have hn : T ⊢ ∼diagonalHistoryFormula/[n] := hn + cl_prover[hp, hn] + +/-- Standard-model adequacy for the actual diagonal history formula. -/ +theorem diagonalHistoryFormula_nat (n : ℕ) : + diagonalHistoryFormula.Evalb ![n] ↔ FailureOfComposition.diagonalHalts n := + by + rw [diagonalHistoryFormula_eval] + simp only [eventualGraph_adequate] + exact Part.dom_iff_mem.symm + +/-- Consistency suffices to make the enumerable provable-divergence set a +subset of the genuinely divergent diagonal computations. -/ +theorem provableHistoryDivergence_sound (T : ArithmeticTheory) [𝐑₀ ≼ T] [Consistent T] (n : ℕ) : + provableHistoryDivergence T n → ¬FailureOfComposition.diagonalHalts n := + by + intro hn hh + exact provableHistoryDivergence_sound_eval T n hn ((diagonalHistoryFormula_nat n).mpr hh) + +/-- Productiveness supplies an unprovable divergence sentence for the actual +program-index history formula, without Gödel's second incompleteness theorem. -/ +theorem exists_unprovable_diagonal_history_divergence_of_theorem_codes (T : ArithmeticTheory) + [𝐑₀ ≼ T] [Consistent T] (hT : REPred (FailureOfComposition.TheoremCodes T)) : + ∃ d : ℕ, ¬FailureOfComposition.diagonalHalts d ∧ T ⊬ ∼diagonalHistoryFormula/[d] := by + exact + FailureOfComposition.productive_escape_re + (provableHistoryDivergence_re_of_theorem_codes T hT) (provableHistoryDivergence_sound T) + +/-- The same result from Foundation's Delta-one theory presentation. -/ +theorem exists_unprovable_diagonal_history_divergence (T : ArithmeticTheory) [T.Δ₁] [𝐑₀ ≼ T] + [Consistent T] : + ∃ d : ℕ, ¬FailureOfComposition.diagonalHalts d ∧ T ⊬ ∼diagonalHistoryFormula/[d] := by + exact + FailureOfComposition.productive_escape_re (provableHistoryDivergence_re T) + (provableHistoryDivergence_sound T) + +/-- The selected divergence is true for the concrete arithmetical formula. -/ +theorem exists_true_unprovable_history_divergence_of_theorem_codes (T : ArithmeticTheory) + [𝐑₀ ≼ T] [Consistent T] (hT : REPred (FailureOfComposition.TheoremCodes T)) : + ∃ d : ℕ, ¬diagonalHistoryFormula.Evalb ![d] ∧ T ⊬ ∼diagonalHistoryFormula/[d] := + by + obtain ⟨d, hd, hu⟩ := exists_unprovable_diagonal_history_divergence_of_theorem_codes T hT + exact ⟨d, fun h => hd ((diagonalHistoryFormula_nat d).mp h), hu⟩ + +/-- Concrete arithmetical divergence under a Delta-one theory presentation. -/ +theorem exists_true_unprovable_history_divergence (T : ArithmeticTheory) [T.Δ₁] [𝐑₀ ≼ T] + [Consistent T] : + ∃ d : ℕ, ¬diagonalHistoryFormula.Evalb ![d] ∧ T ⊬ ∼diagonalHistoryFormula/[d] := + by + obtain ⟨d, hd, hu⟩ := exists_unprovable_diagonal_history_divergence T + exact ⟨d, fun h => hd ((diagonalHistoryFormula_nat d).mp h), hu⟩ + +end + +end ConcreteEvaluator +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteEmptyGraph.lean b/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteEmptyGraph.lean new file mode 100644 index 000000000..ac22b9ff0 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteEmptyGraph.lean @@ -0,0 +1,133 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteWitnessGraphs +public import LeanPool.PointwiseComposition.FailureOfComposition.MinimizationPersistence + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +A concrete nowhere-defined program in the accepted Mathlib numbering. +The program searches for a zero of successor; its index is 11. +Its graph is proved empty inside every model of PA, including nonstandard models. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +open scoped FFL.FirstOrder.Arithmetic + +open CategoricalRiceShapiro.Evaluator + +open CategoricalRiceShapiro.ArithmeticCode + +open FailureOfComposition.ConcreteWitnessGraphs + +namespace FailureOfComposition +namespace ConcreteEmptyGraph + +/-- Search for a zero of successor, starting from the supplied search position. -/ +def concreteEmptyIndex : ℕ := + Encodable.encode (Nat.Partrec.Code.rfind' Nat.Partrec.Code.succ) + +@[simp] +theorem concreteEmptyIndex_eq : concreteEmptyIndex = 11 := + rfl + +/-- Absence of successful computations at a stage, expressed in PA's language. -/ +def noComputationFormula (q : ℕ) : ArithmeticSemisentence 1 := + “s. ∀ u, ∀ y, ¬!certificateSentence s↑q u y” + +variable {M : Type*} [ORingStructure M] + +private theorem noComputationFormula_eval [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (q : ℕ) (s : M) : + Semiformula.Evalb ![s] (noComputationFormula q) ↔ + ∀ u y : M, + ¬Semiformula.Evalb ![s, ((q : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) := + by + simp [noComputationFormula, certificateSentence, Semiformula.eval_substs, numeral_eq_natCast] + +/-- No stage, input, or output in a PA model is a successful computation of +`rfind' succ`; the induction is PA induction on the model's stage parameter. -/ +theorem concreteEmpty_no_computation [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] : + ∀ s u y : M, + ¬Semiformula.Evalb ![s, (concreteEmptyIndex : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) := + by + have := models_inductionScheme_univ (M := M) + have : Inhabited M := ⟨0⟩ + have hzero : + ∀ u y : M, + ¬Semiformula.Evalb ![(0 : M), (concreteEmptyIndex : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) := + by + intro u y h + have hhist := (evalnCertificateFormula_eval_history_iff 0 (concreteEmptyIndex : M) u y).mp h + have hlt := + ((eval_codeHistoryEvaluator_succ_iff_cell 0 (concreteEmptyIndex : M) u y).mp hhist).1 + exact (not_lt_of_ge (FFL.FirstOrder.Arithmetic.zero_le u)) hlt + have hstep (s : M) + (ih : + ∀ u y : M, + ¬Semiformula.Evalb ![s, (concreteEmptyIndex : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4)) : + ∀ u y : M, + ¬Semiformula.Evalb ![s + 1, (concreteEmptyIndex : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) := + by + intro u y h + have hs : (0 : M) < s + 1 := + lt_of_le_of_lt (FFL.FirstOrder.Arithmetic.zero_le s) (lt_add_one s) + obtain ⟨_, x, hx, hcase⟩ := + (evalnCertificateFormula_tag_seven_iff concreteEmptyIndex (by decide) (s + 1) u y hs).mp h + have hsub : partrecCodePayload concreteEmptyIndex = 1 := by decide + rw [hsub] at hx + have hx' : u < s + 1 ∧ x = u + 1 := by + simpa [baseOutput] using (base_computation_iff 1 (by decide) (s + 1) u x).mp hx + rcases hcase with ⟨_, hr⟩ | ⟨hx0, _⟩ + · apply ih _ y + simpa only [add_sub_self] using hr + · have hp : (0 : M) < u + 1 := + lt_of_le_of_lt (FFL.FirstOrder.Arithmetic.zero_le u) (lt_add_one u) + exact (ne_of_gt hp) (hx'.2.symm.trans hx0) + intro s + refine + InductionScheme.succ_induction (C := Set.univ) (P := fun s : M => + ∀ u y : M, + ¬Semiformula.Evalb ![s, (concreteEmptyIndex : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4)) + ⟨fun _ => default, Rew.emb ▹ noComputationFormula concreteEmptyIndex, trivial, ?_⟩ hzero + hstep s + intro x + rw [← noComputationFormula_eval concreteEmptyIndex x] + simp [Semiformula.eval_emb] + +/-- The unbounded computation graph of the concrete empty program is empty. -/ +theorem concreteEmpty_unbounded_computation_iff [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (u y : M) : + (∃ s : M, + Semiformula.Evalb ![s, (concreteEmptyIndex : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4)) ↔ + False := + by + constructor + · rintro ⟨s, h⟩ + exact concreteEmpty_no_computation s u y h + · exact False.elim + +end ConcreteEmptyGraph +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteEvaluatorGraph.lean b/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteEvaluatorGraph.lean new file mode 100644 index 000000000..33ed6506a --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteEvaluatorGraph.lean @@ -0,0 +1,175 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcretePersistence +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteEmptyGraph +public import LeanPool.PointwiseComposition.FailureOfComposition.ProofSearchTemplate + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +The existential-stage graph of the repository's concrete evaluator. + +Persistence of successful computations brings two possibly nonstandard stages +to a common stage. It therefore supplies PA proofs of functionality and of the +composition equation for the actual canonical composition indices. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic FFL.Entailment + +open CategoricalRiceShapiro.ArithmeticCode CategoricalRiceShapiro.Evaluator + +open CategoricalRiceShapiro.PartialRecursive + +namespace FailureOfComposition +namespace ConcreteEvaluator + +open ProofSearch + +noncomputable section + +/-- PA proves persistence at each fixed standard index, with all stages, +inputs, and outputs quantified inside the arithmetic sentence. -/ +theorem evaluator_persistence_provable (q : ℕ) : + 𝐏𝐀 ⊢ + (“∀ s t x y, + s ≤ t → + !evalnCertificateFormula.val s !!(q)x y → + !evalnCertificateFormula.val t !!(q)x y”) := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + have : M↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + simpa [models_iff, numeral_eq_natCast] using + (evalnCertificateFormula_natCode_persist (M := M) q) + +/-- The graph at a fixed standard program index, allowing any internal stage. -/ +def eventualGraph (q : ℕ) : Graph := + .mkSigma (“x y. ∃ s, !evalnCertificateFormula.val s !!(q)x y”) + +@[simp] +theorem eventualGraph_eval {M : Type*} [ORingStructure M] (q : ℕ) (v : Fin 2 → M) : + (eventualGraph q).val.Evalb v ↔ + ∃ s : M, + Semiformula.Evalb ![s, (ORingStructure.numeral q : M), v 0, v 1] + (evalnCertificateFormula : ArithmeticSemisentence 4) := + by simp [eventualGraph] + +/-- Two successful computations of one standard index have the same output, +even when their stages are nonstandard and different. -/ +theorem eventualGraph_output_unique {M : Type*} [ORingStructure M] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] (q : ℕ) + (x y z : M) (hy : (eventualGraph q).val.Evalb ![x, y]) + (hz : (eventualGraph q).val.Evalb ![x, z]) : y = z := + by + have : M↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + obtain ⟨s, hs⟩ := (eventualGraph_eval q _).mp hy + obtain ⟨t, ht⟩ := (eventualGraph_eval q _).mp hz + simp only [numeral_eq_natCast_app, Matrix.cons_val_zero, Matrix.cons_val_one] at hs ht + have hs' := evalnCertificateFormula_natCode_persist q s (s + t) x y le_self_add hs + have ht' := evalnCertificateFormula_natCode_persist q t (s + t) x z le_add_self ht + exact + add_right_cancel + (eval_unique ((evalnCertificateFormula_eval_history_iff (s + t) (q : M) x y).mp hs') + ((evalnCertificateFormula_eval_history_iff (s + t) (q : M) x z).mp ht')) + +/-- Functionality is proved in PA for this concrete evaluator graph. -/ +theorem eventualGraph_functional (q : ℕ) : Functional (eventualGraph q) := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + rw [models_iff, functionalSentence_eval] + exact eventualGraph_output_unique q + +/-- The composition equation holds in every PA model at all internal inputs +and outputs; the two component computations need not start at the same stage. -/ +theorem eventualGraph_comp_eval {M : Type*} [ORingStructure M] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] (fCode gCode : ℕ) + (x z : M) : + (eventualGraph (canonicalPartrecCompIndex fCode gCode)).val.Evalb ![x, z] ↔ + ∃ y : M, + (eventualGraph gCode).val.Evalb ![x, y] ∧ (eventualGraph fCode).val.Evalb ![y, z] := + by + have : M↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + constructor + · intro h + obtain ⟨s, hs⟩ := (eventualGraph_eval _ _).mp h + obtain ⟨y, hy, hz⟩ := + evalnCertificateFormula_canonicalPartrecCompIndex_forward s x z fCode gCode hs + exact ⟨y, (eventualGraph_eval _ _).mpr ⟨s, hy⟩, (eventualGraph_eval _ _).mpr ⟨s, hz⟩⟩ + · rintro ⟨y, hy, hz⟩ + obtain ⟨s, hs⟩ := (eventualGraph_eval _ _).mp hy + obtain ⟨t, ht⟩ := (eventualGraph_eval _ _).mp hz + simp only [numeral_eq_natCast_app, Matrix.cons_val_zero, Matrix.cons_val_one] at hs ht + have hs' := evalnCertificateFormula_natCode_persist gCode s (s + t) x y le_self_add hs + have ht' := evalnCertificateFormula_natCode_persist fCode t (s + t) y z le_add_self ht + apply (eventualGraph_eval _ _).mpr + refine ⟨s + t, ?_⟩ + apply evalnCertificateFormula_canonicalPartrecCompIndex_reverse (s + t) x y z fCode gCode + · simpa only [numeral_eq_natCast_app] using hs' + · simpa only [numeral_eq_natCast_app] using ht' + +/-- PA proves relational composition for the concrete program indices. -/ +theorem eventualGraph_composition (fCode gCode : ℕ) : + Uniform 𝐏𝐀 (eventualGraph (canonicalPartrecCompIndex fCode gCode)) + (comp (eventualGraph fCode) (eventualGraph gCode)) := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + rw [models_iff, uniformSentence_eval] + intro x z + rw [comp_eval] + exact eventualGraph_comp_eval fCode gCode x z + +/-- The identity index already defined by Mathlib's program numbering realizes +the equality graph in PA, at all internal inputs and outputs. -/ +theorem eventualGraph_identity : Uniform 𝐏𝐀 (eventualGraph Kleene.identityIndex) identity := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + have : M↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + rw [models_iff, uniformSentence_eval] + intro x y + rw [identity_eval] + simp only [Matrix.cons_val_zero, Matrix.cons_val_one] + have hi : (eventualGraph Kleene.identityIndex).val.Evalb ![x, x] := + by + apply (eventualGraph_eval _ _).mpr + refine ⟨x + 1, ?_⟩ + simpa only [numeral_eq_natCast_app, Matrix.cons_val_zero, Matrix.cons_val_one] using + (ConcreteWitnessGraphs.identity_computation (x + 1) x (lt_add_one x)) + constructor + · intro hy + exact eventualGraph_output_unique Kleene.identityIndex x y x hy hi + · rintro rfl + exact hi + +/-- Minimization of successor supplies an explicitly encoded nowhere-defined +program, whose empty graph equation is provable in PA. -/ +theorem eventualGraph_empty : + Uniform 𝐏𝐀 (eventualGraph ConcreteEmptyGraph.concreteEmptyIndex) empty := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + have : M↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + simp only [models_iff, uniformSentence_eval, empty_eval, eventualGraph_eval, + numeral_eq_natCast_app, Matrix.cons_val_zero, Matrix.cons_val_one] + exact ConcreteEmptyGraph.concreteEmpty_unbounded_computation_iff + +end + +end ConcreteEvaluator +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteGeneratedCongruence.lean b/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteGeneratedCongruence.lean new file mode 100644 index 000000000..dfd7388b6 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteGeneratedCongruence.lean @@ -0,0 +1,109 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.GeneratedIndexClassification +public import LeanPool.PointwiseComposition.FailureOfComposition.GeneratedIndexQuotient +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteGodel + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +Generated-congruence classification for the concrete evaluator indices. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic FFL.Entailment + +open CategoricalRiceShapiro.PartialRecursive + +namespace FailureOfComposition +namespace ConcreteIndices + +noncomputable section + +/-- The intersection of all composition congruences containing pointwise +provability for the actual natural-number program indices. -/ +def GeneratedRel (T : ArithmeticTheory) : ℕ → ℕ → Prop := + CompositionClosure.Generated canonicalPartrecCompIndex (PointwiseIndex T) + +/-- The generated Setoid construction in `FailureOfComposition.ConcreteIndices`. -/ +def generatedSetoid (T : ArithmeticTheory) : Setoid ℕ := + CompositionClosure.setoid canonicalPartrecCompIndex (PointwiseIndex T) + +/-- Equal partial functions are always identified by the generated congruence. -/ +theorem extensional_implies_generated (T : ArithmeticTheory) [𝐏𝐀 ≼ T] (e d : ℕ) + (h : Kleene.eval e = Kleene.eval d) : GeneratedRel T e d := + ProgramIndices.extensional_implies_generated ConcreteEvaluator.arithmetization T e d h + +theorem generated_iff_extensional_of_sound (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (hT : GeneratedCongruence.SigmaOneSound T) (e d : ℕ) : + GeneratedRel T e d ↔ Kleene.eval e = Kleene.eval d := + ProgramIndices.generated_iff_extensional_of_sound ConcreteEvaluator.arithmetization T hT e d + +theorem generated_universal_of_not_sound (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (hT : ¬GeneratedCongruence.SigmaOneSound T) (e d : ℕ) : GeneratedRel T e d := + ProgramIndices.generated_universal_of_not_sound ConcreteEvaluator.arithmetization T hT e d + +/-- The generated-congruence theorem for every extension of PA. There is no +consistency, enumerability, or supplied realization hypothesis. -/ +theorem generated_congruence_classification (T : ArithmeticTheory) [𝐏𝐀 ≼ T] : + (GeneratedCongruence.SigmaOneSound T → + ∀ e d : ℕ, GeneratedRel T e d ↔ Kleene.eval e = Kleene.eval d) ∧ + (¬GeneratedCongruence.SigmaOneSound T → ∀ e d : ℕ, GeneratedRel T e d) := + ⟨generated_iff_extensional_of_sound T, generated_universal_of_not_sound T⟩ + +theorem generated_iff_extensional_or_unsound (T : ArithmeticTheory) [𝐏𝐀 ≼ T] (e d : ℕ) : + GeneratedRel T e d ↔ Kleene.eval e = Kleene.eval d ∨ ¬GeneratedCongruence.SigmaOneSound T := + ProgramIndices.generated_iff_extensional_or_unsound ConcreteEvaluator.arithmetization T e d + +/-- In particular, closing PA-pointwise equality under composition gives +exactly extensional equality. -/ +theorem pa_generated_iff_extensional (e d : ℕ) : + GeneratedRel 𝐏𝐀 e d ↔ Kleene.eval e = Kleene.eval d := + by + apply generated_iff_extensional_of_sound 𝐏𝐀 + intro σ _ hp + exact consequence_iff.mp (Theory.Proof.sound hp) ℕ inferInstance + +/-- The Generated Quotient construction in `FailureOfComposition.ConcreteIndices`. -/ +abbrev GeneratedQuotient (T : ArithmeticTheory) := + ProgramIndices.GeneratedIndexQuotient ConcreteEvaluator.arithmetization T + +/-- The generated Quotient Mk construction in `FailureOfComposition.ConcreteIndices`. -/ +def generatedQuotientMk (T : ArithmeticTheory) (e : ℕ) : GeneratedQuotient T := + Quotient.mk (generatedSetoid T) e + +theorem generated_quotient_mul_mk (T : ArithmeticTheory) (e d : ℕ) : + generatedQuotientMk T e * generatedQuotientMk T d = + generatedQuotientMk T (canonicalPartrecCompIndex e d) := + rfl + +/-- The concrete index quotient and functional-graph quotient are isomorphic +as monoids, with their induced composition operations. -/ +def generatedQuotientMulEquiv (T : ArithmeticTheory) [𝐏𝐀 ≼ T] : + GeneratedQuotient T ≃* GeneratedCongruence.QuotientGraph T := + ProgramIndices.generatedQuotientMulEquiv ConcreteEvaluator.arithmetization T + +theorem generated_quotient_subsingleton_iff_not_sound (T : ArithmeticTheory) [𝐏𝐀 ≼ T] : + Subsingleton (GeneratedQuotient T) ↔ ¬GeneratedCongruence.SigmaOneSound T := + ProgramIndices.generated_quotient_subsingleton_iff_not_sound ConcreteEvaluator.arithmetization + T + +end + +end ConcreteIndices +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteGodel.lean b/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteGodel.lean new file mode 100644 index 000000000..341aff920 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteGodel.lean @@ -0,0 +1,106 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.SigmaOneRealization +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteAdequacy +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteIndexObstruction + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +The complete arithmetization for the production history evaluator, and the +independent second-incompleteness proof for theories with a Delta-one axiom +presentation. The realization field is proved by the formula compiler; no +arithmetization structure or realization premise is supplied by the caller. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic FFL.Entailment + +open CategoricalRiceShapiro.PartialRecursive + +namespace FailureOfComposition +namespace ConcreteEvaluator + +/-- The actual Mathlib numbering and production arithmetic graph satisfy all +of the arithmetization properties used in the manuscript. -/ +noncomputable def arithmetization : ProgramIndices.Arithmetization + where + evaluation := Kleene.eval + graph := eventualGraph + compIndex := canonicalPartrecCompIndex + compIndex_primrec := Kleene.compIndex_primrec + adequate := eventualGraph_adequate + functional := eventualGraph_functional + composition := eventualGraph_composition + realization := SigmaOneRealization.realize_graph + +end ConcreteEvaluator +end FailureOfComposition + +namespace FailureOfComposition +namespace ConcreteIndices + +/-- The second-incompleteness witnesses are indices of the concrete evaluator. +This proof uses the proof predicate of the chosen Delta-one presentation. -/ +theorem index_noncongruence_via_godel (T : ArithmeticTheory) [T.Δ₁] [Consistent T] [𝐏𝐀 ≼ T] : + ∃ f i g : ℕ, + PointwiseIndex T f i ∧ + ¬PointwiseIndex T (canonicalPartrecCompIndex f g) (canonicalPartrecCompIndex i g) := + ProgramIndices.index_noncongruence_of_graph_noncongruence ConcreteEvaluator.arithmetization T + (graph_noncongruence_via_godel T) + +/-- Concrete quotient composition fails by Gödel II, independently of the +productive-set proof. Only consistency and the displayed theory hypotheses +are assumed; realization is supplied by the concrete formula compiler. -/ +theorem no_index_quotient_via_godel (T : ArithmeticTheory) [T.Δ₁] [Consistent T] [𝐏𝐀 ≼ T] : + NoIndexQuotientComposition T := + ProgramIndices.no_index_quotient_via_godel ConcreteEvaluator.arithmetization T + +theorem pa_no_index_quotient_via_godel : NoIndexQuotientComposition 𝐏𝐀 := + no_index_quotient_via_godel 𝐏𝐀 + +/-- Replacing a theory by a deductively equivalent Delta-one presentation +preserves the external pointwise relation and its failure of congruence. -/ +theorem index_noncongruence_via_godel_of_equivalent_presentation (S T : ArithmeticTheory) [S.Δ₁] + [Consistent T] [𝐏𝐀 ≼ T] (hST : S ≼ T) (hTS : T ≼ S) : + ∃ f i g : ℕ, + PointwiseIndex T f i ∧ + ¬PointwiseIndex T (canonicalPartrecCompIndex f g) (canonicalPartrecCompIndex i g) := + by + let : S ≼ T := hST + let : T ≼ S := hTS + have : 𝐏𝐀 ≼ S := WeakerThan.trans (𝓣 := T) inferInstance hTS + have : Consistent S := + consistent_iff_unprovable_bot.mpr fun h => + consistent_iff_unprovable_bot.mp (inferInstance : Consistent T) (WeakerThan.pbl h) + obtain ⟨f, i, g, hfi, hcomp⟩ := index_noncongruence_via_godel S + refine ⟨f, i, g, fun n => WeakerThan.pbl (hfi n), ?_⟩ + intro h + exact hcomp (fun n => WeakerThan.pbl (h n)) + +theorem no_index_quotient_via_godel_of_equivalent_presentation (S T : ArithmeticTheory) [S.Δ₁] + [Consistent T] [𝐏𝐀 ≼ T] (hST : S ≼ T) (hTS : T ≼ S) : NoIndexQuotientComposition T := + by + obtain ⟨f, i, g, hfi, hcomp⟩ := + index_noncongruence_via_godel_of_equivalent_presentation S T hST hTS + exact + no_quotient_composition_of_noncongruence (indexSetoid T) canonicalPartrecCompIndex f i g hfi + hcomp + +end ConcreteIndices +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteGodelRE.lean b/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteGodelRE.lean new file mode 100644 index 000000000..487370cba --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteGodelRE.lean @@ -0,0 +1,63 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteGodel +public import LeanPool.PointwiseComposition.FailureOfComposition.CraigPresentation + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +The concrete second-incompleteness obstruction for every consistent extension +of PA with recursively enumerable axiom codes. Craig's padded presentation +discharges the Delta-one presentation requirement of the proof predicate. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic FFL.Entailment + +open CategoricalRiceShapiro.PartialRecursive + +namespace FailureOfComposition +namespace ConcreteIndices + +theorem index_noncongruence_via_godel_of_re_axioms (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + [Consistent T] (hT : REPred (FailureOfComposition.AxiomCodes T)) : + ∃ f i g : ℕ, + PointwiseIndex T f i ∧ + ¬PointwiseIndex T (canonicalPartrecCompIndex f g) (canonicalPartrecCompIndex i g) := + by + obtain ⟨S, ⟨hS⟩, hST, hTS⟩ := CraigPresentation.exists_craig_presentation T hT + let : S.Δ₁ := hS + exact index_noncongruence_via_godel_of_equivalent_presentation S T hST hTS + +/-- The Gödel-II route, with the same r.e.-axiom assumptions as the independent +productive-set route and no realization or presentation hypothesis. -/ +theorem no_index_quotient_via_godel_of_re_axioms (T : ArithmeticTheory) [𝐏𝐀 ≼ T] [Consistent T] + (hT : REPred (FailureOfComposition.AxiomCodes T)) : NoIndexQuotientComposition T := + by + obtain ⟨f, i, g, hfi, hcomp⟩ := index_noncongruence_via_godel_of_re_axioms T hT + exact + no_quotient_composition_of_noncongruence (indexSetoid T) canonicalPartrecCompIndex f i g hfi + hcomp + +theorem no_index_quotient_via_godel_of_axiom_enumerator (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + [Consistent T] (a : ℕ) (ha : ∀ n : ℕ, AxiomCodes T n ↔ ∃ x : ℕ, n ∈ Kleene.eval a x) : + NoIndexQuotientComposition T := + no_index_quotient_via_godel_of_re_axioms T (axiom_codes_re_of_program_enumerator T a ha) + +end ConcreteIndices +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteIndexObstruction.lean b/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteIndexObstruction.lean new file mode 100644 index 000000000..0ff08c3a7 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteIndexObstruction.lean @@ -0,0 +1,187 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.HistoryObstruction +public import LeanPool.PointwiseComposition.FailureOfComposition.ArithmeticCodeCompiler +public import LeanPool.PointwiseComposition.FailureOfComposition.ProgramIndices +public import LeanPool.PointwiseComposition.FailureOfComposition.AxiomEnumeration + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +Concrete natural-number witnesses for the failure of quotient composition. +The graphs are the production history evaluator, and the guard/search indices +are obtained by the proved structural compiler, without an Arithmetization +parameter or a graph-realization hypothesis. +-/ + +@[expose] public section + +open Encodable FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic FFL.Entailment + +open CategoricalRiceShapiro.PartialRecursive + +namespace FailureOfComposition +namespace ConcreteIndices + +open ProofSearch ConcreteEvaluator HistoryWitnesses ArithmeticCodeCompiler + +open ProgramIndices + +/-- The guard Index construction in `FailureOfComposition.ConcreteIndices`. -/ +def guardIndex (d : ℕ) : ℕ := + encode (unaryCompile (guardCode d)) + +/-- The search Index construction in `FailureOfComposition.ConcreteIndices`. -/ +def searchIndex (d : ℕ) : ℕ := + encode (unaryCompile (searchCode d)) + +theorem guardIndex_realizes (d : ℕ) : + Uniform 𝐏𝐀 (eventualGraph (guardIndex d)) (guardGraph d) := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + have : M↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + rw [models_iff, uniformSentence_eval] + intro x y + exact (computes_unaryCompile (guardCode d) x y).trans (guardCode_eval d x y) + +theorem searchIndex_realizes (d : ℕ) : + Uniform 𝐏𝐀 (eventualGraph (searchIndex d)) (searchGraph d) := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + have : M↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + rw [models_iff, uniformSentence_eval] + intro x y + exact (computes_unaryCompile (searchCode d) x y).trans (searchCode_eval d x y) + +/-- The external input quantifier of Montagna's relation. -/ +def PointwiseIndex (T : ArithmeticTheory) (e f : ℕ) : Prop := + ∀ n : ℕ, T ⊢ kleeneEqAt (eventualGraph e) (eventualGraph f) n + +theorem pointwiseIndex_iff (T : ArithmeticTheory) [𝐏𝐀 ≼ T] (e f : ℕ) : + PointwiseIndex T e f ↔ Pointwise T (eventualGraph e) (eventualGraph f) := + by + have h (n : ℕ) : + T ⊢ + kleeneEqAt (eventualGraph e) (eventualGraph f) n ⇔ₗ + eqAt (eventualGraph e) (eventualGraph f) n := + WeakerThan.pbl + (kleeneEqAt_iff_eqAt _ _ (eventualGraph_functional e) (eventualGraph_functional f) n) + constructor + · intro he n + have hn := he n + cl_prover[h n, hn] + · intro he n + have hn := he n + cl_prover[h n, hn] + +/-- The index Setoid construction in `FailureOfComposition.ConcreteIndices`. -/ +def indexSetoid (T : ArithmeticTheory) [𝐏𝐀 ≼ T] : Setoid ℕ + where + r := PointwiseIndex T + iseqv := + { refl := fun e => (pointwiseIndex_iff T e e).mpr ((pointwise_equivalence T).refl _) + symm := fun {e f} h => + (pointwiseIndex_iff T f e).mpr + ((pointwise_equivalence T).symm ((pointwiseIndex_iff T e f).mp h)) + trans := fun {e f g} h₁ h₂ => + (pointwiseIndex_iff T e g).mpr + ((pointwise_equivalence T).trans ((pointwiseIndex_iff T e f).mp h₁) + ((pointwiseIndex_iff T f g).mp h₂)) } + +/-- The No Index Quotient Composition construction in `FailureOfComposition.ConcreteIndices`. -/ +def NoIndexQuotientComposition (T : ArithmeticTheory) [𝐏𝐀 ≼ T] : Prop := + ¬∃ C : Quotient (indexSetoid T) → Quotient (indexSetoid T) → Quotient (indexSetoid T), + ∀ e f, + C (Quotient.mk (indexSetoid T) e) (Quotient.mk (indexSetoid T) f) = + Quotient.mk (indexSetoid T) (canonicalPartrecCompIndex e f) + +theorem index_noncongruence_of_history_divergence (T : ArithmeticTheory) [𝐏𝐀 ≼ T] (d : ℕ) + (hdiv : ¬diagonalHistoryFormula.Evalb ![d]) (hnot : T ⊬ ∼diagonalHistoryFormula/[d]) : + PointwiseIndex T (guardIndex d) Kleene.identityIndex ∧ + ¬PointwiseIndex T (canonicalPartrecCompIndex (guardIndex d) (searchIndex d)) + (canonicalPartrecCompIndex Kleene.identityIndex (searchIndex d)) := + by + obtain ⟨hfi, hn⟩ := graph_noncongruence_of_history_divergence T d hdiv hnot + have eqv := pointwise_equivalence T + have hf := uniform_to_pointwise T (guardIndex_realizes d) + have hi := uniform_to_pointwise T eventualGraph_identity + have hfg : + Pointwise T (eventualGraph (canonicalPartrecCompIndex (guardIndex d) (searchIndex d))) + (comp (guardGraph d) (searchGraph d)) := + eqv.trans (uniform_to_pointwise T (eventualGraph_composition _ _)) + (uniform_to_pointwise T (uniform_comp (guardIndex_realizes d) (searchIndex_realizes d))) + have hig : + Pointwise T (eventualGraph (canonicalPartrecCompIndex Kleene.identityIndex (searchIndex d))) + (comp identity (searchGraph d)) := + eqv.trans (uniform_to_pointwise T (eventualGraph_composition _ _)) + (uniform_to_pointwise T (uniform_comp eventualGraph_identity (searchIndex_realizes d))) + refine ⟨(pointwiseIndex_iff T _ _).mpr (eqv.trans hf (eqv.trans hfi (eqv.symm hi))), ?_⟩ + intro hc + exact hn (eqv.trans (eqv.symm hfg) (eqv.trans ((pointwiseIndex_iff T _ _).mp hc) hig)) + +theorem no_index_quotient_of_history_divergence (T : ArithmeticTheory) [𝐏𝐀 ≼ T] (d : ℕ) + (hdiv : ¬diagonalHistoryFormula.Evalb ![d]) (hnot : T ⊬ ∼diagonalHistoryFormula/[d]) : + NoIndexQuotientComposition T := + by + obtain ⟨hfi, hcomp⟩ := index_noncongruence_of_history_divergence T d hdiv hnot + exact + no_quotient_composition_of_noncongruence (indexSetoid T) canonicalPartrecCompIndex + (guardIndex d) Kleene.identityIndex (searchIndex d) hfi hcomp + +/-- Concrete obstruction, using only consistency and an r.e. theorem set. -/ +theorem no_index_quotient_via_productiveness (T : ArithmeticTheory) [𝐏𝐀 ≼ T] [Consistent T] + (hT : REPred (FailureOfComposition.TheoremCodes T)) : NoIndexQuotientComposition T := + by + obtain ⟨d, hdiv, hnot⟩ := exists_true_unprovable_history_divergence_of_theorem_codes T hT + exact no_index_quotient_of_history_divergence T d hdiv hnot + +/-- The decidable axiom-presentation specialization. -/ +theorem no_index_quotient_of_delta_one (T : ArithmeticTheory) [T.Δ₁] [𝐏𝐀 ≼ T] [Consistent T] : + NoIndexQuotientComposition T := + by + obtain ⟨d, hdiv, hnot⟩ := exists_true_unprovable_history_divergence T + exact no_index_quotient_of_history_divergence T d hdiv hnot + +/-- Every consistent extension of PA with recursively enumerable axiom codes +has this concrete program-index quotient obstruction. -/ +theorem no_index_quotient_of_re_axioms (T : ArithmeticTheory) [𝐏𝐀 ≼ T] [Consistent T] + (hT : REPred (FailureOfComposition.AxiomCodes T)) : NoIndexQuotientComposition T := + no_index_quotient_via_productiveness T (theorem_codes_re_of_axiom_codes T hT) + +/-- The explicit partial-recursive axiom enumeration used in v36. -/ +theorem no_index_quotient_of_axiom_enumerator (T : ArithmeticTheory) [𝐏𝐀 ≼ T] [Consistent T] + (a : ℕ) (ha : ∀ n : ℕ, AxiomCodes T n ↔ ∃ x : ℕ, n ∈ Kleene.eval a x) : + NoIndexQuotientComposition T := + no_index_quotient_of_re_axioms T (axiom_codes_re_of_program_enumerator T a ha) + +end ConcreteIndices +end FailureOfComposition + +namespace FailureOfComposition +namespace ProgramIndices + +/-- The manuscript's arithmetization assumptions with its r.e. axiom +presentation; no separate theorem-code enumerability hypothesis remains. -/ +theorem no_index_quotient_of_re_axioms (A : Arithmetization) (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + [Consistent T] (hT : REPred (FailureOfComposition.AxiomCodes T)) : + NoIndexQuotientComposition A T := + no_index_quotient_via_productiveness A T (theorem_codes_re_of_axiom_codes T hT) + +end ProgramIndices +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteMinimizationGraph.lean b/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteMinimizationGraph.lean new file mode 100644 index 000000000..df0bc5a73 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteMinimizationGraph.lean @@ -0,0 +1,318 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteEvaluatorGraph + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +PA graph laws for concrete minimization programs. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +open scoped FFL.FirstOrder.Arithmetic + +open Encodable + +open CategoricalRiceShapiro.ArithmeticCode CategoricalRiceShapiro.Evaluator + +namespace FailureOfComposition +namespace ConcreteEvaluator + +noncomputable section + +private theorem rfind_tag (c : Nat.Partrec.Code) : + partrecCodeTag (encode (Nat.Partrec.Code.rfind' c)) = 7 := + by + have hb (n : ℕ) : n.bodd.toNat = n % 2 := by rw [Nat.mod_two_of_bodd] + simp only [Nat.Partrec.Code.encodeCode_eq, Nat.Partrec.Code.encodeCode] + have h : ¬2 * (2 * Nat.Partrec.Code.encodeCode c + 1) + 1 + 4 < 4 := by omega + simp only [partrecCodeTag, h, ite_false, hb, Nat.div2_val] + omega + +private theorem rfind_payload (c : Nat.Partrec.Code) : + partrecCodePayload (encode (Nat.Partrec.Code.rfind' c)) = encode c := + by + simp only [Nat.Partrec.Code.encodeCode_eq, Nat.Partrec.Code.encodeCode, partrecCodePayload, + Nat.div2_val] + omega + +private def pairedStageFormula (q : ℕ) : ArithmeticSemisentence 4 := + “s a m y. ∃ u, !pairDef u a m ∧ !evalnCertificateFormula.val s !!(q)u y” + +private def pairedEventualFormula (q : ℕ) : ArithmeticSemisentence 3 := + “a m y. ∃ u, !pairDef u a m ∧ !(eventualGraph q).val u y” + +variable {M : Type*} [ORingStructure M] + +section + +variable [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + +private abbrev sc (q : ℕ) (s a m y : M) : Prop := + Semiformula.Evalb ![s, (q : M), FFL.FirstOrder.Arithmetic.pair a m, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) + +private abbrev egp (q : ℕ) (a m y : M) : Prop := + (eventualGraph q).val.Evalb ![FFL.FirstOrder.Arithmetic.pair a m, y] + +end + +section + +variable [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + +private theorem pairedStageFormula_eval (q : ℕ) (s a m y : M) : + (pairedStageFormula q).Evalb ![s, a, m, y] ↔ sc q s a m y := by + simp [pairedStageFormula, sc, numeral_eq_natCast] + +private theorem pairedEventualFormula_eval (q : ℕ) (a m y : M) : + (pairedEventualFormula q).Evalb ![a, m, y] ↔ egp q a m y := by + simp [pairedEventualFormula, egp] + +private theorem egp_iff (q : ℕ) (a m y : M) : egp q a m y ↔ ∃ s : M, sc q s a m y := by + simpa only [sc, egp, numeral_eq_natCast_app, Matrix.cons_val_zero, Matrix.cons_val_one] using + eventualGraph_eval q ![FFL.FirstOrder.Arithmetic.pair a m, y] + +end + +section + +variable [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + +private theorem sc_rfind (f : Nat.Partrec.Code) (s a m y : M) (hs : 0 < s) : + sc (encode (Nat.Partrec.Code.rfind' f)) s a m y ↔ + FFL.FirstOrder.Arithmetic.pair a m < s ∧ + ∃ v : M, + sc (encode f) s a m v ∧ + ((0 < v ∧ sc (encode (Nat.Partrec.Code.rfind' f)) (s - 1) a (m + 1) y) ∨ + (v = 0 ∧ y = m)) := + by + simpa only [sc, rfind_payload, FFL.FirstOrder.Arithmetic.pi₁_pair, + FFL.FirstOrder.Arithmetic.pi₂_pair] using + evalnCertificateFormula_tag_seven_iff (encode (Nat.Partrec.Code.rfind' f)) (rfind_tag f) s + (FFL.FirstOrder.Arithmetic.pair a m) y hs + +end + +private def forwardFormula (q p : ℕ) : ArithmeticSemisentence 1 := + “s. + ∀ a m y, + !(pairedStageFormula q)s a m y → + (m ≤ y ∧ + !(pairedEventualFormula p)a y 0 ∧ + ∀ k, m ≤ k → k < y → ∃ v, v ≠ 0 ∧ !(pairedEventualFormula p)a k v)” + +section + +variable [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + +private theorem forwardFormula_eval (q p : ℕ) (s : M) : + (forwardFormula q p).Evalb ![s] ↔ + ∀ a m y : M, + sc q s a m y → + m ≤ y ∧ egp p a y 0 ∧ ∀ k : M, m ≤ k → k < y → ∃ v : M, v ≠ 0 ∧ egp p a k v := + by simp [forwardFormula, pairedStageFormula_eval, pairedEventualFormula_eval] + +end + +section + +variable [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + +private theorem rfind_forward (f : Nat.Partrec.Code) : + ∀ s a m y : M, + sc (encode (Nat.Partrec.Code.rfind' f)) s a m y → + m ≤ y ∧ + egp (encode f) a y 0 ∧ + ∀ k : M, m ≤ k → k < y → ∃ v : M, v ≠ 0 ∧ egp (encode f) a k v := + by + have := models_inductionScheme_univ (M := M) + have : Inhabited M := ⟨0⟩ + intro s + apply + InductionScheme.succ_induction (C := Set.univ) (P := fun s : M => + ∀ a m y : M, + sc (encode (Nat.Partrec.Code.rfind' f)) s a m y → + m ≤ y ∧ + egp (encode f) a y 0 ∧ + ∀ k : M, m ≤ k → k < y → ∃ v : M, v ≠ 0 ∧ egp (encode f) a k v) + ⟨fun _ => default, + Rew.emb ▹ forwardFormula (encode (Nat.Partrec.Code.rfind' f)) (encode f), trivial, ?_⟩ + ?_ ?_ s + · intro x + rw [← forwardFormula_eval] + simp [Semiformula.eval_emb] + · intro a m y h + have hh := (evalnCertificateFormula_eval_history_iff (0 : M) _ _ _).mp h + have hlt := ((eval_codeHistoryEvaluator_succ_iff_cell (0 : M) _ _ _).mp hh).1 + exact False.elim ((not_lt_of_ge (FFL.FirstOrder.Arithmetic.zero_le _)) hlt) + · intro s ih a m y h + have hs : (0 : M) < s + 1 := + lt_of_le_of_lt (FFL.FirstOrder.Arithmetic.zero_le s) (lt_add_one s) + obtain ⟨_, v, hv, hcase⟩ := (sc_rfind f (s + 1) a m y hs).mp h + rcases hcase with ⟨hvp, hr⟩ | ⟨hv0, rfl⟩ + · have hr' : sc (encode (Nat.Partrec.Code.rfind' f)) s a (m + 1) y := by + simpa only [add_sub_self] using hr + obtain ⟨hmy, hy, hp⟩ := ih a (m + 1) y hr' + refine ⟨le_trans (le_self_add : m ≤ m + 1) hmy, hy, ?_⟩ + intro k hmk hky + rcases eq_or_lt_of_le hmk with rfl | hmk' + · exact ⟨v, ne_of_gt hvp, (egp_iff _ _ _ _).mpr ⟨s + 1, hv⟩⟩ + · exact hp k (FFL.FirstOrder.Arithmetic.succ_le_iff_lt.mpr hmk') hky + · refine ⟨le_refl _, ?_, ?_⟩ + · exact (egp_iff _ _ _ _).mpr ⟨s + 1, by simpa only [hv0] using hv⟩ + · intro k hmk hkm + exact False.elim ((not_lt_of_ge hmk) hkm) + +private theorem rfind_stop (f : Nat.Partrec.Code) (a m : M) (h : egp (encode f) a m 0) : + egp (encode (Nat.Partrec.Code.rfind' f)) a m m := + by + obtain ⟨s, hs⟩ := (egp_iff _ _ _ _).mp h + let u := FFL.FirstOrder.Arithmetic.pair a m + have hu : u < s + u + 1 := lt_of_le_of_lt le_add_self (lt_add_one _) + have hp : (0 : M) < s + u + 1 := + lt_of_le_of_lt (FFL.FirstOrder.Arithmetic.zero_le _) (lt_add_one _) + apply (egp_iff _ _ _ _).mpr + refine ⟨s + u + 1, (sc_rfind f _ a m m hp).mpr ⟨hu, 0, ?_, Or.inr ⟨rfl, rfl⟩⟩⟩ + exact + evalnCertificateFormula_natCode_persist (encode f) s (s + u + 1) u 0 + (le_trans le_self_add le_self_add) hs + +private theorem rfind_next (f : Nat.Partrec.Code) (a m y : M) + (h : ∃ v : M, v ≠ 0 ∧ egp (encode f) a m v) + (hr : egp (encode (Nat.Partrec.Code.rfind' f)) a (m + 1) y) : + egp (encode (Nat.Partrec.Code.rfind' f)) a m y := + by + obtain ⟨v, hv, hvg⟩ := h + obtain ⟨sv, hvs⟩ := (egp_iff _ _ _ _).mp hvg + obtain ⟨sr, hrs⟩ := (egp_iff _ _ _ _).mp hr + let u := FFL.FirstOrder.Arithmetic.pair a m + let t := sv + sr + u + have hu : u < t + 1 := lt_of_le_of_lt le_add_self (lt_add_one _) + have ht : (0 : M) < t + 1 := + lt_of_le_of_lt (FFL.FirstOrder.Arithmetic.zero_le _) (lt_add_one _) + have hvp : 0 < v := lt_of_le_of_ne (FFL.FirstOrder.Arithmetic.zero_le v) (Ne.symm hv) + apply (egp_iff _ _ _ _).mpr + refine ⟨t + 1, (sc_rfind f _ a m y ht).mpr ⟨hu, v, ?_, Or.inl ⟨hvp, ?_⟩⟩⟩ + · exact + evalnCertificateFormula_natCode_persist (encode f) sv (t + 1) u v + (le_trans (le_trans le_self_add le_self_add) le_self_add) hvs + · have hle : sr ≤ t := le_trans le_add_self le_self_add + have hc := + evalnCertificateFormula_natCode_persist (encode (Nat.Partrec.Code.rfind' f)) sr t + (FFL.FirstOrder.Arithmetic.pair a (m + 1)) y hle hrs + simpa only [add_sub_self] using hc + +end + +private def reverseFormula (q p : ℕ) : ArithmeticSemisentence 1 := + “l. + ∀ a m, + (!(pairedEventualFormula p)a(m + l)0 ∧ + ∀ k, m ≤ k → k < m + l → ∃ v, v ≠ 0 ∧ !(pairedEventualFormula p)a k v) → + !(pairedEventualFormula q)a m(m + l)” + +section + +variable [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + +private theorem reverseFormula_eval (q p : ℕ) (l : M) : + (reverseFormula q p).Evalb ![l] ↔ + ∀ a m : M, + (egp p a (m + l) 0 ∧ ∀ k : M, m ≤ k → k < m + l → ∃ v : M, v ≠ 0 ∧ egp p a k v) → + egp q a m (m + l) := + by simp [reverseFormula, pairedEventualFormula_eval] + +end + +section + +variable [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + +private theorem rfind_reverse (f : Nat.Partrec.Code) : + ∀ l a m : M, + (egp (encode f) a (m + l) 0 ∧ + ∀ k : M, m ≤ k → k < m + l → ∃ v : M, v ≠ 0 ∧ egp (encode f) a k v) → + egp (encode (Nat.Partrec.Code.rfind' f)) a m (m + l) := + by + have := models_inductionScheme_univ (M := M) + have : Inhabited M := ⟨0⟩ + intro l + apply + InductionScheme.succ_induction (C := Set.univ) (P := fun l : M => + ∀ a m : M, + (egp (encode f) a (m + l) 0 ∧ + ∀ k : M, m ≤ k → k < m + l → ∃ v : M, v ≠ 0 ∧ egp (encode f) a k v) → + egp (encode (Nat.Partrec.Code.rfind' f)) a m (m + l)) + ⟨fun _ => default, + Rew.emb ▹ reverseFormula (encode (Nat.Partrec.Code.rfind' f)) (encode f), trivial, ?_⟩ + ?_ ?_ l + · intro x + rw [← reverseFormula_eval] + simp [Semiformula.eval_emb] + · intro a m h + simp only [add_zero] at h ⊢ + exact rfind_stop f a m h.1 + · intro l ih a m h + have he : m + 1 + l = m + (l + 1) := by rw [add_assoc, add_comm (1 : M) l] + have hml : m < m + (l + 1) := + by + have h0 : (0 : M) < l + 1 := + lt_of_le_of_lt (FFL.FirstOrder.Arithmetic.zero_le l) (lt_add_one l) + simpa only [zero_add, add_zero, add_comm] using add_lt_add_left h0 m + have hp := h.2 m (le_refl m) hml + have hr : egp (encode (Nat.Partrec.Code.rfind' f)) a (m + 1) (m + 1 + l) := + by + apply ih a (m + 1) + refine ⟨by simpa only [he] using h.1, ?_⟩ + intro k hmk hky + exact h.2 k (le_trans le_self_add hmk) (by simpa only [he] using hky) + exact rfind_next f a m (m + (l + 1)) hp (by simpa only [he] using hr) + +/-- The complete existential-stage graph of minimization from candidate zero. +The candidate bound and every computation stage range over the PA model. -/ +theorem eventualGraph_rfind_code_eval (f : Nat.Partrec.Code) (a y : M) : + (eventualGraph (encode (Nat.Partrec.Code.rfind' f))).val.Evalb + ![FFL.FirstOrder.Arithmetic.pair a 0, y] ↔ + (eventualGraph (encode f)).val.Evalb ![FFL.FirstOrder.Arithmetic.pair a y, 0] ∧ + ∀ k : M, + k < y → + ∃ z : M, + z ≠ 0 ∧ + (eventualGraph (encode f)).val.Evalb ![FFL.FirstOrder.Arithmetic.pair a k, z] := + by + constructor + · intro h + obtain ⟨s, hs⟩ := (egp_iff _ _ _ _).mp h + obtain ⟨_, hy, hp⟩ := rfind_forward f s a 0 y hs + exact ⟨hy, fun k hk => hp k (FFL.FirstOrder.Arithmetic.zero_le k) hk⟩ + · intro h + have hh : + egp (encode f) a (0 + y) 0 ∧ + ∀ k : M, 0 ≤ k → k < 0 + y → ∃ z : M, z ≠ 0 ∧ egp (encode f) a k z := + by simpa only [zero_add] using And.intro h.1 (fun k _ hk => h.2 k hk) + simpa only [zero_add] using rfind_reverse f y a 0 hh + +end + +end + +end ConcreteEvaluator +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/ConcretePersistence.lean b/LeanPool/PointwiseComposition/FailureOfComposition/ConcretePersistence.lean new file mode 100644 index 000000000..b1d4863ed --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/ConcretePersistence.lean @@ -0,0 +1,86 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteWitnessGraphs +public import LeanPool.PointwiseComposition.FailureOfComposition.MinimizationPersistence +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.PairPersistence +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.CompositionPersistence +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.PrimitiveRecursionPersistence + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +Persistence of the repository's concrete evaluator at every standard program +index. The induction is external on the natural-number index. The stage, input, +and output range over an arbitrary model of PA, including its nonstandard +elements. The constructor lemmas discharge every induction case. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +open scoped FFL.FirstOrder.Arithmetic + +open CategoricalRiceShapiro.ArithmeticCode CategoricalRiceShapiro.Evaluator + +namespace FailureOfComposition +namespace ConcreteEvaluator + +theorem partrecCodeTag_lt_eight (q : ℕ) : partrecCodeTag q < 8 := + by + have hb : ∀ n : ℕ, n.bodd.toNat = n % 2 := fun n => by rw [Nat.mod_two_of_bodd] + simp only [partrecCodeTag, hb] + split_ifs <;> omega + +theorem lt_four_of_partrecCodeTag_lt_four (q : ℕ) (hq : partrecCodeTag q < 4) : q < 4 := + by + unfold partrecCodeTag at hq + split_ifs at hq with h + · exact h + · dsimp at hq + omega + +/-- Unconditional persistence for every standard Mathlib program index in +every PA model. No persistence or arithmetization field is a hypothesis. -/ +theorem evalnCertificateFormula_natCode_persist {M : Type*} [ORingStructure M] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] + [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (q : ℕ) : + ∀ s t u y : M, + s ≤ t → + Semiformula.Evalb ![s, ((q : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) → + Semiformula.Evalb ![t, ((q : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) := + by + induction q using Nat.strong_induction_on with + | h q ih => + by_cases hsmall : partrecCodeTag q < 4 + · exact + ConcreteWitnessGraphs.evalnCertificateFormula_natCode_persist_of_lt_four q + (lt_four_of_partrecCodeTag_lt_four q hsmall) + have hbound := partrecCodeTag_lt_eight q + have hcases : + partrecCodeTag q = 4 ∨ + partrecCodeTag q = 5 ∨ partrecCodeTag q = 6 ∨ partrecCodeTag q = 7 := + by omega + rcases hcases with h4 | h5 | h6 | h7 + · exact evalnCertificateFormula_natCode_persist_of_tag_four q h4 ih + · exact evalnCertificateFormula_natCode_persist_of_tag_five q h5 ih + · exact evalnCertificateFormula_natCode_persist_of_tag_six q h6 ih + · exact evalnCertificateFormula_natCode_persist_of_tag_seven q h7 ih + +end ConcreteEvaluator +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/ConcretePiOneCharacterization.lean b/LeanPool/PointwiseComposition/FailureOfComposition/ConcretePiOneCharacterization.lean new file mode 100644 index 000000000..feeaafb51 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/ConcretePiOneCharacterization.lean @@ -0,0 +1,98 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.PiOneIndexCharacterization +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteGodel + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +The manuscript's four-way characterization for the actual natural-number +program indices and history graphs. The ambient theory may be non-enumerable. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic FFL.Entailment + +open CategoricalRiceShapiro.PartialRecursive + +namespace FailureOfComposition +namespace ConcreteIndices + +/-- The Right Compatible construction in `FailureOfComposition.ConcreteIndices`. -/ +def RightCompatible (T : ArithmeticTheory) : Prop := + ∀ f h g : ℕ, + PointwiseIndex T f h → + PointwiseIndex T (canonicalPartrecCompIndex f g) (canonicalPartrecCompIndex h g) + +/-- The Composition Congruence construction in `FailureOfComposition.ConcreteIndices`. -/ +def CompositionCongruence (T : ArithmeticTheory) : Prop := + ∀ f f' g g' : ℕ, + PointwiseIndex T f f' → + PointwiseIndex T g g' → + PointwiseIndex T (canonicalPartrecCompIndex f g) (canonicalPartrecCompIndex f' g') + +/-- The Agrees With Extensional construction in `FailureOfComposition.ConcreteIndices`. -/ +def AgreesWithExtensional (T : ArithmeticTheory) : Prop := + ∀ e d : ℕ, PointwiseIndex T e d ↔ Kleene.eval e = Kleene.eval d + +/-- Left composition preserves pointwise provability for every PA extension. -/ +theorem pointwiseIndex_comp_left (T : ArithmeticTheory) [𝐏𝐀 ≼ T] (f g h : ℕ) + (hgh : PointwiseIndex T g h) : + PointwiseIndex T (canonicalPartrecCompIndex f g) (canonicalPartrecCompIndex f h) := + ProgramIndices.pointwiseIndex_comp_left ConcreteEvaluator.arithmetization T f g h hgh + +theorem rightCompatible_implies_piOneComplete (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (h : RightCompatible T) : PiOneCharacterization.PiOneComplete T := + PiOneCharacterization.rightCompatible_implies_piOneComplete T + ((ProgramIndices.rightCompatible_iff_graph ConcreteEvaluator.arithmetization T).mp h) + +theorem rightCompatible_iff_piOneComplete (T : ArithmeticTheory) [𝐏𝐀 ≼ T] [Consistent T] : + RightCompatible T ↔ PiOneCharacterization.PiOneComplete T := + ProgramIndices.rightCompatible_iff_piOneComplete ConcreteEvaluator.arithmetization T + +theorem compositionCongruence_iff_piOneComplete (T : ArithmeticTheory) [𝐏𝐀 ≼ T] [Consistent T] : + CompositionCongruence T ↔ PiOneCharacterization.PiOneComplete T := + ProgramIndices.compositionCongruence_iff_piOneComplete ConcreteEvaluator.arithmetization T + +theorem agreesWithExtensional_iff_piOneComplete (T : ArithmeticTheory) [𝐏𝐀 ≼ T] [Consistent T] : + AgreesWithExtensional T ↔ PiOneCharacterization.PiOneComplete T := + ProgramIndices.agreesWithExtensional_iff_piOneComplete ConcreteEvaluator.arithmetization T + +/-- Pointwise provability is exactly equality of the computed partial functions +when T is consistent and proves every true Pi-one sentence. -/ +theorem pointwiseIndex_iff_evaluation_eq (T : ArithmeticTheory) [𝐏𝐀 ≼ T] [Consistent T] + (hT : PiOneCharacterization.PiOneComplete T) (e d : ℕ) : + PointwiseIndex T e d ↔ Kleene.eval e = Kleene.eval d := + ProgramIndices.pointwiseIndex_iff_evaluation_eq ConcreteEvaluator.arithmetization T hT e d + +/-- The four statements of the characterization, without a realization or +recursive-enumerability hypothesis. -/ +theorem pi_one_characterization (T : ArithmeticTheory) [𝐏𝐀 ≼ T] [Consistent T] : + (RightCompatible T ↔ CompositionCongruence T) ∧ + (CompositionCongruence T ↔ PiOneCharacterization.PiOneComplete T) ∧ + (PiOneCharacterization.PiOneComplete T ↔ AgreesWithExtensional T) := + ⟨(rightCompatible_iff_piOneComplete T).trans (compositionCongruence_iff_piOneComplete T).symm, + compositionCongruence_iff_piOneComplete T, (agreesWithExtensional_iff_piOneComplete T).symm⟩ + +/-- Induced quotient composition fails exactly when Pi-one completeness fails. -/ +theorem no_index_quotient_iff_not_piOneComplete (T : ArithmeticTheory) [𝐏𝐀 ≼ T] [Consistent T] : + NoIndexQuotientComposition T ↔ ¬PiOneCharacterization.PiOneComplete T := + ProgramIndices.no_index_quotient_iff_not_piOneComplete ConcreteEvaluator.arithmetization T + +end ConcreteIndices +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteRecursionGraph.lean b/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteRecursionGraph.lean new file mode 100644 index 000000000..00c3b83b8 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteRecursionGraph.lean @@ -0,0 +1,764 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteEvaluatorGraph + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +Arithmetic graph equations for actual primitive-recursion program indices. +The equations hold over arbitrary PA models, including nonstandard inputs. -/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +open scoped FFL.FirstOrder.Arithmetic + +open Nat.ArithPart₁ + +open CategoricalRiceShapiro.ArithmeticCode CategoricalRiceShapiro.PartialRecursive + +open CategoricalRiceShapiro.Evaluator + +namespace FailureOfComposition +namespace ConcreteEvaluator + +variable {M : Type*} [ORingStructure M] + +/-- A standard tag-6 index, cast into the model, is the canonical +primitive-recursion index of its decoded payloads. -/ +private theorem tagSix_canonical_cast [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] (q : ℕ) (hq : partrecCodeTag q = 6) : + ((q : ℕ) : M) = + ((canonicalPartrecPrecIndex (partrecCodePayload₁ q) (partrecCodePayload₂ q) : ℕ) : M) := + by conv_lhs => rw [partrecCode_eq_canonicalPartrecPrecIndex_of_tag_six q hq] + +/-- The constructor number `6`, read at a standard tag-6 index. -/ +private theorem tagSix_read_tag [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) + (hq : partrecCodeTag q = 6) (v : Fin r → M) + (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : + Semiformula.Evalb ((6 : M) :> v) (code (codePartrecTag d)) := + by + rw [tagSix_canonical_cast (M := M) q hq] at hd + exact + eval_codePartrecTag_canonicalPartrecPrecIndex d (partrecCodePayload₁ q) + (partrecCodePayload₂ q) v hd + +/-- The base payload, read at a standard tag-6 index. -/ +private theorem tagSix_read_payload₁ [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) + (hq : partrecCodeTag q = 6) (v : Fin r → M) + (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : + Semiformula.Evalb (((partrecCodePayload₁ q : ℕ) : M) :> v) (code (codePartrecPayload₁ d)) := + by + rw [tagSix_canonical_cast (M := M) q hq] at hd + exact + eval_codePartrecPayload₁_canonicalPartrecPrecIndex d (partrecCodePayload₁ q) + (partrecCodePayload₂ q) v hd + +/-- The step payload, read at a standard tag-6 index. -/ +private theorem tagSix_read_payload₂ [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) + (hq : partrecCodeTag q = 6) (v : Fin r → M) + (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : + Semiformula.Evalb (((partrecCodePayload₂ q : ℕ) : M) :> v) (code (codePartrecPayload₂ d)) := + by + rw [tagSix_canonical_cast (M := M) q hq] at hd + exact + eval_codePartrecPayload₂_canonicalPartrecPrecIndex d (partrecCodePayload₁ q) + (partrecCodePayload₂ q) v hd + +/-! +### The constructor-6 branch of the eager dispatcher -/ + +/-- With positive fuel and a tag reading of `6`, the cell value is the value of +the primitive-recursion branch. The first comparison of the dispatcher, with +`4`, and the second, with `5`, both fail, and the third, with `6`, succeeds. -/ +private theorem tagSix_prec_branch [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (dtable dn : Code r) (v : Fin r → M) + (z k : M) (hk : Semiformula.Evalb (k :> v) (code (codeUnpair₁ (codeListLength dtable)))) + (hkpos : 0 < k) + (htag : + Semiformula.Evalb ((6 : M) :> v) + (code (codePartrecTag (codeUnpair₂ (codeListLength dtable))))) + (hcell : Semiformula.Evalb (z :> v) (code (codeEvaluatorCell dtable dn))) : + Semiformula.Evalb (z :> v) + (code + (codePrecEvaluatorCell dtable + (codeSub (codeUnpair₁ (codeListLength dtable)) (codeConst 1)) + (codeUnpair₂ (codeListLength dtable)) + (codePartrecPayload₁ (codeUnpair₂ (codeListLength dtable))) + (codePartrecPayload₂ (codeUnpair₂ (codeListLength dtable))) dn)) := + by + have hconst : + ∀ (m : ℕ) (x : M), + Semiformula.Evalb (x :> v) (code (codeConst (n := r) m)) → x = ((m : ℕ) : M) := + fun m x hx => eval_unique hx (eval_codeConst m v) + have hcast4 : ((4 : ℕ) : M) = (4 : M) := by simp + have hcast5 : ((5 : ℕ) : M) = (5 : M) := by simp + have hcast6 : ((6 : ℕ) : M) = (6 : M) := by simp + have hne64 : ¬((6 : M) = ((4 : ℕ) : M)) := + by + rw [hcast4] + exact fun hc => + absurd hc.symm + (_root_.ne_of_lt + (by + simpa [FFL.FirstOrder.Arithmetic.numeral_eq_natCast] using + (FFL.FirstOrder.Arithmetic.numeral_lt_of_lt (M := M) (by omega : 4 < 6)))) + have hne65 : ¬((6 : M) = ((5 : ℕ) : M)) := + by + rw [hcast5] + exact fun hc => + absurd hc.symm + (_root_.ne_of_lt + (by + simpa [FFL.FirstOrder.Arithmetic.numeral_eq_natCast] using + (FFL.FirstOrder.Arithmetic.numeral_lt_of_lt (M := M) (by omega : 5 < 6)))) + simp only [codeEvaluatorCell] at hcell + obtain ⟨kf, hkf, hkcase⟩ := eval_codeIfPos_cases _ _ _ z v hcell + have hkfk : kf = k := eval_unique hkf hk + rcases hkcase with ⟨-, hafterFuel⟩ | ⟨h0, -⟩ + swap + · exact absurd (hkfk ▸ h0 : k = 0) (ne_of_gt hkpos) + obtain ⟨e4, he4, h4case⟩ := eval_codeIfPos_cases _ _ _ z v hafterFuel + rw [eval_codeEq_iff] at he4 + obtain ⟨a4, b4, ha4, hb4, hc4⟩ := he4 + have ha46 : a4 = (6 : M) := eval_unique ha4 htag + have hb44 : b4 = ((4 : ℕ) : M) := hconst 4 b4 hb4 + have he40 : e4 = 0 := by + rcases hc4 with ⟨heq, -⟩ | ⟨-, h0⟩ + · exact absurd (by rw [← ha46, ← hb44]; exact heq) hne64 + · exact h0 + rcases h4case with ⟨hpos, -⟩ | ⟨-, hafterFour⟩ + · exact absurd (he40 ▸ hpos) (_root_.lt_irrefl 0) + obtain ⟨e5, he5, h5case⟩ := eval_codeIfPos_cases _ _ _ z v hafterFour + rw [eval_codeEq_iff] at he5 + obtain ⟨a5, b5, ha5, hb5, hc5⟩ := he5 + have ha56 : a5 = (6 : M) := eval_unique ha5 htag + have hb55 : b5 = ((5 : ℕ) : M) := hconst 5 b5 hb5 + have he50 : e5 = 0 := by + rcases hc5 with ⟨heq, -⟩ | ⟨-, h0⟩ + · exact absurd (by rw [← ha56, ← hb55]; exact heq) hne65 + · exact h0 + rcases h5case with ⟨hpos, -⟩ | ⟨-, hafterFive⟩ + · exact absurd (he50 ▸ hpos) (_root_.lt_irrefl 0) + obtain ⟨e6, he6, h6case⟩ := eval_codeIfPos_cases _ _ _ z v hafterFive + rw [eval_codeEq_iff] at he6 + obtain ⟨a6, b6, ha6, hb6, hc6⟩ := he6 + have ha66 : a6 = (6 : M) := eval_unique ha6 htag + have hb66 : b6 = ((6 : ℕ) : M) := hconst 6 b6 hb6 + have he61 : e6 = 1 := by + rcases hc6 with ⟨-, h1⟩ | ⟨hne, -⟩ + · exact h1 + · exact absurd (by rw [ha66, hb66, hcast6]) hne + rcases h6case with ⟨-, hprec⟩ | ⟨h0, -⟩ + · exact hprec + · exact absurd (he61 ▸ h0 : (1 : M) = 0) _root_.one_ne_zero + +/-! +### Fuel arithmetic and the readings the branch uses -/ + +/-- The dispatcher evaluates the branch at the decremented fuel `k - 1`; for +positive `k`, its successor, the key of the base lookup, is `k`. -/ +private theorem tagSix_succ_pred [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : M} (hk : 0 < k) : k - 1 + 1 = k := + FFL.FirstOrder.Arithmetic.sub_add_self_of_le + (FFL.FirstOrder.Arithmetic.one_le_of_zero_lt k hk) + +/-- The decremented fuel, as the dispatcher computes it. -/ +private theorem tagSix_decremented_fuel [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] + (s qCode u : M) : + Semiformula.Evalb ((s - 1) :> ![s, qCode, u]) + (code + (codeSub (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell)) + (codeConst 1))) := + by + have hone : Semiformula.Evalb ((1 : M) :> ![s, qCode, u]) (code (codeConst (n := 3) 1)) := + by + have h := eval_codeConst (M := M) (k := 3) 1 ![s, qCode, u] + have hcast : (((1 : ℕ)) : M) = (1 : M) := by simp + rwa [hcast] at h + exact + eval_codeSub _ (codeConst 1) s (1 : M) ![s, qCode, u] + (eval_codeEvaluatorCell_fuel s qCode u) hone + +/-- The key of the base lookup is the fuel. -/ +private theorem tagSix_base_key [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] + (s qCode u : M) (hs : 0 < s) : + Semiformula.Evalb (s :> ![s, qCode, u]) + (code + (codeSucc + (codeSub (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell)) + (codeConst 1)))) := + by + refine (eval_codeSucc_iff _ _ _).mpr ⟨s - 1, tagSix_decremented_fuel s qCode u, ?_⟩ + exact (tagSix_succ_pred hs).symm + +/-! +### Relating the base lookup of the branch to the history bridges + +The branch reads its table, key, query and argument through decoded codes; the +history bridges use the fuel key, a constant query and the argument itself. The +four congruences below prove that the two forms have the same values. -/ + +private theorem tagSix_table_congr [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (s qCode u z x : M) : + Semiformula.Evalb (x :> ![s, qCode, u]) (code codeEvaluatorHistoryBeforeCell) ↔ + Semiformula.Evalb (x :> ![s, qCode, z]) (code codeEvaluatorHistoryBeforeCell) := + by + have hpair : + ∀ c : M, + Semiformula.Evalb (FFL.FirstOrder.Arithmetic.pair s qCode :> ![s, qCode, c]) + (code (codePair (Code.proj (0 : Fin 3)) (Code.proj (1 : Fin 3)))) := + fun c => + eval_codePair _ _ s qCode ![s, qCode, c] ((eval_proj_iff _ _ _).mpr rfl) + ((eval_proj_iff _ _ _).mpr rfl) + rw [codeEvaluatorHistoryBeforeCell, eval_comp_iff, eval_comp_iff] + constructor + · rintro ⟨w, hw, hcomp⟩ + refine ⟨w, hw, ?_⟩ + intro i + refine Fin.cases ?_ (fun j => Fin.elim0 j) i + have h0 := hcomp 0 + have : w 0 = FFL.FirstOrder.Arithmetic.pair s qCode := eval_unique h0 (hpair u) + simpa [this] using hpair z + · rintro ⟨w, hw, hcomp⟩ + refine ⟨w, hw, ?_⟩ + intro i + refine Fin.cases ?_ (fun j => Fin.elim0 j) i + have h0 := hcomp 0 + have : w 0 = FFL.FirstOrder.Arithmetic.pair s qCode := eval_unique h0 (hpair z) + simpa [this] using hpair u + +private theorem tagSix_key_congr [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] + (s qCode u z : M) (hs : 0 < s) (x : M) : + Semiformula.Evalb (x :> ![s, qCode, u]) + (code + (codeSucc + (codeSub (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell)) + (codeConst 1)))) ↔ + Semiformula.Evalb (x :> ![s, qCode, z]) + (code (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell))) := + by + constructor + · intro hx + have hxs : x = s := eval_unique hx (tagSix_base_key s qCode u hs) + rw [hxs] + exact eval_codeEvaluatorCell_fuel s qCode z + · intro hx + have hxs : x = s := eval_unique hx (eval_codeEvaluatorCell_fuel s qCode z) + rw [hxs] + exact tagSix_base_key s qCode u hs + +private theorem tagSix_query_congr [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] + (s u z : M) (q : ℕ) (hq : partrecCodeTag q = 6) (x : M) : + Semiformula.Evalb (x :> ![s, ((q : ℕ) : M), u]) + (code + (codePartrecPayload₁ (codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell)))) ↔ + Semiformula.Evalb (x :> ![s, ((q : ℕ) : M), z]) + (code (codeConst (n := 3) (partrecCodePayload₁ q))) := + by + have hleft := tagSix_read_payload₁ _ q hq _ (eval_codeEvaluatorCell_index s ((q : ℕ) : M) u) + have hright : + Semiformula.Evalb (((partrecCodePayload₁ q : ℕ) : M) :> ![s, ((q : ℕ) : M), z]) + (code (codeConst (n := 3) (partrecCodePayload₁ q))) := + eval_codeConst _ ![s, ((q : ℕ) : M), z] + constructor + · intro hx + have hxv : x = ((partrecCodePayload₁ q : ℕ) : M) := eval_unique hx hleft + rw [hxv] + exact hright + · intro hx + have hxv : x = ((partrecCodePayload₁ q : ℕ) : M) := eval_unique hx hright + rw [hxv] + exact hleft + +private theorem tagSix_argument_congr [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (s qCode z x : M) : + Semiformula.Evalb (x :> ![s, qCode, FFL.FirstOrder.Arithmetic.pair z 0]) + (code (codeUnpair₁ (Code.proj (2 : Fin 3)))) ↔ + Semiformula.Evalb (x :> ![s, qCode, z]) (code (Code.proj (2 : Fin 3))) := + by + have hleft : + Semiformula.Evalb (z :> ![s, qCode, FFL.FirstOrder.Arithmetic.pair z 0]) + (code (codeUnpair₁ (Code.proj (2 : Fin 3)))) := + by + have h := + eval_codeUnpair₁ (Code.proj (2 : Fin 3)) (FFL.FirstOrder.Arithmetic.pair z 0) + ![s, qCode, FFL.FirstOrder.Arithmetic.pair z 0] ((eval_proj_iff _ _ _).mpr rfl) + rwa [FFL.FirstOrder.Arithmetic.pi₁_pair] at h + have hright : Semiformula.Evalb (z :> ![s, qCode, z]) (code (Code.proj (2 : Fin 3))) := + (eval_proj_iff _ _ _).mpr rfl + constructor + · intro hx + have hxz : x = z := eval_unique hx hleft + rw [hxz] + exact hright + · intro hx + have hxz : x = z := eval_unique hx hright + rw [hxz] + exact hleft + +/-- The predecessor lookup reads the argument `pair z a` from `pair z (a + 1)`. -/ +private theorem tagSix_predecessor_argument [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + (s qCode z a : M) : + Semiformula.Evalb + ((FFL.FirstOrder.Arithmetic.pair z a) :> + ![s, qCode, FFL.FirstOrder.Arithmetic.pair z (a + 1)]) + (code + (codePair (codeUnpair₁ (Code.proj (2 : Fin 3))) + (codeSub (codeUnpair₂ (Code.proj (2 : Fin 3))) (codeConst 1)))) := + by + let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + have hproj : + Semiformula.Evalb + (FFL.FirstOrder.Arithmetic.pair z (a + 1) :> + ![s, qCode, FFL.FirstOrder.Arithmetic.pair z (a + 1)]) + (code (Code.proj (2 : Fin 3))) := + (eval_proj_iff _ _ _).mpr rfl + have h1 := eval_codeUnpair₁ (Code.proj (2 : Fin 3)) _ _ hproj + rw [FFL.FirstOrder.Arithmetic.pi₁_pair] at h1 + have h2 := eval_codeUnpair₂ (Code.proj (2 : Fin 3)) _ _ hproj + rw [FFL.FirstOrder.Arithmetic.pi₂_pair] at h2 + have hone : + Semiformula.Evalb ((1 : M) :> ![s, qCode, FFL.FirstOrder.Arithmetic.pair z (a + 1)]) + (code (codeConst (n := 3) 1)) := + by rw [eval_codeConst_iff]; simp + have h3 := eval_codeSub _ (codeConst 1) (a + 1) 1 _ h2 hone + rw [add_sub_self] at h3 + exact eval_codePair _ _ z a _ h1 h3 + +/-- The step lookup reads the argument `pair z (pair a x)` in the lifted +environment, where the intermediate value `x` is the new head. -/ +private theorem tagSix_step_argument [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (s qCode z a x : M) : + Semiformula.Evalb + ((FFL.FirstOrder.Arithmetic.pair z (FFL.FirstOrder.Arithmetic.pair a x)) :> + (x :> ![s, qCode, FFL.FirstOrder.Arithmetic.pair z (a + 1)])) + (code + (codePair (codeLift (codeUnpair₁ (Code.proj (2 : Fin 3)))) + (codePair (codeLift (codeSub (codeUnpair₂ (Code.proj (2 : Fin 3))) (codeConst 1))) + (codeHead (n := 3))))) := + by + let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + have hproj : + Semiformula.Evalb + (FFL.FirstOrder.Arithmetic.pair z (a + 1) :> + ![s, qCode, FFL.FirstOrder.Arithmetic.pair z (a + 1)]) + (code (Code.proj (2 : Fin 3))) := + (eval_proj_iff _ _ _).mpr rfl + have h1 := eval_codeUnpair₁ (Code.proj (2 : Fin 3)) _ _ hproj + rw [FFL.FirstOrder.Arithmetic.pi₁_pair] at h1 + have h2 := eval_codeUnpair₂ (Code.proj (2 : Fin 3)) _ _ hproj + rw [FFL.FirstOrder.Arithmetic.pi₂_pair] at h2 + have hone : + Semiformula.Evalb ((1 : M) :> ![s, qCode, FFL.FirstOrder.Arithmetic.pair z (a + 1)]) + (code (codeConst (n := 3) 1)) := + by rw [eval_codeConst_iff]; simp + have h3 := eval_codeSub _ (codeConst 1) (a + 1) 1 _ h2 hone + rw [add_sub_self] at h3 + have hz : + Semiformula.Evalb (z :> (x :> ![s, qCode, FFL.FirstOrder.Arithmetic.pair z (a + 1)])) + (code (codeLift (codeUnpair₁ (Code.proj (2 : Fin 3))))) := + (eval_codeLift_iff _ _ _ _).mpr h1 + have ha : + Semiformula.Evalb (a :> (x :> ![s, qCode, FFL.FirstOrder.Arithmetic.pair z (a + 1)])) + (code (codeLift (codeSub (codeUnpair₂ (Code.proj (2 : Fin 3))) (codeConst 1)))) := + (eval_codeLift_iff _ _ _ _).mpr h3 + have hx : + Semiformula.Evalb (x :> (x :> ![s, qCode, FFL.FirstOrder.Arithmetic.pair z (a + 1)])) + (code (codeHead (n := 3))) := + (eval_codeHead_iff _ _).mpr rfl + exact eval_codePair _ _ z _ _ hz (eval_codePair _ _ a x _ ha hx) + +/-- At a positive stage, zero-argument primitive recursion is the base program, +with the caller's argument bound imposed by the concrete evaluator. -/ +theorem evaln_tag_six_zero_iff [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (q : ℕ) + (hq : partrecCodeTag q = 6) (s z y : M) (hs : 0 < s) : + Semiformula.Evalb + ![s, (q : M), FFL.FirstOrder.Arithmetic.pair z 0, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) ↔ + FFL.FirstOrder.Arithmetic.pair z 0 < s ∧ + Semiformula.Evalb ![s, (partrecCodePayload₁ q : M), z, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) := by + let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := + models_of_subtheory + (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + -- the argument codes of the primitive-recursion branch of the dispatcher, named once + set dtable : Code 3 := codeEvaluatorHistoryBeforeCell with hdtable + set dk' : Code 3 := + codeSub (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell)) (codeConst 1) with + hdk' + set dq : Code 3 := codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell) with hdq + set dcf : Code 3 := + codePartrecPayload₁ (codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell)) with hdcf + set dcg : Code 3 := + codePartrecPayload₂ (codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell)) with hdcg + set dn : Code 3 := Code.proj (2 : Fin 3) with hdn + obtain ⟨Hs, hHs, _⟩ := + eval_codeEvaluatorHistoryBeforeCell_exists s (q : M) + (FFL.FirstOrder.Arithmetic.pair z 0) + have hidx_s := + eval_codeEvaluatorCell_index s (q : M) + (FFL.FirstOrder.Arithmetic.pair z 0) + have htag_s := tagSix_read_tag _ q hq _ hidx_s + have hn_s : + Semiformula.Evalb + (FFL.FirstOrder.Arithmetic.pair z 0 :> + ![s, (q : M), FFL.FirstOrder.Arithmetic.pair z 0]) + (code (Code.proj (2 : Fin 3))) := + (eval_proj_iff _ _ _).mpr rfl + have source_equivalence : + Semiformula.Evalb + ((y + 1) :> + ![s, ((q : ℕ) : M), FFL.FirstOrder.Arithmetic.pair z 0]) + (code (codePrecEvaluatorCell dtable dk' dq dcf dcg dn)) ↔ + Semiformula.Evalb + ((y + 1) :> + ![s, ((q : ℕ) : M), FFL.FirstOrder.Arithmetic.pair z 0]) + (code (codeTableLookup dtable (codeSucc dk') dcf (codeUnpair₁ dn))) := + eval_codePrecEvaluatorCell_succ_iff_of_zero dtable dk' dq dcf dcg dn Hs (s - 1) + ((q : ℕ) : M) ((partrecCodePayload₁ q : ℕ) : M) ((partrecCodePayload₂ q : ℕ) : M) z y + ![s, ((q : ℕ) : M), FFL.FirstOrder.Arithmetic.pair z 0] hHs + (tagSix_decremented_fuel s ((q : ℕ) : M) + (FFL.FirstOrder.Arithmetic.pair z 0)) + hidx_s (tagSix_read_payload₁ _ q hq _ hidx_s) (tagSix_read_payload₂ _ q hq _ hidx_s) hn_s + have lookup_equivalence : + Semiformula.Evalb + ((y + 1) :> + ![s, (q : M), FFL.FirstOrder.Arithmetic.pair z 0]) + (code (codeTableLookup dtable (codeSucc dk') dcf (codeUnpair₁ dn))) ↔ + Semiformula.Evalb ((y + 1) :> ![s, (q : M), z]) + (code + (codeTableLookup codeEvaluatorHistoryBeforeCell + (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell)) + (codeConst (n := 3) (partrecCodePayload₁ q)) (Code.proj (2 : Fin 3)))) := + eval_codeTableLookup_congr_at _ _ _ _ _ _ _ _ _ _ _ + (tagSix_table_congr s (q : M) + (FFL.FirstOrder.Arithmetic.pair z 0) z) + (tagSix_key_congr s (q : M) + (FFL.FirstOrder.Arithmetic.pair z 0) z hs) + (tagSix_query_congr s (FFL.FirstOrder.Arithmetic.pair z 0) z + q hq) + (tagSix_argument_congr s (q : M) z) + have payload₁_lt : partrecCodePayload₁ q < q := (partrecCodePayloads_lt_of_tag_six q hq).1 + have prefix_s : + FFL.FirstOrder.Arithmetic.pair s (partrecCodePayload₁ q : M) < + FFL.FirstOrder.Arithmetic.pair s (q : M) := + FFL.FirstOrder.Arithmetic.pair_lt_pair_right s + (by exact_mod_cast payload₁_lt) + constructor + · intro hc + have hh := + (evalnCertificateFormula_eval_history_iff s (q : M) + (FFL.FirstOrder.Arithmetic.pair z 0) y).mp + hc + obtain ⟨hu, hcell⟩ := + (eval_codeHistoryEvaluator_succ_iff_cell s (q : M) + (FFL.FirstOrder.Arithmetic.pair z 0) y).mp + hh + have hb := + tagSix_prec_branch _ _ _ (y + 1) s + (eval_codeEvaluatorCell_fuel s (q : M) + (FFL.FirstOrder.Arithmetic.pair z 0)) + hs htag_s hcell + have hl := lookup_equivalence.mp (source_equivalence.mp hb) + have hf := + eval_codeHistoryEvaluator_succ_of_prefix_lookup s (q : M) z y (partrecCodePayload₁ q) + prefix_s hl + exact + ⟨hu, (evalnCertificateFormula_eval_history_iff s (partrecCodePayload₁ q : M) z y).mpr hf⟩ + · rintro ⟨hu, hc⟩ + have hf := + (evalnCertificateFormula_eval_history_iff s (partrecCodePayload₁ q : M) z y).mp hc + have hl := + eval_prefix_lookup_succ_of_codeHistoryEvaluator s (q : M) z y (partrecCodePayload₁ q) + prefix_s hf + have hb := source_equivalence.mpr (lookup_equivalence.mpr hl) + obtain ⟨w, hw⟩ := + eval_codeEvaluatorCell_exists_of_values dtable dn Hs + (FFL.FirstOrder.Arithmetic.pair z 0) + ![s, (q : M), FFL.FirstOrder.Arithmetic.pair z 0] hHs hn_s + have hbw := + tagSix_prec_branch _ _ _ w s + (eval_codeEvaluatorCell_fuel s (q : M) + (FFL.FirstOrder.Arithmetic.pair z 0)) + hs htag_s hw + have hwy : w = y + 1 := eval_unique hbw hb + rw [hwy] at hw + exact + (evalnCertificateFormula_eval_history_iff s (q : M) + (FFL.FirstOrder.Arithmetic.pair z 0) y).mpr + ((eval_codeHistoryEvaluator_succ_iff_cell s (q : M) + (FFL.FirstOrder.Arithmetic.pair z 0) y).mpr + ⟨hu, hw⟩) + +/-- A successor recursion computation at stage `k + 1` consists of the +predecessor computation at stage `k` and the step computation at stage `k + 1`. -/ +theorem evaln_tag_six_succ_iff [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (q : ℕ) + (hq : partrecCodeTag q = 6) (k z a y : M) : + Semiformula.Evalb + ![k + 1, (q : M), + FFL.FirstOrder.Arithmetic.pair z (a + 1), y] + (evalnCertificateFormula : ArithmeticSemisentence 4) ↔ + FFL.FirstOrder.Arithmetic.pair z (a + 1) < k + 1 ∧ + ∃ x : M, + Semiformula.Evalb + ![k, (q : M), FFL.FirstOrder.Arithmetic.pair z a, x] + (evalnCertificateFormula : ArithmeticSemisentence 4) ∧ + Semiformula.Evalb + ![k + 1, (partrecCodePayload₂ q : M), + FFL.FirstOrder.Arithmetic.pair z + (FFL.FirstOrder.Arithmetic.pair a x), + y] + (evalnCertificateFormula : ArithmeticSemisentence 4) := by + let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := + models_of_subtheory + (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + -- the argument codes of the primitive-recursion branch, named once + set dtable : Code 3 := codeEvaluatorHistoryBeforeCell with hdtable + set dk' : Code 3 := + codeSub (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell)) (codeConst 1) with + hdk' + set dq : Code 3 := codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell) with hdq + set dcf : Code 3 := + codePartrecPayload₁ (codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell)) with hdcf + set dcg : Code 3 := + codePartrecPayload₂ (codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell)) with hdcg + set dn : Code 3 := Code.proj (2 : Fin 3) with hdn + set u : M := FFL.FirstOrder.Arithmetic.pair z (a + 1) with hu + have hs : (0 : M) < k + 1 := + lt_of_le_of_lt (FFL.FirstOrder.Arithmetic.zero_le k) + (lt_add_one k) + -- readings at the source stage + obtain ⟨Hs, hHs, hHistS⟩ := eval_codeEvaluatorHistoryBeforeCell_exists (k + 1) ((q : ℕ) : M) u + have hidx_s := eval_codeEvaluatorCell_index (k + 1) ((q : ℕ) : M) u + have htag_s := tagSix_read_tag _ q hq _ hidx_s + have hn_s : Semiformula.Evalb (u :> ![k + 1, ((q : ℕ) : M), u]) (code dn) := + (eval_proj_iff _ _ _).mpr rfl + have source_equivalence : + Semiformula.Evalb ((y + 1) :> ![k + 1, ((q : ℕ) : M), u]) + (code (codePrecEvaluatorCell dtable dk' dq dcf dcg dn)) ↔ + ∃ x : M, + Semiformula.Evalb ((x + 1) :> ![k + 1, ((q : ℕ) : M), u]) + (code + (codeTableLookup dtable dk' dq + (codePair (codeUnpair₁ dn) (codeSub (codeUnpair₂ dn) (codeConst 1))))) ∧ + Semiformula.Evalb ((y + 1) :> x :> ![k + 1, ((q : ℕ) : M), u]) + (code + (codeTableLookup (codeLift dtable) (codeLift (codeSucc dk')) (codeLift dcg) + (codePair (codeLift (codeUnpair₁ dn)) + (codePair (codeLift (codeSub (codeUnpair₂ dn) (codeConst 1))) + (codeHead (n := 3)))))) := + eval_codePrecEvaluatorCell_succ_iff_of_succ dtable dk' dq dcf dcg dn Hs (k + 1 - 1) + ((q : ℕ) : M) ((partrecCodePayload₁ q : ℕ) : M) ((partrecCodePayload₂ q : ℕ) : M) z a y + ![k + 1, ((q : ℕ) : M), u] hHs (tagSix_decremented_fuel (k + 1) ((q : ℕ) : M) u) hidx_s + (tagSix_read_payload₁ _ q hq _ hidx_s) (tagSix_read_payload₂ _ q hq _ hidx_s) hn_s + have hpayload₂_lt : partrecCodePayload₂ q < q := (partrecCodePayloads_lt_of_tag_six q hq).2 + have hrow_step : + ∀ s : M, + FFL.FirstOrder.Arithmetic.pair s + ((partrecCodePayload₂ q : ℕ) : M) < + FFL.FirstOrder.Arithmetic.pair s ((q : ℕ) : M) := + fun s => + FFL.FirstOrder.Arithmetic.pair_lt_pair_right s + (by exact_mod_cast hpayload₂_lt) + have hstep_bridge (x : M) : + ∀ s : M, + (0 : M) < s → + ∀ H : M, + Semiformula.Evalb (H :> ![s, ((q : ℕ) : M), u]) (code dtable) → + Semiformula.Evalb + ![H, + FFL.FirstOrder.Arithmetic.pair s ((q : ℕ) : M)] + (code codeEvaluatorHistory) → + (Semiformula.Evalb ((y + 1) :> x :> ![s, ((q : ℕ) : M), u]) + (code + (codeTableLookup (codeLift dtable) (codeLift (codeSucc dk')) (codeLift dcg) + (codePair (codeLift (codeUnpair₁ dn)) + (codePair (codeLift (codeSub (codeUnpair₂ dn) (codeConst 1))) + (codeHead (n := 3)))))) ↔ + Semiformula.Evalb + ![y + 1, s, ((partrecCodePayload₂ q : ℕ) : M), + FFL.FirstOrder.Arithmetic.pair z + (FFL.FirstOrder.Arithmetic.pair a x)] + (code codeHistoryEvaluator)) := + by + intro s hspos H hH hHist + exact + eval_codeTableLookup_succ_iff_codeHistoryEvaluator_of_history (codeLift dtable) + (codeLift (codeSucc dk')) (codeLift dcg) _ (x :> ![s, ((q : ℕ) : M), u]) + (FFL.FirstOrder.Arithmetic.pair s ((q : ℕ) : M)) H s + (FFL.FirstOrder.Arithmetic.pair z + (FFL.FirstOrder.Arithmetic.pair a x)) + y (partrecCodePayload₂ q) hHist (hrow_step s) ((eval_codeLift_iff _ _ _ _).mpr hH) + ((eval_codeLift_iff _ _ _ _).mpr (tagSix_base_key s ((q : ℕ) : M) u hspos)) + ((eval_codeLift_iff _ _ _ _).mpr + (tagSix_read_payload₂ _ q hq _ (eval_codeEvaluatorCell_index s ((q : ℕ) : M) u))) + (tagSix_step_argument s ((q : ℕ) : M) z a x) + constructor + · intro hc + have hh := (evalnCertificateFormula_eval_history_iff (k + 1) (q : M) u y).mp hc + obtain ⟨hu, hcell⟩ := (eval_codeHistoryEvaluator_succ_iff_cell (k + 1) (q : M) u y).mp hh + have hb := + tagSix_prec_branch _ _ _ (y + 1) (k + 1) (eval_codeEvaluatorCell_fuel (k + 1) (q : M) u) + hs htag_s hcell + obtain ⟨x, hp, hg⟩ := source_equivalence.mp hb + have hph := (eval_prec_predecessor_lookup_succ_iff_codeHistoryEvaluator k z a x q).mp hp + have hgh := (hstep_bridge x (k + 1) hs Hs hHs hHistS).mp hg + exact + ⟨hu, x, + (evalnCertificateFormula_eval_history_iff k (q : M) + (FFL.FirstOrder.Arithmetic.pair z a) x).mpr + hph, + (evalnCertificateFormula_eval_history_iff (k + 1) (partrecCodePayload₂ q : M) + (FFL.FirstOrder.Arithmetic.pair z + (FFL.FirstOrder.Arithmetic.pair a x)) + y).mpr + hgh⟩ + · rintro ⟨hu, x, hp, hg⟩ + have hph := + (evalnCertificateFormula_eval_history_iff k (q : M) + (FFL.FirstOrder.Arithmetic.pair z a) x).mp + hp + have hgh := + (evalnCertificateFormula_eval_history_iff (k + 1) (partrecCodePayload₂ q : M) + (FFL.FirstOrder.Arithmetic.pair z + (FFL.FirstOrder.Arithmetic.pair a x)) + y).mp + hg + have hpl := (eval_prec_predecessor_lookup_succ_iff_codeHistoryEvaluator k z a x q).mpr hph + have hgl := (hstep_bridge x (k + 1) hs Hs hHs hHistS).mpr hgh + have hb := source_equivalence.mpr ⟨x, hpl, hgl⟩ + obtain ⟨w, hw⟩ := + eval_codeEvaluatorCell_exists_of_values dtable dn Hs u ![k + 1, (q : M), u] hHs hn_s + have hbw := + tagSix_prec_branch _ _ _ w (k + 1) (eval_codeEvaluatorCell_fuel (k + 1) (q : M) u) hs + htag_s hw + have hwy : w = y + 1 := eval_unique hbw hb + rw [hwy] at hw + exact + (evalnCertificateFormula_eval_history_iff (k + 1) (q : M) u y).mpr + ((eval_codeHistoryEvaluator_succ_iff_cell (k + 1) (q : M) u y).mpr ⟨hu, hw⟩) + +/-- Primitive recursion at zero realizes the base graph in every PA model. -/ +theorem eventualGraph_prec_zero_eval [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (fCode gCode : ℕ) + (z y : M) : + (eventualGraph (canonicalPartrecPrecIndex fCode gCode)).val.Evalb + ![FFL.FirstOrder.Arithmetic.pair z 0, y] ↔ + (eventualGraph fCode).val.Evalb ![z, y] := + by + have : M↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + let q := canonicalPartrecPrecIndex fCode gCode + have hq : partrecCodeTag q = 6 := canonicalPartrecPrecIndex_constructor_number fCode gCode + have hf : partrecCodePayload₁ q = fCode := canonicalPartrecPrecIndex_base_index fCode gCode + constructor + · intro h + obtain ⟨s, hs⟩ := (eventualGraph_eval q _).mp h + simp only [numeral_eq_natCast_app, Matrix.cons_val_zero, Matrix.cons_val_one] at hs + have hu := + ((eval_codeHistoryEvaluator_succ_iff_cell s (q : M) (FFL.FirstOrder.Arithmetic.pair z 0) + y).mp + ((evalnCertificateFormula_eval_history_iff s (q : M) + (FFL.FirstOrder.Arithmetic.pair z 0) y).mp + hs)).1 + have hpos : (0 : M) < s := lt_of_le_of_lt (FFL.FirstOrder.Arithmetic.zero_le _) hu + have hc := ((evaln_tag_six_zero_iff q hq s z y hpos).mp hs).2 + rw [hf] at hc + exact + (eventualGraph_eval fCode _).mpr + ⟨s, by + simpa only [numeral_eq_natCast_app, Matrix.cons_val_zero, Matrix.cons_val_one] using + hc⟩ + · intro h + obtain ⟨s, hs⟩ := (eventualGraph_eval fCode _).mp h + simp only [numeral_eq_natCast_app, Matrix.cons_val_zero, Matrix.cons_val_one] at hs + let t := s + FFL.FirstOrder.Arithmetic.pair z 0 + 1 + have hst : s ≤ t := le_trans le_self_add (le_of_lt (lt_add_one _)) + have hu : FFL.FirstOrder.Arithmetic.pair z 0 < t := + lt_of_le_of_lt le_add_self (lt_add_one _) + have hpos : (0 : M) < t := lt_of_le_of_lt (FFL.FirstOrder.Arithmetic.zero_le _) hu + have hc := evalnCertificateFormula_natCode_persist fCode s t z y hst hs + rw [← hf] at hc + have hr := (evaln_tag_six_zero_iff q hq t z y hpos).mpr ⟨hu, hc⟩ + exact + (eventualGraph_eval q _).mpr + ⟨t, by + simpa only [numeral_eq_natCast_app, Matrix.cons_val_zero, Matrix.cons_val_one] using + hr⟩ + +/-- Primitive recursion at a successor realizes the predecessor-then-step +graph in every PA model. The recursion argument may be nonstandard. -/ +theorem eventualGraph_prec_succ_eval [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (fCode gCode : ℕ) + (z a y : M) : + (eventualGraph (canonicalPartrecPrecIndex fCode gCode)).val.Evalb + ![FFL.FirstOrder.Arithmetic.pair z (a + 1), y] ↔ + ∃ x : M, + (eventualGraph (canonicalPartrecPrecIndex fCode gCode)).val.Evalb + ![FFL.FirstOrder.Arithmetic.pair z a, x] ∧ + (eventualGraph gCode).val.Evalb + ![FFL.FirstOrder.Arithmetic.pair z (FFL.FirstOrder.Arithmetic.pair a x), y] := + by + have : M↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + let q := canonicalPartrecPrecIndex fCode gCode + have hq : partrecCodeTag q = 6 := canonicalPartrecPrecIndex_constructor_number fCode gCode + have hg : partrecCodePayload₂ q = gCode := canonicalPartrecPrecIndex_step_index fCode gCode + constructor + · intro h + obtain ⟨s, hs⟩ := (eventualGraph_eval q _).mp h + simp only [numeral_eq_natCast_app, Matrix.cons_val_zero, Matrix.cons_val_one] at hs + have hu := + ((eval_codeHistoryEvaluator_succ_iff_cell s (q : M) + (FFL.FirstOrder.Arithmetic.pair z (a + 1)) y).mp + ((evalnCertificateFormula_eval_history_iff s (q : M) + (FFL.FirstOrder.Arithmetic.pair z (a + 1)) y).mp + hs)).1 + have hpos : (0 : M) < s := lt_of_le_of_lt (FFL.FirstOrder.Arithmetic.zero_le _) hu + have hpred : s - 1 + 1 = s := tagSix_succ_pred hpos + have hh := evaln_tag_six_succ_iff q hq (s - 1) z a y + rw [hpred] at hh + obtain ⟨_, x, hp, hf⟩ := hh.mp hs + rw [hg] at hf + exact + ⟨x, + (eventualGraph_eval q _).mpr + ⟨s - 1, by + simpa only [numeral_eq_natCast_app, Matrix.cons_val_zero, Matrix.cons_val_one] using + hp⟩, + (eventualGraph_eval gCode _).mpr + ⟨s, by + simpa only [numeral_eq_natCast_app, Matrix.cons_val_zero, Matrix.cons_val_one] using + hf⟩⟩ + · rintro ⟨x, hp, hf⟩ + obtain ⟨s, hs⟩ := (eventualGraph_eval q _).mp hp + obtain ⟨t, ht⟩ := (eventualGraph_eval gCode _).mp hf + simp only [numeral_eq_natCast_app, Matrix.cons_val_zero, Matrix.cons_val_one] at hs ht + let k := s + t + FFL.FirstOrder.Arithmetic.pair z (a + 1) + have hsk : s ≤ k := le_trans le_self_add le_self_add + have htk : t ≤ k + 1 := + le_trans (le_trans le_add_self le_self_add) (le_of_lt (lt_add_one _)) + have hu : FFL.FirstOrder.Arithmetic.pair z (a + 1) < k + 1 := + lt_of_le_of_lt le_add_self (lt_add_one _) + have hs' := + evalnCertificateFormula_natCode_persist q s k (FFL.FirstOrder.Arithmetic.pair z a) x hsk + hs + have ht' := + evalnCertificateFormula_natCode_persist gCode t (k + 1) + (FFL.FirstOrder.Arithmetic.pair z (FFL.FirstOrder.Arithmetic.pair a x)) y htk ht + rw [← hg] at ht' + have hr := (evaln_tag_six_succ_iff q hq k z a y).mpr ⟨hu, x, hs', ht'⟩ + exact + (eventualGraph_eval q _).mpr + ⟨k + 1, by + simpa only [numeral_eq_natCast_app, Matrix.cons_val_zero, Matrix.cons_val_one] using + hr⟩ + +end ConcreteEvaluator +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteWeakTotality.lean b/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteWeakTotality.lean new file mode 100644 index 000000000..c4e592cc9 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteWeakTotality.lean @@ -0,0 +1,201 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteIndexObstruction + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +Concrete weak-totality witnesses for the manuscript's external pointwise +provability relation. The guard agrees pointwise with identity, but annihilates +a search program that is not provably empty. Consequently weak totality cannot +be assigned to the pointwise quotient independently of a representative. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic FFL.Entailment + +open CategoricalRiceShapiro.PartialRecursive + +namespace FailureOfComposition +namespace ConcreteIndices + +open ProofSearch ConcreteEvaluator HistoryWitnesses ProgramIndices + +open ConcreteEmptyGraph + +/-- The manuscript's weak-totality predicate on concrete program indices. -/ +def WeaklyTotalIndex (T : ArithmeticTheory) (e : ℕ) : Prop := + ∀ d, + PointwiseIndex T (canonicalPartrecCompIndex e d) concreteEmptyIndex → + PointwiseIndex T d concreteEmptyIndex + +/-- Identity is a left identity for the external pointwise index relation. -/ +theorem identity_comp_pointwiseIndex (T : ArithmeticTheory) [𝐏𝐀 ≼ T] (e : ℕ) : + PointwiseIndex T (canonicalPartrecCompIndex Kleene.identityIndex e) e := + by + have hRefl : Uniform 𝐏𝐀 (eventualGraph e) (eventualGraph e) := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + simp [models_iff, uniformSentence] + have eqv := pointwise_equivalence T + apply (pointwiseIndex_iff T _ _).mpr + exact + eqv.trans (uniform_to_pointwise T (eventualGraph_composition _ _)) + (eqv.trans (uniform_to_pointwise T (uniform_comp eventualGraph_identity hRefl)) + (uniform_to_pointwise T (identity_comp (eventualGraph e)))) + +/-- Every standard instance of the divergent guard agrees provably with identity. -/ +theorem guardIndex_pointwise_identity (T : ArithmeticTheory) [𝐏𝐀 ≼ T] (d : ℕ) + (hdiv : ¬diagonalHistoryFormula.Evalb ![d]) : + PointwiseIndex T (guardIndex d) Kleene.identityIndex := + by + have eqv := pointwise_equivalence T + apply (pointwiseIndex_iff T _ _).mpr + exact + eqv.trans (uniform_to_pointwise T (guardIndex_realizes d)) + (eqv.trans (guard_pointwise_identity T d hdiv) + (eqv.symm (uniform_to_pointwise T eventualGraph_identity))) + +/-- The guard annihilates its associated least-success search in PA. -/ +theorem guard_search_pointwise_empty (T : ArithmeticTheory) [𝐏𝐀 ≼ T] (d : ℕ) : + PointwiseIndex T (canonicalPartrecCompIndex (guardIndex d) (searchIndex d)) + concreteEmptyIndex := + by + have eqv := pointwise_equivalence T + apply (pointwiseIndex_iff T _ _).mpr + exact + eqv.trans (uniform_to_pointwise T (eventualGraph_composition _ _)) + (eqv.trans + (uniform_to_pointwise T (uniform_comp (guardIndex_realizes d) (searchIndex_realizes d))) + (eqv.trans (uniform_to_pointwise T (HistoryWitnesses.guard_search_empty d)) + (eqv.symm (uniform_to_pointwise T eventualGraph_empty)))) + +/-- Proving the search empty would prove the chosen divergence sentence. -/ +theorem searchIndex_not_pointwise_empty (T : ArithmeticTheory) [𝐏𝐀 ≼ T] (d : ℕ) + (hnot : T ⊬ ∼diagonalHistoryFormula/[d]) : + ¬PointwiseIndex T (searchIndex d) concreteEmptyIndex := + by + intro h + have eqv := pointwise_equivalence T + have hs : Pointwise T (searchGraph d) empty := + eqv.trans (eqv.symm (uniform_to_pointwise T (searchIndex_realizes d))) + (eqv.trans ((pointwiseIndex_iff T _ _).mp h) (uniform_to_pointwise T eventualGraph_empty)) + exact hnot (Entailment.mdp (WeakerThan.pbl (search_empty_implies_absence d)) (hs 0)) + +/-- All four concrete witnesses used for composition and weak-totality failure. -/ +theorem index_four_witnesses_of_history_divergence (T : ArithmeticTheory) [𝐏𝐀 ≼ T] (d : ℕ) + (hdiv : ¬diagonalHistoryFormula.Evalb ![d]) (hnot : T ⊬ ∼diagonalHistoryFormula/[d]) : + PointwiseIndex T (guardIndex d) Kleene.identityIndex ∧ + PointwiseIndex T (canonicalPartrecCompIndex (guardIndex d) (searchIndex d)) + concreteEmptyIndex ∧ + PointwiseIndex T (canonicalPartrecCompIndex Kleene.identityIndex (searchIndex d)) + (searchIndex d) ∧ + ¬PointwiseIndex T (searchIndex d) concreteEmptyIndex := + ⟨guardIndex_pointwise_identity T d hdiv, guard_search_pointwise_empty T d, + identity_comp_pointwiseIndex T (searchIndex d), searchIndex_not_pointwise_empty T d hnot⟩ + +/-- Identity is weakly total without any consistency or enumerability hypothesis. -/ +theorem weaklyTotalIndex_identity (T : ArithmeticTheory) [𝐏𝐀 ≼ T] : + WeaklyTotalIndex T Kleene.identityIndex := + weaklyTotal_identity (indexSetoid T) canonicalPartrecCompIndex Kleene.identityIndex + concreteEmptyIndex (identity_comp_pointwiseIndex T) + +/-- The search witness refutes weak totality of the guard. -/ +theorem not_weaklyTotalIndex_guard (T : ArithmeticTheory) [𝐏𝐀 ≼ T] (d : ℕ) + (hnot : T ⊬ ∼diagonalHistoryFormula/[d]) : ¬WeaklyTotalIndex T (guardIndex d) := + not_weaklyTotal_guard (indexSetoid T) canonicalPartrecCompIndex (guardIndex d) (searchIndex d) + concreteEmptyIndex (guard_search_pointwise_empty T d) + (searchIndex_not_pointwise_empty T d hnot) + +/-- A true unprovable divergence gives equivalent indices of different weak totality. -/ +theorem weak_totality_counterexample_of_history_divergence (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (d : ℕ) (hdiv : ¬diagonalHistoryFormula.Evalb ![d]) + (hnot : T ⊬ ∼diagonalHistoryFormula/[d]) : + PointwiseIndex T (guardIndex d) Kleene.identityIndex ∧ + ¬WeaklyTotalIndex T (guardIndex d) ∧ WeaklyTotalIndex T Kleene.identityIndex := + ⟨guardIndex_pointwise_identity T d hdiv, not_weaklyTotalIndex_guard T d hnot, + weaklyTotalIndex_identity T⟩ + +/-- Productiveness supplies a concrete counterexample for every consistent +extension of PA with recursively enumerable theorem codes. -/ +theorem weak_totality_counterexample_via_productiveness (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + [Consistent T] (hT : REPred (TheoremCodes T)) : + ∃ d, + PointwiseIndex T (guardIndex d) Kleene.identityIndex ∧ + ¬WeaklyTotalIndex T (guardIndex d) ∧ WeaklyTotalIndex T Kleene.identityIndex := + by + obtain ⟨d, hdiv, hnot⟩ := exists_true_unprovable_history_divergence_of_theorem_codes T hT + exact ⟨d, weak_totality_counterexample_of_history_divergence T d hdiv hnot⟩ + +/-- The decidable axiom-presentation specialization. -/ +theorem weak_totality_counterexample_of_delta_one (T : ArithmeticTheory) [T.Δ₁] [𝐏𝐀 ≼ T] + [Consistent T] : + ∃ d, + PointwiseIndex T (guardIndex d) Kleene.identityIndex ∧ + ¬WeaklyTotalIndex T (guardIndex d) ∧ WeaklyTotalIndex T Kleene.identityIndex := + by + obtain ⟨d, hdiv, hnot⟩ := exists_true_unprovable_history_divergence T + exact ⟨d, weak_totality_counterexample_of_history_divergence T d hdiv hnot⟩ + +/-- Recursively enumerable axiom codes suffice for weak-totality failure. -/ +theorem weak_totality_counterexample_of_re_axioms (T : ArithmeticTheory) [𝐏𝐀 ≼ T] [Consistent T] + (hT : REPred (AxiomCodes T)) : + ∃ d, + PointwiseIndex T (guardIndex d) Kleene.identityIndex ∧ + ¬WeaklyTotalIndex T (guardIndex d) ∧ WeaklyTotalIndex T Kleene.identityIndex := + weak_totality_counterexample_via_productiveness T (theorem_codes_re_of_axiom_codes T hT) + +/-- The explicit program enumeration of axioms used in the manuscript. -/ +theorem weak_totality_counterexample_of_axiom_enumerator (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + [Consistent T] (a : ℕ) (ha : ∀ n : ℕ, AxiomCodes T n ↔ ∃ x : ℕ, n ∈ Kleene.eval a x) : + ∃ d, + PointwiseIndex T (guardIndex d) Kleene.identityIndex ∧ + ¬WeaklyTotalIndex T (guardIndex d) ∧ WeaklyTotalIndex T Kleene.identityIndex := + weak_totality_counterexample_of_re_axioms T (axiom_codes_re_of_program_enumerator T a ha) + +/-- No predicate on the pointwise quotient represents weak totality of its indices. -/ +theorem no_quotient_weak_totality_of_history_divergence (T : ArithmeticTheory) [𝐏𝐀 ≼ T] (d : ℕ) + (hdiv : ¬diagonalHistoryFormula.Evalb ![d]) (hnot : T ⊬ ∼diagonalHistoryFormula/[d]) : + ¬∃ P : Quotient (indexSetoid T) → Prop, + ∀ e, P (Quotient.mk (indexSetoid T) e) ↔ WeaklyTotalIndex T e := + by + rintro ⟨P, hP⟩ + apply not_weaklyTotalIndex_guard T d hnot + apply (hP (guardIndex d)).mp + have hEq : + Quotient.mk (indexSetoid T) (guardIndex d) = + Quotient.mk (indexSetoid T) Kleene.identityIndex := + Quotient.sound (guardIndex_pointwise_identity T d hdiv) + rw [hEq] + exact (hP Kleene.identityIndex).mpr (weaklyTotalIndex_identity T) + +/-- Weak totality does not descend for any consistent recursively axiomatized +extension of PA. -/ +theorem no_quotient_weak_totality_of_re_axioms (T : ArithmeticTheory) [𝐏𝐀 ≼ T] [Consistent T] + (hT : REPred (AxiomCodes T)) : + ¬∃ P : Quotient (indexSetoid T) → Prop, + ∀ e, P (Quotient.mk (indexSetoid T) e) ↔ WeaklyTotalIndex T e := + by + obtain ⟨d, hdiv, hnot⟩ := + exists_true_unprovable_history_divergence_of_theorem_codes T + (theorem_codes_re_of_axiom_codes T hT) + exact no_quotient_weak_totality_of_history_divergence T d hdiv hnot + +end ConcreteIndices +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteWitnessGraphs.lean b/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteWitnessGraphs.lean new file mode 100644 index 000000000..0c0d3cebc --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteWitnessGraphs.lean @@ -0,0 +1,277 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.Certificate +public import LeanPool.PointwiseComposition.FailureOfComposition.ComputationSearchIndices + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +PA-model equations for the four base program indices of the repository's +arithmetized Mathlib evaluator. These equations quantify over all elements of +an arbitrary PA model, including the fuel and input; they are not merely +standard-natural-number equations. +-/ + +@[expose] public section + +open _root_.Nat Nat Nat.ArithPart₁ + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +open scoped FFL.FirstOrder.Arithmetic + +open CategoricalRiceShapiro.ArithmeticCode + +open CategoricalRiceShapiro.Evaluator + +namespace FailureOfComposition +namespace ConcreteWitnessGraphs + +variable {M : Type*} [ORingStructure M] + +private theorem positive_branch [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (a b c : Code r) (v : Fin r → M) + (z k : M) (ha : Semiformula.Evalb (k :> v) (code a)) (hk : 0 < k) + (h : Semiformula.Evalb (z :> v) (code (codeIfPos a b c))) : + Semiformula.Evalb (z :> v) (code b) := + by + obtain ⟨k', hk', hh⟩ := eval_codeIfPos_cases a b c z v h + have he : k' = k := eval_unique hk' ha + rcases hh with ⟨_, hb⟩ | ⟨hz, _⟩ + · exact hb + · exact False.elim ((ne_of_gt hk) (he ▸ hz)) + +private theorem zero_branch [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (a b c : Code r) (v : Fin r → M) (z : M) + (ha : Semiformula.Evalb ((0 : M) :> v) (code a)) + (h : Semiformula.Evalb (z :> v) (code (codeIfPos a b c))) : + Semiformula.Evalb (z :> v) (code c) := + by + obtain ⟨k', hk', hh⟩ := eval_codeIfPos_cases a b c z v h + have he : k' = 0 := eval_unique hk' ha + rcases hh with ⟨hp, _⟩ | ⟨_, hc⟩ + · exact False.elim ((_root_.lt_irrefl (0 : M)) (he ▸ hp)) + · exact hc + +private theorem equal_branch [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (a b c : Code r) (v : Fin r → M) (z : M) + (q : ℕ) (ha : Semiformula.Evalb ((q : M) :> v) (code a)) + (h : Semiformula.Evalb (z :> v) (code (codeIfPos (codeEq a (codeConst q)) b c))) : + Semiformula.Evalb (z :> v) (code b) := + by + apply positive_branch _ _ _ v z 1 _ _root_.zero_lt_one h + exact (eval_codeEq_iff _ _ _ v).mpr ⟨q, q, ha, eval_codeConst q v, Or.inl ⟨rfl, rfl⟩⟩ + +private theorem unequal_branch [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (a b c : Code r) (v : Fin r → M) (z : M) + (q n : ℕ) (hqn : q ≠ n) (ha : Semiformula.Evalb ((q : M) :> v) (code a)) + (h : Semiformula.Evalb (z :> v) (code (codeIfPos (codeEq a (codeConst n)) b c))) : + Semiformula.Evalb (z :> v) (code c) := + by + apply zero_branch _ _ _ v z _ h + refine (eval_codeEq_iff _ _ _ v).mpr ⟨q, n, ha, eval_codeConst n v, Or.inr ⟨?_, rfl⟩⟩ + exact_mod_cast hqn + +/-- The tag decoder agrees with the index below four in every PA model. -/ +theorem eval_base_tag [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) (hq : q < 4) + (v : Fin r → M) (hd : Semiformula.Evalb ((q : M) :> v) (code d)) : + Semiformula.Evalb ((q : M) :> v) (code (codePartrecTag d)) := + by + obtain ⟨z, hz⟩ := eval_codePartrecTag_exists_of_value d (q : M) v hd + have hlt : Semiformula.Evalb ((1 : M) :> v) (code (codeLt d (codeConst 4))) := + by + refine (eval_codeLt_iff _ _ _ v).mpr ⟨q, (4 : ℕ), hd, eval_codeConst 4 v, Or.inl ⟨?_, rfl⟩⟩ + exact_mod_cast hq + have hd' := + positive_branch _ _ _ v z 1 hlt _root_.zero_lt_one + (show Semiformula.Evalb (z :> v) (code (codeIfPos (codeLt d (codeConst 4)) d _)) from hz) + have hzq : z = q := eval_unique hd' hd + simpa only [hzq] using hz + +/-- Output of the four base programs, interpreted in an arbitrary PA model. -/ +noncomputable def baseOutput [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (q : ℕ) (u : M) : M := + if q = 0 then 0 + else + if q = 1 then u + 1 + else if q = 2 then FFL.FirstOrder.Arithmetic.pi₁ u else FFL.FirstOrder.Arithmetic.pi₂ u + +private theorem cell_base_branch [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (dtable dn : Code r) + (v : Fin r → M) (z k : M) (q : ℕ) (hq : q < 4) + (hk : Semiformula.Evalb (k :> v) (code (codeUnpair₁ (codeListLength dtable)))) + (hkpos : 0 < k) + (hindex : Semiformula.Evalb ((q : M) :> v) (code (codeUnpair₂ (codeListLength dtable)))) + (hcell : Semiformula.Evalb (z :> v) (code (codeEvaluatorCell dtable dn))) : + Semiformula.Evalb (z :> v) (code (codeBaseEvaluatorCell dtable dn)) := + by + have htag := eval_base_tag _ q hq v hindex + simp only [codeEvaluatorCell] at hcell + have h0 := positive_branch _ _ _ v z k hk hkpos hcell + have h4 := unequal_branch _ _ _ v z q 4 (by omega) htag h0 + have h5 := unequal_branch _ _ _ v z q 5 (by omega) htag h4 + have h6 := unequal_branch _ _ _ v z q 6 (by omega) htag h5 + exact unequal_branch _ _ _ v z q 7 (by omega) htag h6 + +private theorem cell_base_value [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] {r : ℕ} (dtable dn : Code r) + (v : Fin r → M) (z k u : M) (q : ℕ) (hq : q < 4) + (hk : Semiformula.Evalb (k :> v) (code (codeUnpair₁ (codeListLength dtable)))) + (hkpos : 0 < k) + (hindex : Semiformula.Evalb ((q : M) :> v) (code (codeUnpair₂ (codeListLength dtable)))) + (hu : Semiformula.Evalb (u :> v) (code dn)) + (hcell : Semiformula.Evalb (z :> v) (code (codeEvaluatorCell dtable dn))) : + z = baseOutput q u + 1 := + by + have htag := eval_base_tag _ q hq v hindex + have hbase := cell_base_branch dtable dn v z k q hq hk hkpos hindex hcell + simp only [codeBaseEvaluatorCell] at hbase + have h0 := positive_branch _ _ _ v z k hk hkpos hbase + rcases (by omega : q = 0 ∨ q = 1 ∨ q = 2 ∨ q = 3) with rfl | rfl | rfl | rfl + · have hz := equal_branch _ _ _ v z 0 htag h0 + have hval := (eval_codeConst_iff 1 z v).mp hz + simpa [baseOutput] using hval + · have h1 := unequal_branch _ _ _ v z 1 0 (by decide) htag h0 + have hz := equal_branch _ _ _ v z 1 htag h1 + have hs : Semiformula.Evalb ((u + 1) :> v) (code (codeSucc dn)) := + (eval_codeSucc_iff _ _ _).mpr ⟨u, hu, rfl⟩ + have hss : Semiformula.Evalb (((u + 1) + 1) :> v) (code (codeSucc (codeSucc dn))) := + (eval_codeSucc_iff _ _ _).mpr ⟨u + 1, hs, rfl⟩ + simpa [baseOutput] using eval_unique hz hss + · have h1 := unequal_branch _ _ _ v z 2 0 (by decide) htag h0 + have h2 := unequal_branch _ _ _ v z 2 1 (by decide) htag h1 + have hz := equal_branch _ _ _ v z 2 htag h2 + have hp := eval_codeUnpair₁ dn u v hu + have hs : + Semiformula.Evalb ((FFL.FirstOrder.Arithmetic.pi₁ u + 1) :> v) + (code (codeSucc (codeUnpair₁ dn))) := + (eval_codeSucc_iff _ _ _).mpr ⟨_, hp, rfl⟩ + simpa [baseOutput] using eval_unique hz hs + · have h1 := unequal_branch _ _ _ v z 3 0 (by decide) htag h0 + have h2 := unequal_branch _ _ _ v z 3 1 (by decide) htag h1 + have h3 := unequal_branch _ _ _ v z 3 2 (by decide) htag h2 + have hz := equal_branch _ _ _ v z 3 htag h3 + have hp := eval_codeUnpair₂ dn u v hu + have hs : + Semiformula.Evalb ((FFL.FirstOrder.Arithmetic.pi₂ u + 1) :> v) + (code (codeSucc (codeUnpair₂ dn))) := + (eval_codeSucc_iff _ _ _).mpr ⟨_, hp, rfl⟩ + simpa [baseOutput] using eval_unique hz hs + +/-- Exact graph equation for every base program and arbitrary model arguments. -/ +theorem base_computation_iff [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (q : ℕ) (hq : q < 4) + (s u y : M) : + Semiformula.Evalb ![s, (q : M), u, y] (evalnCertificateFormula : ArithmeticSemisentence 4) ↔ + u < s ∧ y = baseOutput q u := + by + rw [evalnCertificateFormula_eval_history_iff, eval_codeHistoryEvaluator_succ_iff_cell] + constructor + · rintro ⟨hus, hcell⟩ + have hs : 0 < s := lt_of_le_of_lt (FFL.FirstOrder.Arithmetic.zero_le u) hus + have he := + cell_base_value codeEvaluatorHistoryBeforeCell (Code.proj (2 : Fin 3)) ![s, (q : M), u] + (y + 1) s u q hq (eval_codeEvaluatorCell_fuel s (q : M) u) hs + (eval_codeEvaluatorCell_index s (q : M) u) ((eval_proj_iff _ _ _).mpr rfl) hcell + exact ⟨hus, add_right_cancel he⟩ + · rintro ⟨hus, rfl⟩ + have hs : 0 < s := lt_of_le_of_lt (FFL.FirstOrder.Arithmetic.zero_le u) hus + obtain ⟨H, hH, _⟩ := eval_codeEvaluatorHistoryBeforeCell_exists s (q : M) u + obtain ⟨z, hz⟩ := + eval_codeEvaluatorCell_exists_of_values codeEvaluatorHistoryBeforeCell + (Code.proj (2 : Fin 3)) H u ![s, (q : M), u] hH ((eval_proj_iff _ _ _).mpr rfl) + have he := + cell_base_value codeEvaluatorHistoryBeforeCell (Code.proj (2 : Fin 3)) ![s, (q : M), u] z + s u q hq (eval_codeEvaluatorCell_fuel s (q : M) u) hs + (eval_codeEvaluatorCell_index s (q : M) u) ((eval_proj_iff _ _ _).mpr rfl) hz + exact ⟨hus, by simpa only [he] using hz⟩ + +/-- Persistence for constructor numbers zero through three needs no induction. -/ +theorem evalnCertificateFormula_natCode_persist_of_lt_four [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + (q : ℕ) (hq : q < 4) (s t u y : M) (hst : s ≤ t) + (h : + Semiformula.Evalb ![s, (q : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4)) : + Semiformula.Evalb ![t, (q : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) := + by + rw [base_computation_iff q hq] at h ⊢ + exact ⟨lt_of_lt_of_le h.1 hst, h.2⟩ + +/-- Removing fuel yields the exact total graph for each base program. -/ +theorem base_unbounded_computation_iff [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (q : ℕ) (hq : q < 4) + (u y : M) : + (∃ s : M, + Semiformula.Evalb ![s, (q : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4)) ↔ + y = baseOutput q u := + by + simp only [base_computation_iff q hq] + exact ⟨fun ⟨_, _, hy⟩ => hy, fun hy => ⟨u + 1, lt_add_one u, hy⟩⟩ + +/-- Mathlib's existing identity program has index 48 in its fixed numbering. -/ +theorem identityIndex_eq : FailureOfComposition.Kleene.identityIndex = 48 := + rfl + +/-- The concrete identity program computes at every fuel exceeding its input. -/ +theorem identity_computation [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (s u : M) (hus : u < s) : + Semiformula.Evalb ![s, (FailureOfComposition.Kleene.identityIndex : M), u, u] + (evalnCertificateFormula : ArithmeticSemisentence 4) := + by + rw [identityIndex_eq, evalnCertificateFormula_eval_history_iff] + apply (eval_codeHistoryEvaluator_succ_iff_cell s (48 : M) u u).mpr + refine ⟨hus, ?_⟩ + have hs : 0 < s := lt_of_le_of_lt (FFL.FirstOrder.Arithmetic.zero_le u) hus + have hleft := + (base_computation_iff 2 (by decide) s u (FFL.FirstOrder.Arithmetic.pi₁ u)).mpr + ⟨hus, by simp [baseOutput]⟩ + have hright := + (base_computation_iff 3 (by decide) s u (FFL.FirstOrder.Arithmetic.pi₂ u)).mpr + ⟨hus, by simp [baseOutput]⟩ + rw [evalnCertificateFormula_eval_history_iff] at hleft hright + have hl := + eval_prefix_lookup_succ_of_codeHistoryEvaluator s (48 : M) u + (FFL.FirstOrder.Arithmetic.pi₁ u) 2 + (FFL.FirstOrder.Arithmetic.pair_lt_pair_right s + (by exact_mod_cast (show (2 : ℕ) < 48 by norm_num))) + hleft + have hr := + eval_prefix_lookup_succ_of_codeHistoryEvaluator s (48 : M) u + (FFL.FirstOrder.Arithmetic.pi₂ u) 3 + (FFL.FirstOrder.Arithmetic.pair_lt_pair_right s + (by exact_mod_cast (show (3 : ℕ) < 48 by norm_num))) + hright + have hcell := + eval_codeEvaluatorCell_succ_of_pair_component_lookups codeEvaluatorHistoryBeforeCell + (Code.proj (2 : Fin 3)) 48 (by decide) (FFL.FirstOrder.Arithmetic.pi₁ u) + (FFL.FirstOrder.Arithmetic.pi₂ u) ![s, (48 : M), u] + (eval_codeEvaluatorCell_index s (48 : M) u) + ⟨s, hs, eval_codeEvaluatorCell_fuel s (48 : M) u⟩ + (by + change + Semiformula.Evalb _ + (code (codeTableLookup _ _ (codeConst (partrecCodePayload₁ 48)) _)) + rw [show partrecCodePayload₁ 48 = 2 from + by + change (Nat.unpair (Nat.pair 2 3)).1 = 2 + simp only [Nat.unpair_pair]] + exact hl) + (by + change + Semiformula.Evalb _ + (code (codeTableLookup _ _ (codeConst (partrecCodePayload₂ 48)) _)) + rw [show partrecCodePayload₂ 48 = 3 from + by + change (Nat.unpair (Nat.pair 2 3)).2 = 3 + simp only [Nat.unpair_pair]] + exact hr) + simpa only [FFL.FirstOrder.Arithmetic.pair_unpair] using hcell + +end ConcreteWitnessGraphs +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/CraigPresentation.lean b/LeanPool/PointwiseComposition/FailureOfComposition/CraigPresentation.lean new file mode 100644 index 000000000..582e6ac74 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/CraigPresentation.lean @@ -0,0 +1,266 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.TheoryEnumerability +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Incompleteness.Definability + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +A decidable presentation of an r.e. arithmetic theory. +Each axiom is padded by a tautology carrying a PA derivation that its original +code belongs to the represented axiom set. The derivation checker and syntax +operations are provably Delta-one over IΣ1. -/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic FFL.Entailment + +open FFL.FirstOrder.Arithmetic.Bootstrapping + +open scoped FFL.FirstOrder.Arithmetic FFL.FirstOrder.Arithmetic.Bootstrapping + +namespace FailureOfComposition +namespace CraigPresentation + +noncomputable section + +/-- The axiom Formula construction in `FailureOfComposition.CraigPresentation`. -/ +def axiomFormula (T : ArithmeticTheory) : ArithmeticSemisentence 1 := + codeOfREPred (AxiomCodes T) + +/-- The padded construction in `FailureOfComposition.CraigPresentation`. -/ +def padded (σ : ArithmeticSentence) (d : ℕ) : ArithmeticSentence := + σ ⋏ ((“!!(d) = !!(d)”) ⋎ (“!!(d) ≠ !!(d)”)) + +/-- The pad Graph construction in `FailureOfComposition.CraigPresentation`. -/ +def padGraph : Σ₁.Semisentence 3 := + .mkSigma + (“f s d. + ∃ nd e ne t, + !Bootstrapping.ObjectArithmetic.numeralGraph nd d ∧ + !qqEQDef e nd nd ∧ !qqNEQDef ne nd nd ∧ !qqOrDef t e ne ∧ !qqAndDef f s t”) + +/-- The check Sigma construction in `FailureOfComposition.CraigPresentation`. -/ +def checkSigma (T : ArithmeticTheory) : Σ₁.Semisentence 2 := + .mkSigma + (“s d. + ∃ ns a, + !Bootstrapping.ObjectArithmetic.numeralGraph ns s ∧ + !(substs1Graph ℒₒᵣ)a ns !!(⌜axiomFormula T⌝) ∧ !(proof 𝐏𝐀).sigma d a”) + +/-- The check Pi construction in `FailureOfComposition.CraigPresentation`. -/ +def checkPi (T : ArithmeticTheory) : Π₁.Semisentence 2 := + .mkPi + (“s d. + ∀ ns a, + !Bootstrapping.ObjectArithmetic.numeralGraph ns s → + !(substs1Graph ℒₒᵣ)a ns !!(⌜axiomFormula T⌝) → !(proof 𝐏𝐀).pi d a”) + +/-- The characteristic construction in `FailureOfComposition.CraigPresentation`. -/ +def characteristic (T : ArithmeticTheory) : ∆₁.Semisentence 1 := + .mkDelta (.mkSigma (“f. ∃ s < f, ∃ d < f, !padGraph f s d ∧ !(checkSigma T)s d”)) + (.mkPi (“f. ∃ s < f, ∃ d < f, !padGraph.graphDelta.pi f s d ∧ !(checkPi T)s d”)) + +variable {M : Type*} [ORingStructure M] [M↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +private def padCode (s d : M) : M := + qqAnd s + (qqOr + (Bootstrapping.ObjectArithmetic.qqEQ (Bootstrapping.ObjectArithmetic.numeral d) + (Bootstrapping.ObjectArithmetic.numeral d)) + (Bootstrapping.ObjectArithmetic.qqNEQ (Bootstrapping.ObjectArithmetic.numeral d) + (Bootstrapping.ObjectArithmetic.numeral d))) + +private instance pad_defined : Σ₁-Function₂ (padCode : M → M → M) via padGraph := + .mk (by intro v; simp [padGraph, padCode]) + +private instance pad_delta_defined : + ∆₁-Function₂ (padCode : M → M → M) via padGraph.graphDelta := + pad_defined.graph_delta + +private theorem checkSigma_eval (T : ArithmeticTheory) (s d : M) : + (checkSigma T).val.Evalb ![s, d] ↔ + Bootstrapping.Proof 𝐏𝐀 d + (substs1 ℒₒᵣ (Bootstrapping.ObjectArithmetic.numeral s) (⌜axiomFormula T⌝ : M)) := + by simp [checkSigma] + +private theorem checkPi_eval (T : ArithmeticTheory) (s d : M) : + (checkPi T).val.Evalb ![s, d] ↔ + Bootstrapping.Proof 𝐏𝐀 d + (substs1 ℒₒᵣ (Bootstrapping.ObjectArithmetic.numeral s) (⌜axiomFormula T⌝ : M)) := + by simp [checkPi] + +private instance checkSigma_defined (T : ArithmeticTheory) : + Σ₁-Relation + (fun s d : M => + Bootstrapping.Proof 𝐏𝐀 d + (substs1 ℒₒᵣ (Bootstrapping.ObjectArithmetic.numeral s) (⌜axiomFormula T⌝ : M))) via + checkSigma T := + .mk (by intro v; simp [checkSigma]) + +private instance checkPi_defined (T : ArithmeticTheory) : + Π₁-Relation + (fun s d : M => + Bootstrapping.Proof 𝐏𝐀 d + (substs1 ℒₒᵣ (Bootstrapping.ObjectArithmetic.numeral s) (⌜axiomFormula T⌝ : M))) via + checkPi T := + .mk (by intro v; simp [checkPi]) + +theorem characteristic_proper (T : ArithmeticTheory) : (characteristic T).ProperOn M := + by + intro v + simp only [characteristic, HierarchySymbol.Semiformula.sigma_mkDelta, + HierarchySymbol.Semiformula.pi_mkDelta] + simp + +private theorem characteristic_eval (T : ArithmeticTheory) (f : M) : + (characteristic T).val.Evalb ![f] ↔ + ∃ s < f, + ∃ d < f, + f = padCode s d ∧ + Bootstrapping.Proof 𝐏𝐀 d + (substs1 ℒₒᵣ (Bootstrapping.ObjectArithmetic.numeral s) (⌜axiomFormula T⌝ : M)) := + by simp [characteristic] + +/-- Axioms accompanied by numerical PA derivations of their membership in the +represented r.e. axiom set. The padding carries the derivation code. -/ +def presentation (T : ArithmeticTheory) : ArithmeticTheory := + {τ | + ∃ σ : ArithmeticSentence, + ∃ d : ℕ, + Bootstrapping.Proof 𝐏𝐀 d + (substs1 ℒₒᵣ (Bootstrapping.ObjectArithmetic.numeral (⌜σ⌝ : ℕ)) + (⌜axiomFormula T⌝ : ℕ)) ∧ + τ = padded σ d} + +private theorem numeral_substitution_quote (φ : ArithmeticSemisentence 1) (s : ℕ) : + substs1 ℒₒᵣ (Bootstrapping.ObjectArithmetic.numeral s) (⌜φ⌝ : ℕ) = + (⌜(φ/[s] : ArithmeticSentence)⌝ : ℕ) := + by + simp [substs1, Sentence.quote_def, Semiformula.quote_def, Rewriting.emb_subst_eq_subst_coe₁] + +private theorem proof_substitution_iff (φ : ArithmeticSemisentence 1) (s : ℕ) : + (∃ d : ℕ, + Bootstrapping.Proof 𝐏𝐀 d + (substs1 ℒₒᵣ (Bootstrapping.ObjectArithmetic.numeral s) (⌜φ⌝ : ℕ))) ↔ + 𝐏𝐀 ⊢ (φ/[s] : ArithmeticSentence) := + by + rw [numeral_substitution_quote φ s] + exact Bootstrapping.provable_iff_provable + +private theorem axiom_proof_iff (T : ArithmeticTheory) (hT : REPred (AxiomCodes T)) (s : ℕ) : + (∃ d : ℕ, + Bootstrapping.Proof 𝐏𝐀 d + (substs1 ℒₒᵣ (Bootstrapping.ObjectArithmetic.numeral s) (⌜axiomFormula T⌝ : ℕ))) ↔ + AxiomCodes T s := + (proof_substitution_iff (axiomFormula T) s).trans + (rePred_weak_representation (T := 𝐏𝐀) hT).symm + +private theorem original_axiom (T : ArithmeticTheory) (hT : REPred (AxiomCodes T)) + (σ : ArithmeticSentence) (d : ℕ) + (hd : + Bootstrapping.Proof 𝐏𝐀 d + (substs1 ℒₒᵣ (Bootstrapping.ObjectArithmetic.numeral (⌜σ⌝ : ℕ)) + (⌜axiomFormula T⌝ : ℕ))) : + σ ∈ T := by + have h := (axiom_proof_iff T hT (⌜σ⌝ : ℕ)).mp ⟨d, hd⟩ + simpa [AxiomCodes] using h + +private theorem padded_provable (T : ArithmeticTheory) (σ : ArithmeticSentence) (d : ℕ) : + T ⊢ padded σ d ↔ T ⊢ σ := by + unfold padded + constructor + · exact K_left + · intro h + have ht : T ⊢ ((“!!(d) = !!(d)”) ⋎ (“!!(d) ≠ !!(d)”) : ArithmeticSentence) := + by + have hn : + (“!!(d) ≠ !!(d)” : ArithmeticSentence) = ∼(“!!(d) = !!(d)” : ArithmeticSentence) := rfl + rw [hn] + cl_prover + exact K_intro h ht + +/-- Every padded axiom is provable in the original theory. -/ +theorem presentation_weaker (T : ArithmeticTheory) (hT : REPred (AxiomCodes T)) : + presentation T ≼ T := by + apply WeakerThan.ofAxmProof + intro τ hτ + obtain ⟨σ, d, hd, rfl⟩ := hτ + exact (padded_provable T σ d).mpr (by_axm (original_axiom T hT σ d hd)) + +/-- Every original axiom has a padded representative from which it follows. -/ +theorem original_weaker (T : ArithmeticTheory) (hT : REPred (AxiomCodes T)) : + T ≼ presentation T := by + apply WeakerThan.ofAxmProof + intro σ hσ + obtain ⟨d, hd⟩ := (axiom_proof_iff T hT (⌜σ⌝ : ℕ)).mpr ⟨σ, rfl, hσ⟩ + apply (padded_provable (presentation T) σ d).mp + exact by_axm (show padded σ d ∈ presentation T from ⟨σ, d, hd, rfl⟩) + +private theorem padCode_lt_left (s d : M) : s < padCode s d := + lt_KProof_left _ _ + +private theorem padCode_lt_right (s d : M) : d < padCode s d := by + exact + lt_of_le_of_lt (Bootstrapping.ObjectArithmetic.le_numeral_self d) + (lt_trans (Bootstrapping.ObjectArithmetic.lt_qqEQ_left _ _) + (lt_trans (lt_or_left _ _) (lt_KProof_right _ _))) + +private theorem padded_quote (σ : ArithmeticSentence) (d : ℕ) : + (⌜padded σ d⌝ : ℕ) = padCode (⌜σ⌝ : ℕ) d := by simp [padded, padCode, Sentence.quote_eq] + +private theorem padded_bounds (σ : ArithmeticSentence) (d : ℕ) : + (⌜σ⌝ : ℕ) < (⌜padded σ d⌝ : ℕ) ∧ d < (⌜padded σ d⌝ : ℕ) := + by + rw [padded_quote] + exact ⟨padCode_lt_left _ _, padCode_lt_right _ _⟩ + +theorem characteristic_mem_iff (T : ArithmeticTheory) (hT : REPred (AxiomCodes T)) + (φ : Proposition ℒₒᵣ) : + (characteristic T).val.Evalb ![(⌜φ⌝ : ℕ)] ↔ ∃ τ ∈ presentation T, φ = τ := + by + rw [characteristic_eval] + constructor + · rintro ⟨s, _, d, _, heq, hp⟩ + obtain ⟨σ, hσ, _⟩ := (axiom_proof_iff T hT s).mp ⟨d, hp⟩ + rcases hσ with rfl + refine ⟨padded σ d, ⟨σ, d, hp, rfl⟩, ?_⟩ + apply (Semiformula.quote_inj_iff (V := ℕ)).mp + exact heq.trans (padded_quote σ d).symm + · rintro ⟨τ, ⟨σ, d, hp, rfl⟩, rfl⟩ + exact ⟨(⌜σ⌝ : ℕ), (padded_bounds σ d).1, d, (padded_bounds σ d).2, padded_quote σ d, hp⟩ + +/-- The padded presentation has a characteristic formula whose Sigma-one and +Pi-one forms are provably equivalent in IΣ1. -/ +abbrev presentationDelta1 (T : ArithmeticTheory) (hT : REPred (AxiomCodes T)) : + (presentation T).Δ₁ where + ch := characteristic T + mem_iff φ := characteristic_mem_iff T hT φ + isDelta1 := + HierarchySymbol.Semiformula.ProvablyProperOn.ofProperOn.{0} _ + (fun V _ _ => characteristic_proper (M := V) T) + +/-- Every arithmetic theory with r.e. axiom codes has an equivalent +Delta-one presentation. No soundness or consistency assumption on T is used. -/ +theorem exists_craig_presentation (T : ArithmeticTheory) (hT : REPred (AxiomCodes T)) : + ∃ S : ArithmeticTheory, Nonempty S.Δ₁ ∧ S ≼ T ∧ T ≼ S := + ⟨presentation T, ⟨presentationDelta1 T hT⟩, presentation_weaker T hT, original_weaker T hT⟩ + +end + +end CraigPresentation +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/GeneratedClassification.lean b/LeanPool/PointwiseComposition/FailureOfComposition/GeneratedClassification.lean new file mode 100644 index 000000000..a3b9d44ba --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/GeneratedClassification.lean @@ -0,0 +1,80 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.GeneratedExtensionality +public import LeanPool.PointwiseComposition.FailureOfComposition.GeneratedQuotient + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +Classification of the generated composition congruence. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic FFL.Entailment + +namespace FailureOfComposition +namespace GeneratedCongruence + +open ProofSearch PiOneCharacterization + +/-- In the Sigma-one sound case the generated congruence is exactly +extensional equality. The containment hypothesis is fully discharged. -/ +theorem generated_iff_extensional_of_sound (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (hT : SigmaOneSound T) (F G : FunctionalGraph) : Rel T F G ↔ Extensional F.val G.val := + rel_iff_extensional_of_sigmaOneSound T (extensional_implies_generated T) hT F G + +/-- Failure of Sigma-one soundness makes every two functional graphs +equivalent in the generated congruence. -/ +theorem generated_universal_of_not_sound (T : ArithmeticTheory) [𝐏𝐀 ≼ T] (hT : ¬SigmaOneSound T) + (F G : FunctionalGraph) : Rel T F G := + collapse_of_not_sigmaOneSound T (extensional_implies_generated T) hT F G + +/-- The generated-congruence dichotomy, with no consistency or effective +presentation assumption on T. -/ +theorem classification (T : ArithmeticTheory) [𝐏𝐀 ≼ T] : + (SigmaOneSound T → ∀ F G : FunctionalGraph, Rel T F G ↔ Extensional F.val G.val) ∧ + (¬SigmaOneSound T → ∀ F G : FunctionalGraph, Rel T F G) := + ⟨generated_iff_extensional_of_sound T, generated_universal_of_not_sound T⟩ + +theorem generated_iff_extensional_or_unsound (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (F G : FunctionalGraph) : Rel T F G ↔ Extensional F.val G.val ∨ ¬SigmaOneSound T := by + classical + by_cases hT : SigmaOneSound T + · simpa only [hT, not_true_eq_false, or_false] using + generated_iff_extensional_of_sound T hT F G + · exact ⟨fun _ => Or.inr hT, fun _ => generated_universal_of_not_sound T hT F G⟩ + +theorem quotient_subsingleton_of_not_sound (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (hT : ¬SigmaOneSound T) : Subsingleton (QuotientGraph T) := + quotient_subsingleton_of_universal T (generated_universal_of_not_sound T hT) + +/-- The quotient monoid has one element exactly in the unsound case. -/ +theorem quotient_subsingleton_iff_not_sound (T : ArithmeticTheory) [𝐏𝐀 ≼ T] : + Subsingleton (QuotientGraph T) ↔ ¬SigmaOneSound T := + by + constructor + · intro hsub hT + have he : quotientMk T identityGraph = quotientMk T emptyGraph := hsub.allEq _ _ + have hr : Rel T identityGraph emptyGraph := Quotient.exact he + have hx := (generated_iff_extensional_of_sound T hT identityGraph emptyGraph).mp hr + have hf := (hx 0 0).mp (by simp [identityGraph]) + simp [emptyGraph] at hf + · exact quotient_subsingleton_of_not_sound T + +end GeneratedCongruence +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/GeneratedCollapse.lean b/LeanPool/PointwiseComposition/FailureOfComposition/GeneratedCollapse.lean new file mode 100644 index 000000000..ca72cde3d --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/GeneratedCollapse.lean @@ -0,0 +1,164 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.GeneratedGraphDefinitions +public import LeanPool.PointwiseComposition.FailureOfComposition.PiOneCongruence +public import LeanPool.PointwiseComposition.FailureOfComposition.GeneratedSoundness + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +The two algebraic halves of the generated-congruence dichotomy. Sigma-one +soundness makes the closure extensionally sound; a false proved Sigma-one +sentence collapses it once extensional containment has been established. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic FFL.Entailment + +namespace FailureOfComposition +namespace GeneratedCongruence + +open ProofSearch PiOneCharacterization + +/-- The delta Graph construction in `FailureOfComposition.GeneratedCongruence`. -/ +def deltaGraph (σ : Σ₁.Sentence) : Graph := + .mkSigma (“x y. !σ.val ∧ y = x”) + +@[simp] +theorem deltaGraph_eval {M : Type*} [ORingStructure M] (σ : Σ₁.Sentence) (v : Fin 2 → M) : + (deltaGraph σ).val.Evalb v ↔ σ.val.Evalb (M := M) ![] ∧ v 1 = v 0 := by simp [deltaGraph] + +theorem deltaGraph_functional (σ : Σ₁.Sentence) : Functional (deltaGraph σ) := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + rw [models_iff, functionalSentence_eval] + intro x y z hy hz + have hy' := (deltaGraph_eval σ _).mp hy + have hz' := (deltaGraph_eval σ _).mp hz + exact hy'.2.trans hz'.2.symm + +theorem deltaGraph_pointwise_identity (T : ArithmeticTheory) [𝐏𝐀 ≼ T] (σ : Σ₁.Sentence) + (hp : T ⊢ σ.val) : Pointwise T (deltaGraph σ) identity := + by + intro n + apply complete.{0} T + intro M _ _ + have : M↓[ℒₒᵣ] ⊧* 𝐏𝐀 := models_of_subtheory (U := T) inferInstance + have : M↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + have hs : M↓[ℒₒᵣ] ⊧ σ.val := consequence_iff.mp (Theory.Proof.sound hp) M inferInstance + simp only [models_iff] at hs + simp [models_iff, eqAt_eval, deltaGraph_eval, hs] + +theorem deltaGraph_extensional_empty (σ : Σ₁.Sentence) (hn : ¬ℕ↓[ℒₒᵣ] ⊧ σ.val) : + Extensional (deltaGraph σ) empty := by + intro x y + have hs : ¬σ.val.Evalb (M := ℕ) ![] := by simpa only [models_iff] using hn + simp [deltaGraph_eval, hs] + +theorem comp_right_identity (F : Graph) : Uniform 𝐏𝐀 (comp F identity) F := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + simp [models_iff] + +theorem comp_right_empty (F : Graph) : Uniform 𝐏𝐀 (comp F empty) empty := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + simp [models_iff] + +/-- The identity and empty graphs as PA-functional graph objects. -/ +def identityGraph : FunctionalGraph := + ⟨identity, identity_functional⟩ + +/-- The empty Graph construction in `FailureOfComposition.GeneratedCongruence`. -/ +def emptyGraph : FunctionalGraph := + ⟨empty, by + apply complete.{0} 𝐏𝐀 + intro M _ _ + simp [models_iff]⟩ + +/-- The delta Functional Graph construction in `FailureOfComposition.GeneratedCongruence`. -/ +def deltaFunctionalGraph (σ : Σ₁.Sentence) : FunctionalGraph := + ⟨deltaGraph σ, deltaGraph_functional σ⟩ + +/-- Identifying the identity with the empty graph collapses every program. -/ +theorem collapse_of_identity_rel_empty (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (h : Rel T identityGraph emptyGraph) : ∀ F G : FunctionalGraph, Rel T F G := + by + have hzero (F : FunctionalGraph) : Rel T F emptyGraph := + by + have hi : Rel T (functionalComp F identityGraph) F := + rel_of_uniform T (comp_right_identity F.val) + have hz : Rel T (functionalComp F emptyGraph) emptyGraph := + rel_of_uniform T (comp_right_empty F.val) + exact rel_trans T (rel_symm T hi) (rel_trans T (rel_comp T (rel_refl T F) h) hz) + intro F G + exact rel_trans T (hzero F) (rel_symm T (hzero G)) + +/-- A false proved Sigma-one sentence identifies the identity and empty graphs +once standard extensional equality is contained in the generated relation. -/ +theorem identity_rel_empty_of_false_proved_sigma_one (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (hExt : ∀ F G : FunctionalGraph, Extensional F.val G.val → Rel T F G) (σ : Σ₁.Sentence) + (hp : T ⊢ σ.val) (hn : ¬ℕ↓[ℒₒᵣ] ⊧ σ.val) : Rel T identityGraph emptyGraph := + by + have hi : Rel T (deltaFunctionalGraph σ) identityGraph := + rel_base T (deltaGraph_pointwise_identity T σ hp) + have hz : Rel T (deltaFunctionalGraph σ) emptyGraph := + hExt _ _ (deltaGraph_extensional_empty σ hn) + exact rel_trans T (rel_symm T hi) hz + +/-- Without Sigma-one soundness the generated relation is universal. The +extensional-containment hypothesis is discharged by the computation witnesses. -/ +theorem collapse_of_not_sigmaOneSound (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (hExt : ∀ F G : FunctionalGraph, Extensional F.val G.val → Rel T F G) + (hT : ¬SigmaOneSound T) : ∀ F G : FunctionalGraph, Rel T F G := + by + obtain ⟨σ, hσ, hp, hn⟩ := (not_sigmaOneSound_iff T).mp hT + exact + collapse_of_identity_rel_empty T + (identity_rel_empty_of_false_proved_sigma_one T hExt (.mkSigma σ hσ) hp hn) + +/-- Sigma-one soundness makes the generated congruence extensionally sound. -/ +theorem generated_implies_extensional_of_sigmaOneSound (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (hT : SigmaOneSound T) {F G : FunctionalGraph} (h : Rel T F G) : Extensional F.val G.val := + by + apply h (fun H K : FunctionalGraph => Extensional H.val K.val) + · constructor + · refine ⟨?_, ?_, ?_⟩ + · intro H x y + exact Iff.rfl + · intro H K hHK x y + exact (hHK x y).symm + · intro H K L hHK hKL x y + exact (hHK x y).trans (hKL x y) + · intro H H' K K' hH hK + exact extensional_comp hH hK + · intro H K hHK + exact pointwise_implies_extensional_of_sigmaOneSound T hT H.val K.val hHK + +/-- Extensional containment and Sigma-one soundness identify the generated +relation with standard graph equality. -/ +theorem rel_iff_extensional_of_sigmaOneSound (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (hExt : ∀ F G : FunctionalGraph, Extensional F.val G.val → Rel T F G) (hT : SigmaOneSound T) + (F G : FunctionalGraph) : Rel T F G ↔ Extensional F.val G.val := + ⟨generated_implies_extensional_of_sigmaOneSound T hT, hExt F G⟩ + +end GeneratedCongruence +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/GeneratedExtensionality.lean b/LeanPool/PointwiseComposition/FailureOfComposition/GeneratedExtensionality.lean new file mode 100644 index 000000000..b0485c42e --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/GeneratedExtensionality.lean @@ -0,0 +1,98 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.GeneratedGraphDefinitions +public import LeanPool.PointwiseComposition.FailureOfComposition.GeneratedWitnessPointwise +public import LeanPool.PointwiseComposition.FailureOfComposition.SigmaOneRealization + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +Extensional containment in the generated composition congruence. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic FFL.Entailment + +namespace FailureOfComposition +namespace GeneratedCongruence + +open ProofSearch PiOneCharacterization GeneratedWitnessGraphs + +/-- The concrete Graph construction in `FailureOfComposition.GeneratedCongruence`. -/ +def concreteGraph (e : ℕ) : FunctionalGraph := + ⟨ConcreteEvaluator.eventualGraph e, ConcreteEvaluator.eventualGraph_functional e⟩ + +/-- The intersection Graph construction in `FailureOfComposition.GeneratedCongruence`. -/ +def intersectionGraph (F G : FunctionalGraph) : FunctionalGraph := + ⟨intersection F.val G.val, intersection_functional F.val G.val F.property⟩ + +/-- PA-uniform equality in particular identifies standard graph extensions. -/ +theorem uniform_extensional {F G : Graph} (h : Uniform 𝐏𝐀 F G) : Extensional F G := + by + have hs : ℕ↓[ℒₒᵣ] ⊧ uniformSentence F G := + consequence_iff.mp (Theory.Proof.sound h) ℕ inferInstance + simpa only [Extensional, models_iff, uniformSentence_eval] using hs + +/-- The least-stage witnesses identify a concrete graph with its intersection +with any extensionally equal graph in every generated congruence. -/ +theorem concrete_rel_intersection (T : ArithmeticTheory) [𝐏𝐀 ≼ T] (e : ℕ) (G : FunctionalGraph) + (hExt : Extensional (concreteGraph e).val G.val) : + Rel T (concreteGraph e) (intersectionGraph (concreteGraph e) G) := + by + let A : FunctionalGraph := ⟨AGraph e G.val, AGraph_functional e G.val⟩ + let B : FunctionalGraph := ⟨BGraph e, BGraph_functional e⟩ + let H : FunctionalGraph := ⟨HGraph e, HGraph_functional e⟩ + have hAB : Rel T A B := + rel_base T (fun n => WeakerThan.pbl (AGraph_pointwise_B e G.val hExt n)) + have hComp : Rel T (functionalComp A H) (functionalComp B H) := rel_comp T hAB (rel_refl T H) + have hB : Rel T (functionalComp B H) (concreteGraph e) := rel_of_uniform T (B_comp_H e) + have hA : Rel T (functionalComp A H) (intersectionGraph (concreteGraph e) G) := + rel_of_uniform T (A_comp_H e G.val) + exact rel_trans T (rel_symm T hB) (rel_trans T (rel_symm T hComp) hA) + +theorem concrete_extensional_implies_generated (T : ArithmeticTheory) [𝐏𝐀 ≼ T] (e d : ℕ) + (h : Extensional (concreteGraph e).val (concreteGraph d).val) : + Rel T (concreteGraph e) (concreteGraph d) := + by + have he := concrete_rel_intersection T e (concreteGraph d) h + have hd := concrete_rel_intersection T d (concreteGraph e) (fun x y => (h x y).symm) + have hc : + Rel T (intersectionGraph (concreteGraph e) (concreteGraph d)) + (intersectionGraph (concreteGraph d) (concreteGraph e)) := + rel_of_uniform T (intersection_comm_uniform _ _) + exact rel_trans T he (rel_trans T hc (rel_symm T hd)) + +/-- Extensional equality is contained in the congruence generated by pointwise +provability for every extension of PA, without consistency or soundness. -/ +theorem extensional_implies_generated (T : ArithmeticTheory) [𝐏𝐀 ≼ T] (F G : FunctionalGraph) + (h : Extensional F.val G.val) : Rel T F G := + by + obtain ⟨e, he⟩ := SigmaOneRealization.realize_graph F.val F.property + obtain ⟨d, hd⟩ := SigmaOneRealization.realize_graph G.val G.property + have hext := uniform_extensional he + have hdxt := uniform_extensional hd + have hed : Extensional (concreteGraph e).val (concreteGraph d).val := fun x y => + (hext x y).trans ((h x y).trans (hdxt x y).symm) + have heR : Rel T (concreteGraph e) F := rel_of_uniform T he + have hdR : Rel T (concreteGraph d) G := rel_of_uniform T hd + exact + rel_trans T (rel_symm T heR) + (rel_trans T (concrete_extensional_implies_generated T e d hed) hdR) + +end GeneratedCongruence +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/GeneratedGraphDefinitions.lean b/LeanPool/PointwiseComposition/FailureOfComposition/GeneratedGraphDefinitions.lean new file mode 100644 index 000000000..84a8a478d --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/GeneratedGraphDefinitions.lean @@ -0,0 +1,79 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.CompositionClosure +public import LeanPool.PointwiseComposition.FailureOfComposition.ProgramIndices +public import LeanPool.PointwiseComposition.FailureOfComposition.PiOneDefinitions + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +Definitions and closure laws for the generated graph congruence. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic FFL.Entailment + +namespace FailureOfComposition +namespace GeneratedCongruence + +open ProofSearch + +/-- The least composition congruence on PA-functional Sigma-one graphs +containing external pointwise provability in T. -/ +def Rel (T : ArithmeticTheory) (F G : FunctionalGraph) : Prop := + CompositionClosure.Generated functionalComp + (fun H K : FunctionalGraph => Pointwise T H.val K.val) F G + +theorem rel_base (T : ArithmeticTheory) {F G : FunctionalGraph} (h : Pointwise T F.val G.val) : + Rel T F G := by + intro R _ hR + exact hR F G h + +theorem rel_refl (T : ArithmeticTheory) (F : FunctionalGraph) : Rel T F F := + by + intro R hR _ + exact hR.1.refl F + +theorem rel_symm (T : ArithmeticTheory) {F G : FunctionalGraph} (h : Rel T F G) : Rel T G F := + by + intro R hR hb + exact hR.1.symm (h R hR hb) + +theorem rel_trans (T : ArithmeticTheory) {F G H : FunctionalGraph} (hFG : Rel T F G) + (hGH : Rel T G H) : Rel T F H := by + intro R hR hb + exact hR.1.trans (hFG R hR hb) (hGH R hR hb) + +theorem rel_comp (T : ArithmeticTheory) {F F' G G' : FunctionalGraph} (hF : Rel T F F') + (hG : Rel T G G') : Rel T (functionalComp F G) (functionalComp F' G') := + by + intro R hR hb + exact hR.2 F F' G G' (hF R hR hb) (hG R hR hb) + +theorem rel_of_uniform (T : ArithmeticTheory) [𝐏𝐀 ≼ T] {F G : FunctionalGraph} + (h : Uniform 𝐏𝐀 F.val G.val) : Rel T F G := + rel_base T (ProgramIndices.uniform_to_pointwise T h) + +/-- The graph Setoid construction in `FailureOfComposition.GeneratedCongruence`. -/ +def graphSetoid (T : ArithmeticTheory) : Setoid FunctionalGraph + where + r := Rel T + iseqv := ⟨rel_refl T, rel_symm T, rel_trans T⟩ + +end GeneratedCongruence +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/GeneratedIndexClassification.lean b/LeanPool/PointwiseComposition/FailureOfComposition/GeneratedIndexClassification.lean new file mode 100644 index 000000000..f041f71a8 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/GeneratedIndexClassification.lean @@ -0,0 +1,106 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.GeneratedIndexTransport +public import LeanPool.PointwiseComposition.FailureOfComposition.GeneratedClassification +public import LeanPool.PointwiseComposition.FailureOfComposition.PiOneIndexCharacterization + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +Classification of the least composition congruence on program indices. +Sigma-one soundness gives equality of denoted partial functions; otherwise +the generated relation is universal. No effective presentation is required. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +namespace FailureOfComposition +namespace ProgramIndices + +open ProofSearch + +theorem extensional_implies_generated (A : Arithmetization) (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (e d : ℕ) (h : A.evaluation e = A.evaluation d) : GeneratedRel A T e d := + (generatedRel_iff_graph A T e d).mpr + (GeneratedCongruence.extensional_implies_generated T ⟨A.graph e, A.functional e⟩ + ⟨A.graph d, A.functional d⟩ ((extensionalIndex_iff A e d).mp h)) + +theorem generated_iff_extensional_of_sound (A : Arithmetization) (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (hT : GeneratedCongruence.SigmaOneSound T) (e d : ℕ) : + GeneratedRel A T e d ↔ A.evaluation e = A.evaluation d := + (generatedRel_iff_graph A T e d).trans + ((GeneratedCongruence.generated_iff_extensional_of_sound T hT ⟨A.graph e, A.functional e⟩ + ⟨A.graph d, A.functional d⟩).trans + (extensionalIndex_iff A e d).symm) + +theorem generated_universal_of_not_sound (A : Arithmetization) (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (hT : ¬GeneratedCongruence.SigmaOneSound T) (e d : ℕ) : GeneratedRel A T e d := + (generatedRel_iff_graph A T e d).mpr + (GeneratedCongruence.generated_universal_of_not_sound T hT ⟨A.graph e, A.functional e⟩ + ⟨A.graph d, A.functional d⟩) + +/-- The two cases of the generated-congruence theorem, with equality of +actual partial-function denotations in the sound case. -/ +theorem generated_congruence_classification (A : Arithmetization) (T : ArithmeticTheory) + [𝐏𝐀 ≼ T] : + (GeneratedCongruence.SigmaOneSound T → + ∀ e d : ℕ, GeneratedRel A T e d ↔ A.evaluation e = A.evaluation d) ∧ + (¬GeneratedCongruence.SigmaOneSound T → ∀ e d : ℕ, GeneratedRel A T e d) := + ⟨generated_iff_extensional_of_sound A T, generated_universal_of_not_sound A T⟩ + +theorem generated_iff_extensional_or_unsound (A : Arithmetization) (T : ArithmeticTheory) + [𝐏𝐀 ≼ T] (e d : ℕ) : + GeneratedRel A T e d ↔ + A.evaluation e = A.evaluation d ∨ ¬GeneratedCongruence.SigmaOneSound T := + (generatedRel_iff_graph A T e d).trans + ((GeneratedCongruence.generated_iff_extensional_or_unsound T ⟨A.graph e, A.functional e⟩ + ⟨A.graph d, A.functional d⟩).trans + (or_congr (extensionalIndex_iff A e d).symm Iff.rfl)) + +/-- The quotient by the generated congruence has exactly one element if and +only if the ambient theory fails Sigma-one soundness. -/ +theorem generated_quotient_subsingleton_iff_not_sound (A : Arithmetization) + (T : ArithmeticTheory) [𝐏𝐀 ≼ T] : + Subsingleton (Quotient (generatedSetoid A T)) ↔ ¬GeneratedCongruence.SigmaOneSound T := + by + constructor + · intro hsub + apply (GeneratedCongruence.quotient_subsingleton_iff_not_sound T).mp + apply GeneratedCongruence.quotient_subsingleton_of_universal T + intro F G + have heq := + hsub.allEq (Quotient.mk (generatedSetoid A T) (realizationIndex A F)) + (Quotient.mk (generatedSetoid A T) (realizationIndex A G)) + have hrel : GeneratedRel A T (realizationIndex A F) (realizationIndex A G) := + Quotient.exact heq + exact + GeneratedCongruence.rel_trans T + (GeneratedCongruence.rel_symm T + (GeneratedCongruence.rel_of_uniform T (realizationIndex_uniform A F))) + (GeneratedCongruence.rel_trans T ((generatedRel_iff_graph A T _ _).mp hrel) + (GeneratedCongruence.rel_of_uniform T (realizationIndex_uniform A G))) + · intro hT + constructor + intro a b + refine Quotient.inductionOn₂ a b ?_ + intro e d + exact Quotient.sound (generated_universal_of_not_sound A T hT e d) + +end ProgramIndices +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/GeneratedIndexQuotient.lean b/LeanPool/PointwiseComposition/FailureOfComposition/GeneratedIndexQuotient.lean new file mode 100644 index 000000000..96f457fdc --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/GeneratedIndexQuotient.lean @@ -0,0 +1,171 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.GeneratedIndexTransport +public import LeanPool.PointwiseComposition.FailureOfComposition.GeneratedQuotient + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +The generated quotient of program indices is a monoid, with multiplication +given by the compiler's composition operation. Interpreting indices as +functional graphs gives a monoid equivalence to the generated graph quotient. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +namespace FailureOfComposition +namespace ProgramIndices + +open ProofSearch + +noncomputable section + +/-- Program indices modulo the generated composition congruence. -/ +def GeneratedIndexQuotient (A : Arithmetization) (T : ArithmeticTheory) := + Quotient (generatedSetoid A T) + +/-- The class of a program index. -/ +def generatedIndexMk (A : Arithmetization) (T : ArithmeticTheory) (e : ℕ) : + GeneratedIndexQuotient A T := + Quotient.mk (generatedSetoid A T) e + +theorem realizationIndex_respects_generated (A : Arithmetization) (T : ArithmeticTheory) + [𝐏𝐀 ≼ T] {F G : FunctionalGraph} (h : GeneratedCongruence.Rel T F G) : + GeneratedRel A T (realizationIndex A F) (realizationIndex A G) := + by + apply graph_implies_generatedRel A T + exact + GeneratedCongruence.rel_trans T + (GeneratedCongruence.rel_of_uniform T (realizationIndex_uniform A F)) + (GeneratedCongruence.rel_trans T h + (GeneratedCongruence.rel_symm T + (GeneratedCongruence.rel_of_uniform T (realizationIndex_uniform A G)))) + +/-- Graph interpretation and chosen PA realizers give inverse maps on the +generated quotients. -/ +def generatedQuotientEquiv (A : Arithmetization) (T : ArithmeticTheory) [𝐏𝐀 ≼ T] : + GeneratedIndexQuotient A T ≃ GeneratedCongruence.QuotientGraph T + where + toFun := + Quotient.lift (fun e => GeneratedCongruence.quotientMk T ⟨A.graph e, A.functional e⟩) + (fun _ _ h => Quotient.sound (generatedRel_implies_graph A T h)) + invFun := + Quotient.lift (fun F => generatedIndexMk A T (realizationIndex A F)) + (fun _ _ h => Quotient.sound (realizationIndex_respects_generated A T h)) + left_inv + q := by + refine Quotient.inductionOn q ?_ + intro e + exact Quotient.sound (CompositionClosure.base _ _ (realizationIndex_roundtrip A T e)) + right_inv + q := by + refine Quotient.inductionOn q ?_ + intro F + exact Quotient.sound (GeneratedCongruence.rel_of_uniform T (realizationIndex_uniform A F)) + +@[simp] +theorem generatedQuotientEquiv_mk (A : Arithmetization) (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (e : ℕ) : + generatedQuotientEquiv A T (generatedIndexMk A T e) = + GeneratedCongruence.quotientMk T ⟨A.graph e, A.functional e⟩ := + rfl + +@[simp] +theorem generatedQuotientEquiv_symm_mk (A : Arithmetization) (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (F : FunctionalGraph) : + (generatedQuotientEquiv A T).symm (GeneratedCongruence.quotientMk T F) = + generatedIndexMk A T (realizationIndex A F) := + rfl + +instance (A : Arithmetization) (T : ArithmeticTheory) : Mul (GeneratedIndexQuotient A T) where + mul := + Quotient.lift₂ (fun e d => generatedIndexMk A T (A.compIndex e d)) + (fun _ _ _ _ he hd => Quotient.sound (CompositionClosure.comp he hd)) + +instance (A : Arithmetization) (T : ArithmeticTheory) : One (GeneratedIndexQuotient A T) where + one := generatedIndexMk A T (realizationIndex A GeneratedCongruence.identityGraph) + +@[simp] +theorem generatedIndexQuotient_mul_mk (A : Arithmetization) (T : ArithmeticTheory) (e d : ℕ) : + generatedIndexMk A T e * generatedIndexMk A T d = generatedIndexMk A T (A.compIndex e d) := + rfl + +theorem generatedIndexQuotient_one_mk (A : Arithmetization) (T : ArithmeticTheory) : + (1 : GeneratedIndexQuotient A T) = + generatedIndexMk A T (realizationIndex A GeneratedCongruence.identityGraph) := + rfl + +theorem generatedQuotientEquiv_mul (A : Arithmetization) (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (a b : GeneratedIndexQuotient A T) : + generatedQuotientEquiv A T (a * b) = + generatedQuotientEquiv A T a * generatedQuotientEquiv A T b := + by + refine Quotient.inductionOn₂ a b ?_ + intro e d + exact Quotient.sound (GeneratedCongruence.rel_of_uniform T (A.composition e d)) + +theorem generatedQuotientEquiv_one (A : Arithmetization) (T : ArithmeticTheory) [𝐏𝐀 ≼ T] : + generatedQuotientEquiv A T 1 = 1 := + Quotient.sound + (GeneratedCongruence.rel_of_uniform T + (realizationIndex_uniform A GeneratedCongruence.identityGraph)) + +instance generatedIndexQuotientMonoid (A : Arithmetization) (T : ArithmeticTheory) [𝐏𝐀 ≼ T] : + Monoid (GeneratedIndexQuotient A T) + where + mul_assoc a b + c := + (generatedQuotientEquiv A T).injective + (by simp only [generatedQuotientEquiv_mul, mul_assoc]) + one_mul + a := + (generatedQuotientEquiv A T).injective + (by simp only [generatedQuotientEquiv_mul, generatedQuotientEquiv_one, one_mul]) + mul_one + a := + (generatedQuotientEquiv A T).injective + (by simp only [generatedQuotientEquiv_mul, generatedQuotientEquiv_one, mul_one]) + +/-- The index and graph quotients are equivalent as monoids. -/ +def generatedQuotientMulEquiv (A : Arithmetization) (T : ArithmeticTheory) [𝐏𝐀 ≼ T] : + GeneratedIndexQuotient A T ≃* GeneratedCongruence.QuotientGraph T := + { generatedQuotientEquiv A T with map_mul' := generatedQuotientEquiv_mul A T } + +@[simp] +theorem generatedQuotientMulEquiv_mk (A : Arithmetization) (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (e : ℕ) : + generatedQuotientMulEquiv A T (generatedIndexMk A T e) = + GeneratedCongruence.quotientMk T ⟨A.graph e, A.functional e⟩ := + rfl + +/-- Universality on functional graphs also collapses the index quotient. -/ +theorem generatedIndexQuotient_subsingleton_of_graph_universal (A : Arithmetization) + (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (h : ∀ F G : FunctionalGraph, GeneratedCongruence.Rel T F G) : + Subsingleton (GeneratedIndexQuotient A T) := + by + have := GeneratedCongruence.quotient_subsingleton_of_universal T h + constructor + intro a b + exact (generatedQuotientEquiv A T).injective (Subsingleton.elim _ _) + +end + +end ProgramIndices +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/GeneratedIndexTransport.lean b/LeanPool/PointwiseComposition/FailureOfComposition/GeneratedIndexTransport.lean new file mode 100644 index 000000000..621dbf439 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/GeneratedIndexTransport.lean @@ -0,0 +1,151 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.GeneratedGraphDefinitions + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +The least composition congruence on indices agrees with the least congruence +on their functional arithmetic graphs. Realization and composition are used +at the level of PA proofs, including for the chosen inverse representatives. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +namespace FailureOfComposition +namespace ProgramIndices + +open ProofSearch + +noncomputable section + +/-- The Generated Rel construction in `FailureOfComposition.ProgramIndices`. -/ +def GeneratedRel (A : Arithmetization) (T : ArithmeticTheory) (e d : ℕ) : Prop := + CompositionClosure.Generated A.compIndex (PointwiseIndex A T) e d + +/-- The generated Setoid construction in `FailureOfComposition.ProgramIndices`. -/ +def generatedSetoid (A : Arithmetization) (T : ArithmeticTheory) : Setoid ℕ := + CompositionClosure.setoid A.compIndex (PointwiseIndex A T) + +private def indexGraph (A : Arithmetization) (e : ℕ) : FunctionalGraph := + ⟨A.graph e, A.functional e⟩ + +/-- Select an index whose arithmetic graph PA proves equal to the given graph. -/ +def realizationIndex (A : Arithmetization) (F : FunctionalGraph) : ℕ := + Classical.choose (A.realization F.val F.property) + +theorem realizationIndex_uniform (A : Arithmetization) (F : FunctionalGraph) : + Uniform 𝐏𝐀 (A.graph (realizationIndex A F)) F.val := + Classical.choose_spec (A.realization F.val F.property) + +theorem realizationIndex_pointwise (A : Arithmetization) (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (F G : FunctionalGraph) (h : Pointwise T F.val G.val) : + PointwiseIndex A T (realizationIndex A F) (realizationIndex A G) := + by + apply (pointwiseIndex_iff A T _ _).mpr + have eqv := pointwise_equivalence T + exact + eqv.trans (uniform_to_pointwise T (realizationIndex_uniform A F)) + (eqv.trans h (eqv.symm (uniform_to_pointwise T (realizationIndex_uniform A G)))) + +theorem realizationIndex_roundtrip (A : Arithmetization) (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (e : ℕ) : PointwiseIndex A T (realizationIndex A ⟨A.graph e, A.functional e⟩) e := + (pointwiseIndex_iff A T _ _).mpr + (uniform_to_pointwise T (realizationIndex_uniform A ⟨A.graph e, A.functional e⟩)) + +theorem realizationIndex_composition (A : Arithmetization) (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (F G : FunctionalGraph) : + PointwiseIndex A T (realizationIndex A (functionalComp F G)) + (A.compIndex (realizationIndex A F) (realizationIndex A G)) := + by + apply (pointwiseIndex_iff A T _ _).mpr + have eqv := pointwise_equivalence T + have hl := uniform_to_pointwise T (realizationIndex_uniform A (functionalComp F G)) + have hr := + eqv.trans + (uniform_to_pointwise T (A.composition (realizationIndex A F) (realizationIndex A G))) + (uniform_to_pointwise T + (uniform_comp (realizationIndex_uniform A F) (realizationIndex_uniform A G))) + exact eqv.trans hl (eqv.symm hr) + +private theorem indexGraph_composition (A : Arithmetization) (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (e d : ℕ) : + GeneratedCongruence.Rel T (indexGraph A (A.compIndex e d)) + (functionalComp (indexGraph A e) (indexGraph A d)) := + GeneratedCongruence.rel_of_uniform T (A.composition e d) + +/-- The graph interpretation preserves the generated relation despite being +a composition homomorphism only up to a PA-provable graph equation. -/ +theorem generatedRel_implies_graph (A : Arithmetization) (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + {e d : ℕ} (h : GeneratedRel A T e d) : + GeneratedCongruence.Rel T ⟨A.graph e, A.functional e⟩ ⟨A.graph d, A.functional d⟩ := + by + apply h (fun e d => GeneratedCongruence.Rel T (indexGraph A e) (indexGraph A d)) + · constructor + · exact + ⟨fun e => GeneratedCongruence.rel_refl T (indexGraph A e), fun h => + GeneratedCongruence.rel_symm T h, fun h h' => GeneratedCongruence.rel_trans T h h'⟩ + · intro e e' d d' he hd + exact + GeneratedCongruence.rel_trans T (indexGraph_composition A T e d) + (GeneratedCongruence.rel_trans T (GeneratedCongruence.rel_comp T he hd) + (GeneratedCongruence.rel_symm T (indexGraph_composition A T e' d'))) + · intro e d hed + exact GeneratedCongruence.rel_base T ((pointwiseIndex_iff A T e d).mp hed) + +/-- Realization transports the graph congruence back to indices. The chosen +realizers differ from the original indices by generating relations already. -/ +theorem graph_implies_generatedRel (A : Arithmetization) (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + {e d : ℕ} + (h : GeneratedCongruence.Rel T ⟨A.graph e, A.functional e⟩ ⟨A.graph d, A.functional d⟩) : + GeneratedRel A T e d := + by + have hlift : + GeneratedRel A T (realizationIndex A (indexGraph A e)) + (realizationIndex A (indexGraph A d)) := + by + apply h (fun F G => GeneratedRel A T (realizationIndex A F) (realizationIndex A G)) + · constructor + · exact + ⟨fun F => CompositionClosure.refl _ _ (realizationIndex A F), fun h => + CompositionClosure.symm h, fun h h' => CompositionClosure.trans h h'⟩ + · intro F F' G G' hF hG + exact + CompositionClosure.trans + (CompositionClosure.base _ _ (realizationIndex_composition A T F G)) + (CompositionClosure.trans (CompositionClosure.comp hF hG) + (CompositionClosure.symm + (CompositionClosure.base _ _ (realizationIndex_composition A T F' G')))) + · intro F G hFG + exact CompositionClosure.base _ _ (realizationIndex_pointwise A T F G hFG) + exact + CompositionClosure.trans + (CompositionClosure.symm (CompositionClosure.base _ _ (realizationIndex_roundtrip A T e))) + (CompositionClosure.trans hlift + (CompositionClosure.base _ _ (realizationIndex_roundtrip A T d))) + +theorem generatedRel_iff_graph (A : Arithmetization) (T : ArithmeticTheory) [𝐏𝐀 ≼ T] (e d : ℕ) : + GeneratedRel A T e d ↔ + GeneratedCongruence.Rel T ⟨A.graph e, A.functional e⟩ ⟨A.graph d, A.functional d⟩ := + ⟨generatedRel_implies_graph A T, graph_implies_generatedRel A T⟩ + +end + +end ProgramIndices +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/GeneratedQuotient.lean b/LeanPool/PointwiseComposition/FailureOfComposition/GeneratedQuotient.lean new file mode 100644 index 000000000..d4a978937 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/GeneratedQuotient.lean @@ -0,0 +1,108 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.GeneratedCollapse + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +Composition descends to the quotient by the generated congruence. The PA +proofs of associativity and the identity laws make this quotient a monoid +for every theory extending PA. A universal congruence gives a singleton +quotient. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic FFL.Entailment + +namespace FailureOfComposition +namespace GeneratedCongruence + +open ProofSearch + +/-- PA-functional Sigma-one graphs modulo the generated composition +congruence. -/ +def QuotientGraph (T : ArithmeticTheory) := + Quotient (graphSetoid T) + +/-- The class of a functional graph. -/ +def quotientMk (T : ArithmeticTheory) (F : FunctionalGraph) : QuotientGraph T := + Quotient.mk (graphSetoid T) F + +instance (T : ArithmeticTheory) : Mul (QuotientGraph T) where + mul := + Quotient.lift₂ (fun F G => Quotient.mk (graphSetoid T) (functionalComp F G)) + (fun _ _ _ _ hF hG => Quotient.sound (rel_comp T hF hG)) + +instance (T : ArithmeticTheory) : One (QuotientGraph T) where + one := Quotient.mk (graphSetoid T) identityGraph + +@[simp] +theorem quotient_mul_mk (T : ArithmeticTheory) (F G : FunctionalGraph) : + quotientMk T F * quotientMk T G = quotientMk T (functionalComp F G) := + rfl + +theorem one_mk (T : ArithmeticTheory) : (1 : QuotientGraph T) = quotientMk T identityGraph := + rfl + +/-- Composition of graph formulas is associative already in PA. -/ +theorem comp_associative_uniform (F G H : Graph) : + Uniform 𝐏𝐀 (comp (comp F G) H) (comp F (comp G H)) := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + simp only [models_iff, uniformSentence_eval, comp_eval, Matrix.cons_val_zero, + Matrix.cons_val_one] + intro x y + constructor + · rintro ⟨z, hHz, w, hGzw, hFwy⟩ + exact ⟨w, ⟨z, hHz, hGzw⟩, hFwy⟩ + · rintro ⟨w, ⟨z, hHz, hGzw⟩, hFwy⟩ + exact ⟨z, hHz, w, hGzw, hFwy⟩ + +instance quotientMonoid (T : ArithmeticTheory) [𝐏𝐀 ≼ T] : Monoid (QuotientGraph T) + where + mul_assoc a b + c := by + refine Quotient.inductionOn₃ a b c ?_ + intro F G H + exact Quotient.sound (rel_of_uniform T (comp_associative_uniform F.val G.val H.val)) + one_mul + a := by + refine Quotient.inductionOn a ?_ + intro F + exact Quotient.sound (rel_of_uniform T (identity_comp F.val)) + mul_one + a := by + refine Quotient.inductionOn a ?_ + intro F + exact Quotient.sound (rel_of_uniform T (comp_right_identity F.val)) + +/-- If all functional graphs are related, every two quotient elements are +equal. Together with the identity element, this makes the quotient a +singleton. -/ +theorem quotient_subsingleton_of_universal (T : ArithmeticTheory) + (h : ∀ F G : FunctionalGraph, Rel T F G) : Subsingleton (QuotientGraph T) := + by + constructor + intro a b + refine Quotient.inductionOn₂ a b ?_ + intro F G + exact Quotient.sound (h F G) + +end GeneratedCongruence +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/GeneratedSoundness.lean b/LeanPool/PointwiseComposition/FailureOfComposition/GeneratedSoundness.lean new file mode 100644 index 000000000..65931719d --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/GeneratedSoundness.lean @@ -0,0 +1,88 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.PiOneExtensionality + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +Sigma-one soundness is enough to make pointwise provability sound for the +standard extensions of arbitrary Sigma-one graphs. This statement needs +neither graph functionality nor an enumerability assumption on the theory. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic FFL.Entailment + +namespace FailureOfComposition +namespace GeneratedCongruence + +open ProofSearch PiOneCharacterization + +/-- Every Sigma-one sentence proved by the theory is true in the standard +natural numbers. -/ +def SigmaOneSound (T : ArithmeticTheory) : Prop := + ∀ σ : ArithmeticSentence, Hierarchy Σ 1 σ → T ⊢ σ → ℕ↓[ℒₒᵣ] ⊧ σ + +/-- Failure of Sigma-one soundness supplies a single false proved Sigma-one +sentence. No consistency hypothesis is required. -/ +theorem not_sigmaOneSound_iff (T : ArithmeticTheory) : + ¬SigmaOneSound T ↔ ∃ σ : ArithmeticSentence, Hierarchy Σ 1 σ ∧ T ⊢ σ ∧ ¬ℕ↓[ℒₒᵣ] ⊧ σ := by + classical simp only [SigmaOneSound, not_forall, exists_prop] + +/-- The propositional formulation agrees with Foundation's soundness class. -/ +theorem sigmaOneSound_iff_nonempty_soundOnHierarchy (T : ArithmeticTheory) : + SigmaOneSound T ↔ Nonempty (T.SoundOnHierarchy Σ 1) := + by + constructor + · intro h + exact ⟨⟨fun hp hσ => h _ hσ hp⟩⟩ + · rintro ⟨h⟩ σ hσ hp + exact h.sound hp hσ + +private theorem ground_proof_of_pointwise (T : ArithmeticTheory) [𝐏𝐀 ≼ T] (F G : Graph) + (hFG : Pointwise T F G) (n m : ℕ) (hF : F.val.Evalb ![n, m]) : T ⊢ graphInstance G n m := + by + have hpF : T ⊢ graphInstance F n m := WeakerThan.pbl (true_graph_instance_provable F n m hF) + apply complete.{0} T + intro M _ _ + have : M↓[ℒₒᵣ] ⊧* 𝐏𝐀 := models_of_subtheory (U := T) inferInstance + have : M↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + have hEq : M↓[ℒₒᵣ] ⊧ eqAt F G n := + consequence_iff.mp (Theory.Proof.sound (hFG n)) M inferInstance + have hVal : M↓[ℒₒᵣ] ⊧ graphInstance F n m := + consequence_iff.mp (Theory.Proof.sound hpF) M inferInstance + simp only [models_iff, eqAt_eval] at hEq + simp only [models_iff, graphInstance_eval] at hVal ⊢ + exact (hEq (m : M)).mp hVal + +/-- Sigma-one soundness turns each pointwise proof into equality of standard +graphs, without assuming that either graph is functional. -/ +theorem pointwise_implies_extensional_of_sigmaOneSound (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (hT : SigmaOneSound T) (F G : Graph) (hFG : Pointwise T F G) : Extensional F G := + by + intro n m + have forward {F G : Graph} (hFG : Pointwise T F G) (hF : F.val.Evalb ![n, m]) : + G.val.Evalb ![n, m] := + by + have hp := ground_proof_of_pointwise T F G hFG n m hF + have hs := hT _ (graphInstance_sigma_one G n m) hp + simpa only [models_iff, graphInstance_eval, natCast_nat] using hs + exact ⟨forward hFG, forward ((pointwise_equivalence T).symm hFG)⟩ + +end GeneratedCongruence +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/GeneratedWitnessGraphs.lean b/LeanPool/PointwiseComposition/FailureOfComposition/GeneratedWitnessGraphs.lean new file mode 100644 index 000000000..499029d06 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/GeneratedWitnessGraphs.lean @@ -0,0 +1,323 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteEvaluatorGraph + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +Functional Sigma-one witnesses for adjoining composition to pointwise equality. +The first witness records the least successful evaluator stage and the input; +the other two read that computation, with an optional second graph condition. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic FFL.Entailment + +open CategoricalRiceShapiro.ArithmeticCode CategoricalRiceShapiro.Evaluator + +namespace FailureOfComposition +namespace GeneratedWitnessGraphs + +open ProofSearch ConcreteEvaluator + +/-- The stage Graph construction in `FailureOfComposition.GeneratedWitnessGraphs`. -/ +def stageGraph (e : ℕ) : Σ₁.Semisentence 3 := + .mkSigma (“s x y. !evalnCertificateFormula.val s !!(e)x y”) + +/-- The failure Graph construction in `FailureOfComposition.GeneratedWitnessGraphs`. -/ +def failureGraph (e : ℕ) : Graph := + .mkSigma (“s x. !evalnGraphFormula.val 0s !!(e)x”) + +/-- The least Graph construction in `FailureOfComposition.GeneratedWitnessGraphs`. -/ +def leastGraph (e : ℕ) : Graph := + .mkSigma (“x s. (∃ y, !(stageGraph e).val s x y) ∧ ∀ r < s, !(failureGraph e).val r x”) + +/-- The HGraph construction in `FailureOfComposition.GeneratedWitnessGraphs`. -/ +def HGraph (e : ℕ) : Graph := + .mkSigma (“x n. ∃ s, !(leastGraph e).val x s ∧ !pairDef n s x”) + +/-- The BGraph construction in `FailureOfComposition.GeneratedWitnessGraphs`. -/ +def BGraph (e : ℕ) : Graph := + .mkSigma (“n y. ∃ s x, !pairDef n s x ∧ !(stageGraph e).val s x y”) + +/-- The AGraph construction in `FailureOfComposition.GeneratedWitnessGraphs`. -/ +def AGraph (e : ℕ) (G : Graph) : Graph := + .mkSigma (“n y. ∃ s x, !pairDef n s x ∧ !(stageGraph e).val s x y ∧ !G.val x y”) + +/-- The intersection construction in `FailureOfComposition.GeneratedWitnessGraphs`. -/ +def intersection (F G : Graph) : Graph := + .mkSigma (“x y. !F.val x y ∧ !G.val x y”) + +section Semantics + +variable {M : Type*} [ORingStructure M] + +section + +variable [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + +@[simp] +theorem stageGraph_eval (e : ℕ) (s x y : M) : + (stageGraph e).val.Evalb ![s, x, y] ↔ + Semiformula.Evalb ![s, (e : M), x, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) := + by simp [stageGraph, numeral_eq_natCast] + +@[simp] +theorem failureGraph_eval (e : ℕ) (s x : M) : + (failureGraph e).val.Evalb ![s, x] ↔ + Semiformula.Evalb ![0, s, (e : M), x] (code codeHistoryEvaluator) := + by simp [failureGraph, evalnGraphFormula, numeral_eq_natCast] + +theorem stage_of_history (e : ℕ) (s x y : M) : + (stageGraph e).val.Evalb ![s, x, y] ↔ + Semiformula.Evalb ![y + 1, s, (e : M), x] (code codeHistoryEvaluator) := + by rw [stageGraph_eval, evalnCertificateFormula_eval_history_iff] + +end + +section + +variable [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + +theorem history_total (e : ℕ) (s x : M) : + ∃ z : M, Semiformula.Evalb ![z, s, (e : M), x] (code codeHistoryEvaluator) := + eval_codeHistoryEvaluator_exists s (e : M) x + +end + +section + +variable [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + +theorem stage_implies_eventual (e : ℕ) (s x y : M) (h : (stageGraph e).val.Evalb ![s, x, y]) : + (eventualGraph e).val.Evalb ![x, y] := + by + apply (eventualGraph_eval e _).mpr + refine ⟨s, ?_⟩ + simpa only [numeral_eq_natCast_app, Matrix.cons_val_zero, Matrix.cons_val_one] using + (stageGraph_eval e s x y).mp h + +end + +section + +variable [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + +theorem stage_unique (e : ℕ) (s x a b : M) (ha : (stageGraph e).val.Evalb ![s, x, a]) + (hb : (stageGraph e).val.Evalb ![s, x, b]) : a = b := + eventualGraph_output_unique e x a b (stage_implies_eventual e s x a ha) + (stage_implies_eventual e s x b hb) + +theorem failure_iff_no_stage (e : ℕ) (s x : M) : + (failureGraph e).val.Evalb ![s, x] ↔ ¬∃ y : M, (stageGraph e).val.Evalb ![s, x, y] := + by + constructor + · intro hzero + rintro ⟨y, hy⟩ + have he : y + 1 = 0 := + eval_unique ((stage_of_history e s x y).mp hy) ((failureGraph_eval e s x).mp hzero) + exact (ne_of_gt (lt_of_le_of_lt (Arithmetic.zero_le y) (lt_add_one y))) he + · intro hn + obtain ⟨z, hz⟩ := history_total e s x + have hz0 : z = 0 := + le_antisymm + (not_lt.mp + (fun hpos => + hn + ⟨z - 1, + (stage_of_history e s x (z - 1)).mpr + (by + rw [Arithmetic.sub_add_self_of_le (Arithmetic.one_le_of_zero_lt z hpos)] + exact hz)⟩)) + (Arithmetic.zero_le z) + exact (failureGraph_eval e s x).mpr (by simpa only [hz0] using hz) + +end + +section + +variable [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + +@[simp] +theorem leastGraph_eval (e : ℕ) (x s : M) : + (leastGraph e).val.Evalb ![x, s] ↔ + (∃ y : M, (stageGraph e).val.Evalb ![s, x, y]) ∧ + ∀ r < s, (failureGraph e).val.Evalb ![r, x] := + by simp [leastGraph] + +@[simp] +theorem HGraph_eval (e : ℕ) (x n : M) : + (HGraph e).val.Evalb ![x, n] ↔ ∃ s : M, (leastGraph e).val.Evalb ![x, s] ∧ n = pair s x := + by simp [HGraph] + +@[simp] +theorem BGraph_pair_eval (e : ℕ) (s x y : M) : + (BGraph e).val.Evalb ![pair s x, y] ↔ (stageGraph e).val.Evalb ![s, x, y] := by + simp [BGraph] + +@[simp] +theorem AGraph_pair_eval (e : ℕ) (G : Graph) (s x y : M) : + (AGraph e G).val.Evalb ![pair s x, y] ↔ + (stageGraph e).val.Evalb ![s, x, y] ∧ G.val.Evalb ![x, y] := + by simp [AGraph] + +end + +@[simp] +theorem intersection_eval (F G : Graph) (x y : M) : + (intersection F G).val.Evalb ![x, y] ↔ F.val.Evalb ![x, y] ∧ G.val.Evalb ![x, y] := by + simp [intersection] + +section + +variable [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + +theorem leastGraph_unique (e : ℕ) (x s t : M) (hs : (leastGraph e).val.Evalb ![x, s]) + (ht : (leastGraph e).val.Evalb ![x, t]) : s = t := + by + obtain ⟨hs, hmins⟩ := (leastGraph_eval e x s).mp hs + obtain ⟨ht, hmint⟩ := (leastGraph_eval e x t).mp ht + rcases lt_trichotomy s t with h | h | h + · exact False.elim ((failure_iff_no_stage e s x).mp (hmint s h) hs) + · exact h + · exact False.elim ((failure_iff_no_stage e t x).mp (hmins t h) ht) + +theorem leastGraph_exists (e : ℕ) (x y : M) (hy : (eventualGraph e).val.Evalb ![x, y]) : + ∃ s : M, (leastGraph e).val.Evalb ![x, s] ∧ (stageGraph e).val.Evalb ![s, x, y] := + by + have : M↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + obtain ⟨s, hs⟩ := (eventualGraph_eval e _).mp hy + have hs' : (stageGraph e).val.Evalb ![s, x, y] := + by + apply (stageGraph_eval e s x y).mpr + simpa only [numeral_eq_natCast_app, Matrix.cons_val_zero, Matrix.cons_val_one] using hs + let P : M → Prop := fun s => ∃ z : M, (stageGraph e).val.Evalb ![s, x, z] + have hP : Σ₁-Predicate P := + by + refine ⟨.mkSigma (“s. ∃ z, !(Rew.emb ▹ (stageGraph e).val)s&x z”), ?_⟩ + intro v + simp [P, Semiformula.eval_emb] + obtain ⟨t, ⟨z, hz⟩, hmin⟩ := InductionOnHierarchy.least_number_sigma Σ 1 hP ⟨y, hs'⟩ + have hzy : z = y := eventualGraph_output_unique e x z y (stage_implies_eventual e t x z hz) hy + subst z + refine ⟨t, (leastGraph_eval e x t).mpr ⟨⟨y, hz⟩, ?_⟩, hz⟩ + intro r hr + exact (failure_iff_no_stage e r x).mpr (hmin r hr) + +theorem B_comp_H_eval (e : ℕ) (x y : M) : + (comp (BGraph e) (HGraph e)).val.Evalb ![x, y] ↔ (eventualGraph e).val.Evalb ![x, y] := + by + rw [comp_eval] + constructor + · rintro ⟨n, hn, hb⟩ + obtain ⟨s, _, rfl⟩ := (HGraph_eval e x n).mp hn + exact stage_implies_eventual e s x y ((BGraph_pair_eval e s x y).mp hb) + · intro h + obtain ⟨s, hs, hy⟩ := leastGraph_exists e x y h + exact ⟨pair s x, (HGraph_eval e x _).mpr ⟨s, hs, rfl⟩, (BGraph_pair_eval e s x y).mpr hy⟩ + +theorem A_comp_H_eval (e : ℕ) (G : Graph) (x y : M) : + (comp (AGraph e G) (HGraph e)).val.Evalb ![x, y] ↔ + (intersection (eventualGraph e) G).val.Evalb ![x, y] := + by + rw [comp_eval, intersection_eval] + constructor + · rintro ⟨n, hn, ha⟩ + obtain ⟨s, _, rfl⟩ := (HGraph_eval e x n).mp hn + obtain ⟨hs, hg⟩ := (AGraph_pair_eval e G s x y).mp ha + exact ⟨stage_implies_eventual e s x y hs, hg⟩ + · rintro ⟨he, hg⟩ + obtain ⟨s, hs, hy⟩ := leastGraph_exists e x y he + exact + ⟨pair s x, (HGraph_eval e x _).mpr ⟨s, hs, rfl⟩, + (AGraph_pair_eval e G s x y).mpr ⟨hy, hg⟩⟩ + +end + +end Semantics + +theorem intersection_functional (F G : Graph) (hF : Functional F) : + Functional (intersection F G) := by + apply complete.{0} 𝐏𝐀 + intro M _ _ + have hf : M↓[ℒₒᵣ] ⊧ functionalSentence F := + consequence_iff.mp (Theory.Proof.sound hF) M inferInstance + rw [models_iff, functionalSentence_eval] at hf ⊢ + intro x y z hy hz + exact hf x y z ((intersection_eval F G x y).mp hy).1 ((intersection_eval F G x z).mp hz).1 + +theorem intersection_comm_uniform (F G : Graph) : + Uniform 𝐏𝐀 (intersection F G) (intersection G F) := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + rw [models_iff, uniformSentence_eval] + intro x y + simp only [intersection_eval, and_comm] + +theorem HGraph_functional (e : ℕ) : Functional (HGraph e) := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + have : M↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + rw [models_iff, functionalSentence_eval] + intro x a b ha hb + obtain ⟨s, hs, rfl⟩ := (HGraph_eval e x a).mp ha + obtain ⟨t, ht, rfl⟩ := (HGraph_eval e x b).mp hb + rw [leastGraph_unique e x s t hs ht] + +theorem BGraph_functional (e : ℕ) : Functional (BGraph e) := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + have : M↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + rw [models_iff, functionalSentence_eval] + intro n a b ha hb + rw [← pair_unpair n, BGraph_pair_eval] at ha hb + exact stage_unique e (pi₁ n) (pi₂ n) a b ha hb + +theorem AGraph_functional (e : ℕ) (G : Graph) : Functional (AGraph e G) := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + have : M↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + rw [models_iff, functionalSentence_eval] + intro n a b ha hb + rw [← pair_unpair n, AGraph_pair_eval] at ha hb + exact stage_unique e (pi₁ n) (pi₂ n) a b ha.1 hb.1 + +theorem B_comp_H (e : ℕ) : Uniform 𝐏𝐀 (comp (BGraph e) (HGraph e)) (eventualGraph e) := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + have : M↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + rw [models_iff, uniformSentence_eval] + exact B_comp_H_eval e + +theorem A_comp_H (e : ℕ) (G : Graph) : + Uniform 𝐏𝐀 (comp (AGraph e G) (HGraph e)) (intersection (eventualGraph e) G) := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + have : M↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + rw [models_iff, uniformSentence_eval] + exact A_comp_H_eval e G + +end GeneratedWitnessGraphs +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/GeneratedWitnessPointwise.lean b/LeanPool/PointwiseComposition/FailureOfComposition/GeneratedWitnessPointwise.lean new file mode 100644 index 000000000..32472f82f --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/GeneratedWitnessPointwise.lean @@ -0,0 +1,130 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.PiOneExtensionality +public import LeanPool.PointwiseComposition.FailureOfComposition.GeneratedWitnessGraphs + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +The stage-restricted witnesses are pointwise PA-equivalent whenever the +underlying graphs agree on the standard naturals. A true ground equation for +the total history evaluator fixes all possible internal outputs at that +standard stage and input. No uniform equivalence premise is assumed. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic FFL.Entailment + +open CategoricalRiceShapiro.ArithmeticCode CategoricalRiceShapiro.Evaluator + +namespace FailureOfComposition +namespace GeneratedWitnessGraphs + +open ProofSearch ConcreteEvaluator PiOneCharacterization + +private theorem history_output_at_numerals (e s x z : ℕ) + (hz : Semiformula.Evalb ![z, s, e, x] (code codeHistoryEvaluator)) {M : Type*} + [ORingStructure M] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] : + Semiformula.Evalb ![(z : M), (s : M), (e : M), (x : M)] (code codeHistoryEvaluator) := + by + have htr := + FFL.FirstOrder.Arithmetic.bold_sigma_one_completeness' (M := M) + (code_sigma_one codeHistoryEvaluator) hz + rw [numeral_eq_natCast] at htr + have heq : (Nat.cast ∘ ![z, s, e, x] : Fin 4 → M) = ![(z : M), (s : M), (e : M), (x : M)] := + by + funext i + refine Fin.cases ?_ ?_ i + · rfl + · intro i1 + refine Fin.cases ?_ ?_ i1 + · rfl + · intro i2 + refine Fin.cases ?_ ?_ i2 + · rfl + · intro i3 + refine Fin.cases ?_ (fun i4 => Fin.elim0 i4) i3 + rfl + rw [heq] at htr + exact htr + +/-- A fixed standard stage can only return its genuine standard output in +any PA model. Standard agreement then supplies the second graph at that output. -/ +private theorem standard_stage_implies_graph (e : ℕ) (G : Graph) + (hExt : Extensional (eventualGraph e) G) (s x : ℕ) {M : Type*} [ORingStructure M] + [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (y : M) + (hy : + Semiformula.Evalb ![(s : M), (e : M), (x : M), y] + (evalnCertificateFormula : ArithmeticSemisentence 4)) : + G.val.Evalb ![(x : M), y] := + by + have : M↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + obtain ⟨z, hz⟩ := eval_codeHistoryEvaluator_exists (s : ℕ) e x + have hzM := history_output_at_numerals e s x z hz (M := M) + have hyz := eval_unique ((evalnCertificateFormula_eval_history_iff _ _ _ _).mp hy) hzM + cases z with + | zero => + have heq : y + 1 = 0 := by simpa only [Nat.cast_zero] using hyz + exact False.elim ((ne_of_gt (lt_of_le_of_lt (Arithmetic.zero_le y) (lt_add_one y))) heq) + | succ m => + have heq : y = (m : M) := by simpa using hyz + have hm : + Semiformula.Evalb ![s, e, x, m] (evalnCertificateFormula : ArithmeticSemisentence 4) := + (evalnCertificateFormula_eval_history_iff s e x m).mpr (by simpa using hz) + have hE : (eventualGraph e).val.Evalb ![x, m] := + by + apply (eventualGraph_eval e _).mpr + refine ⟨s, ?_⟩ + simpa only [numeral_eq_natCast_app, natCast_nat, Matrix.cons_val_zero, + Matrix.cons_val_one] using hm + have hG := true_graph_instance_provable G x m ((hExt x m).mp hE) + have hv := consequence_iff.mp (Theory.Proof.sound hG) M inferInstance + have hval : G.val.Evalb ![(x : M), (m : M)] := by + simpa only [models_iff, graphInstance_eval] using hv + simpa only [heq] using hval + +/-- At each fixed standard stage/input pair, PA proves equality of the two +witness graphs over all internal outputs. -/ +theorem AGraph_eqAt_B_pair (e : ℕ) (G : Graph) (hExt : Extensional (eventualGraph e) G) + (s x : ℕ) : 𝐏𝐀 ⊢ eqAt (AGraph e G) (BGraph e) (Nat.pair s x) := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + have : M↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + rw [models_iff, eqAt_eval] + intro y + rw [coe_pair_eq_pair_coe, AGraph_pair_eval, BGraph_pair_eval] + constructor + · exact And.left + · intro h + exact + ⟨h, + standard_stage_implies_graph e G hExt s x y + ((stageGraph_eval e (s : M) (x : M) y).mp h)⟩ + +/-- Standard equality of the original graphs suffices for pointwise +PA-provable equality of the stage-restricted witnesses. No functionality +assumption on G and no uniform-equivalence premise is needed. -/ +theorem AGraph_pointwise_B (e : ℕ) (G : Graph) (hExt : Extensional (eventualGraph e) G) : + Pointwise 𝐏𝐀 (AGraph e G) (BGraph e) := by + intro n + simpa only [Nat.pair_unpair] using + AGraph_eqAt_B_pair e G hExt (Nat.unpair n).1 (Nat.unpair n).2 + +end GeneratedWitnessGraphs +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/GodelGraph.lean b/LeanPool/PointwiseComposition/FailureOfComposition/GodelGraph.lean new file mode 100644 index 000000000..6e60780ed --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/GodelGraph.lean @@ -0,0 +1,75 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.GraphQuotient +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Incompleteness.Second +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Incompleteness.Definability + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +Graph witnesses for the second-incompleteness obstruction. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +open FFL.FirstOrder.Arithmetic.Bootstrapping FFL.Entailment + +namespace FailureOfComposition + +theorem proofBot_consistency_bridge (T : ArithmeticTheory) [T.Δ₁] : + 𝐏𝐀 ⊢ (“(∀ p, ¬!(ProofSearch.proofTarget T ⊥).sigma p) ↔ !T.consistent.val”) := + by + apply complete.{0} 𝐏𝐀 + intro V _ _ + have : V↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + simp [models_iff, Theory.consistent, Bootstrapping.Provable] + +theorem numeral_nonproof_of_consistency (T : ArithmeticTheory) [T.Δ₁] [Consistent T] (n : ℕ) : + 𝐏𝐀 ⊢ (ProofSearch.notProofTarget T ⊥).val/[n] := + ProofSearch.numeral_negative T ⊥ + (consistent_iff_unprovable_bot.mp (inferInstance : Consistent T)) n + +/-- The second-incompleteness route to noncongruence for functional graphs. -/ +theorem graph_noncongruence_via_godel (T : ArithmeticTheory) [T.Δ₁] [Consistent T] [𝐏𝐀 ≼ T] : + ∃ F I G : ProofSearch.Graph, + ProofSearch.Functional F ∧ + ProofSearch.Functional I ∧ + ProofSearch.Functional G ∧ + ProofSearch.Pointwise T F I ∧ + ¬ProofSearch.Pointwise T (ProofSearch.comp F G) (ProofSearch.comp I G) := + by + let : 𝐈Σ₁ ≼ T := WeakerThan.trans (𝓣 := 𝐏𝐀) inferInstance inferInstance + apply ProofSearch.functional_graph_noncongruence T ⊥ T + · exact consistent_iff_unprovable_bot.mp (inferInstance : Consistent T) + · simpa [Theory.consistent] using consistent_unprovable T + +theorem pa_graph_noncongruence_via_godel : + ∃ F I G : ProofSearch.Graph, + ProofSearch.Functional F ∧ + ProofSearch.Functional I ∧ + ProofSearch.Functional G ∧ + ProofSearch.Pointwise 𝐏𝐀 F I ∧ + ¬ProofSearch.Pointwise 𝐏𝐀 (ProofSearch.comp F G) (ProofSearch.comp I G) := + graph_noncongruence_via_godel 𝐏𝐀 + +theorem no_graph_quotient_composition_via_godel (T : ArithmeticTheory) [T.Δ₁] [Consistent T] + [𝐏𝐀 ≼ T] : ProofSearch.NoQuotientComposition T := + ProofSearch.no_quotient_composition_of_graph_noncongruence T (graph_noncongruence_via_godel T) + +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/GraphQuotient.lean b/LeanPool/PointwiseComposition/FailureOfComposition/GraphQuotient.lean new file mode 100644 index 000000000..26eafe44d --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/GraphQuotient.lean @@ -0,0 +1,128 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.ProofSearchTemplate +public import LeanPool.PointwiseComposition.FailureOfComposition.QuotientObstruction + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +Pointwise graph equality and quotient operations. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic FFL.Entailment + +namespace FailureOfComposition +namespace ProofSearch + +noncomputable section + +theorem pointwise_equivalence (T : ArithmeticTheory) [𝐏𝐀 ≼ T] : Equivalence (Pointwise T) + where + refl F + n := by + apply WeakerThan.pbl (𝓢 := 𝐏𝐀) + apply complete.{0} 𝐏𝐀 + intro V _ _ + have : V↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + simp [models_iff, eqAt] + symm := by + intro F G h n + have hs : 𝐏𝐀 ⊢ eqAt F G n ⇒ₗ eqAt G F n := + by + apply complete.{0} 𝐏𝐀 + intro V _ _ + have : V↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + simp only [Semantics.Imp.models_imply, models_iff, eqAt_eval, Nat.succ_eq_add_one, + Nat.reduceAdd] + intro h y + exact (h y).symm + exact Entailment.mdp (WeakerThan.pbl hs) (h n) + trans := by + intro F G H hFG hGH n + have ht : 𝐏𝐀 ⊢ eqAt F G n ⇒ₗ eqAt G H n ⇒ₗ eqAt F H n := + by + apply complete.{0} 𝐏𝐀 + intro V _ _ + have : V↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + simp only [Semantics.Imp.models_imply, models_iff, eqAt_eval, Nat.succ_eq_add_one, + Nat.reduceAdd] + intro hfg hgh y + exact (hfg y).trans (hgh y) + exact Entailment.mdp (Entailment.mdp (WeakerThan.pbl ht) (hFG n)) (hGH n) + +theorem comp_functional {F G : Graph} (hF : Functional F) (hG : Functional G) : + Functional (comp F G) := by + apply complete.{0} 𝐏𝐀 + intro V _ _ + have : V↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + have hf : V↓[ℒₒᵣ] ⊧ functionalSentence F := + consequence_iff.mp (Theory.Proof.sound hF) V inferInstance + have hg : V↓[ℒₒᵣ] ⊧ functionalSentence G := + consequence_iff.mp (Theory.Proof.sound hG) V inferInstance + simp only [models_iff, functionalSentence_eval, Nat.succ_eq_add_one, Nat.reduceAdd] at hf hg + simp only [models_iff, functionalSentence_eval, Nat.succ_eq_add_one, Nat.reduceAdd, comp_eval, + Fin.isValue, Matrix.cons_val_zero, Matrix.cons_val_one, Fin.Fin1.eq_one, + Matrix.cons_val_fin_one, forall_exists_index, and_imp] + intro x y z a hga hfay b hgb hfbz + have hab := hg x a b hga hgb + subst b + exact hf a y z hfay hfbz + +/-- The Functional Graph construction in `FailureOfComposition.ProofSearch`. -/ +def FunctionalGraph := + { F : Graph // Functional F } + +/-- The functional Comp construction in `FailureOfComposition.ProofSearch`. -/ +def functionalComp (F G : FunctionalGraph) : FunctionalGraph := + ⟨comp F.val G.val, comp_functional F.property G.property⟩ + +/-- The pointwise Setoid construction in `FailureOfComposition.ProofSearch`. -/ +def pointwiseSetoid (T : ArithmeticTheory) [𝐏𝐀 ≼ T] : Setoid FunctionalGraph + where + r F G := Pointwise T F.val G.val + iseqv := + { refl := fun F => (pointwise_equivalence T).refl F.val + symm := fun h => (pointwise_equivalence T).symm h + trans := fun h₁ h₂ => (pointwise_equivalence T).trans h₁ h₂ } + +/-- The No Quotient Composition construction in `FailureOfComposition.ProofSearch`. -/ +def NoQuotientComposition (T : ArithmeticTheory) [𝐏𝐀 ≼ T] : Prop := + ¬∃ C : + Quotient (pointwiseSetoid T) → + Quotient (pointwiseSetoid T) → Quotient (pointwiseSetoid T), + ∀ F G, + C (Quotient.mk (pointwiseSetoid T) F) (Quotient.mk (pointwiseSetoid T) G) = + Quotient.mk (pointwiseSetoid T) (functionalComp F G) + +theorem no_quotient_composition_of_graph_noncongruence (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (h : + ∃ F I G : Graph, + Functional F ∧ + Functional I ∧ Functional G ∧ Pointwise T F I ∧ ¬Pointwise T (comp F G) (comp I G)) : + NoQuotientComposition T := + by + obtain ⟨F, I, G, hF, hI, hG, hFI, hcomp⟩ := h + exact + FailureOfComposition.no_quotient_composition_of_noncongruence (pointwiseSetoid T) + functionalComp ⟨F, hF⟩ ⟨I, hI⟩ ⟨G, hG⟩ hFI hcomp + +end + +end ProofSearch +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/HistoryObstruction.lean b/LeanPool/PointwiseComposition/FailureOfComposition/HistoryObstruction.lean new file mode 100644 index 000000000..ee529bb9b --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/HistoryObstruction.lean @@ -0,0 +1,162 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.HistoryWitnesses +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteDiagonal + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +The composition obstruction from unprovable diagonal history divergence. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic FFL.Entailment + +open CategoricalRiceShapiro.Evaluator + +namespace FailureOfComposition +namespace HistoryWitnesses + +open ProofSearch ConcreteEvaluator + +/-- The history Zero Formula construction in `FailureOfComposition.HistoryWitnesses`. -/ +def historyZeroFormula (d : ℕ) : Σ₁.Semisentence 1 := + .mkSigma (“s. !(historyGraph d).val s 0”) + +/-- The history Positive Formula construction in `FailureOfComposition.HistoryWitnesses`. -/ +def historyPositiveFormula (d : ℕ) : Σ₁.Semisentence 1 := + .mkSigma (“s. ∃ z, 0 < z ∧ !(historyGraph d).val s z”) + +variable {M : Type*} [ORingStructure M] + +theorem history_positive_iff [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (d : ℕ) (s : M) : + (∃ z : M, 0 < z ∧ (historyGraph d).val.Evalb ![s, z]) ↔ + ∃ y : M, + Semiformula.Evalb ![s, (d : M), (d : M), y] + (evalnCertificateFormula : ArithmeticSemisentence 4) := + by + constructor + · rintro ⟨z, hz, h⟩ + refine ⟨z - 1, (evalnCertificateFormula_eval_history_iff _ _ _ _).mpr ?_⟩ + rw [Arithmetic.sub_add_self_of_le (Arithmetic.one_le_of_zero_lt z hz)] + exact (historyGraph_eval d s z).mp h + · rintro ⟨y, h⟩ + refine ⟨y + 1, lt_of_le_of_lt (Arithmetic.zero_le y) (lt_add_one y), ?_⟩ + exact + (historyGraph_eval d s (y + 1)).mpr + ((evalnCertificateFormula_eval_history_iff _ _ _ _).mp h) + +theorem diagonalHistory_iff [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (d : ℕ) : + (diagonalHistoryFormula/[d]).Evalb (M := M) ![] ↔ + ∃ s z : M, 0 < z ∧ (historyGraph d).val.Evalb ![s, z] := + by + simp only [diagonalHistoryFormula, Semiformula.eval_substs] + simpa [numeral_eq_natCast] using (exists_congr fun s : M => (history_positive_iff d s).symm) + +theorem history_zero_iff_no_positive [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (d : ℕ) (s : M) : + (historyGraph d).val.Evalb ![s, 0] ↔ ¬∃ z : M, 0 < z ∧ (historyGraph d).val.Evalb ![s, z] := + by + constructor + · rintro h0 ⟨z, hz, h⟩ + exact (ne_of_gt hz) (history_unique d s z 0 h h0) + · intro hn + obtain ⟨z, hz⟩ := history_total d s + have hz0 : z = 0 := + le_antisymm (not_lt.mp (fun hpos => hn ⟨z, hpos, hz⟩)) (Arithmetic.zero_le z) + simpa only [hz0] using hz + +theorem guard_pointwise_identity (T : ArithmeticTheory) [𝐏𝐀 ≼ T] (d : ℕ) + (hdiv : ¬diagonalHistoryFormula.Evalb ![d]) : Pointwise T (guardGraph d) identity := + by + intro n + have hn : (historyZeroFormula d).val.Evalb ![n] := + by + have h0 : (historyGraph d).val.Evalb ![n, (0 : ℕ)] := + by + apply (history_zero_iff_no_positive d n).mpr + intro hpos + apply hdiv + have hh := (diagonalHistory_iff d).mpr ⟨n, hpos⟩ + simpa [Semiformula.eval_substs] using hh + simpa [historyZeroFormula] using h0 + have hp : 𝐏𝐀 ⊢ (historyZeroFormula d).val/[n] := + by + apply sigma_one_completeness (by simp) + simpa [models_iff, Semiformula.eval_substs] using hn + have hi : 𝐏𝐀 ⊢ (historyZeroFormula d).val/[n] ⇒ₗ eqAt (guardGraph d) identity n := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + simp [models_iff, historyZeroFormula, eqAt, guardGraph, identity, Semiformula.eval_substs] + exact WeakerThan.pbl (Entailment.mdp hi hp) + +theorem search_empty_implies_absence (d : ℕ) : + 𝐏𝐀 ⊢ eqAt (searchGraph d) empty 0 ⇒ₗ ∼diagonalHistoryFormula/[d] := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + have : M↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + simp only [models_iff, LogicalConnective.HomClass.map_imply, + LogicalConnective.HomClass.map_neg] + intro he hh + obtain ⟨s, hs⟩ := (diagonalHistory_iff d).mp hh + let P : M → Prop := fun s => ∃ z : M, 0 < z ∧ (historyGraph d).val.Evalb ![s, z] + have hP : Σ₁-Predicate P := + by + refine ⟨(historyPositiveFormula d).rew Rew.emb, ?_⟩ + intro v + simp [P, historyPositiveFormula] + obtain ⟨t, ht, hmin⟩ := InductionOnHierarchy.least_number_sigma Σ 1 hP hs + have hsearch : (searchGraph d).val.Evalb ![(0 : M), t] := + by + apply (searchGraph_eval d _).mpr + refine ⟨ht, fun r hr => ?_⟩ + exact (history_zero_iff_no_positive d r).mpr (hmin r hr) + have hEq := (eqAt_eval (searchGraph d) empty 0).mp he t + exact (empty_eval _).mp (hEq.mp hsearch) + +theorem graph_noncongruence_of_history_divergence (T : ArithmeticTheory) [𝐏𝐀 ≼ T] (d : ℕ) + (hdiv : ¬diagonalHistoryFormula.Evalb ![d]) (hnot : T ⊬ ∼diagonalHistoryFormula/[d]) : + Pointwise T (guardGraph d) identity ∧ + ¬Pointwise T (comp (guardGraph d) (searchGraph d)) (comp identity (searchGraph d)) := + by + refine ⟨guard_pointwise_identity T d hdiv, ?_⟩ + intro he + have hi : + 𝐏𝐀 ⊢ + eqAt (comp (guardGraph d) (searchGraph d)) (comp identity (searchGraph d)) 0 ⇒ₗ + eqAt (searchGraph d) empty 0 := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + have : M↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + have hempty := + consequence_iff.mp (Theory.Proof.sound (guard_search_empty d)) M inferInstance + have hid := + consequence_iff.mp (Theory.Proof.sound (identity_comp (searchGraph d))) M inferInstance + simp only [models_iff, uniformSentence_eval] at hempty hid + simp only [models_iff, LogicalConnective.HomClass.map_imply, eqAt_eval] + intro h y + exact (hid 0 y).symm.trans ((h y).symm.trans (hempty 0 y)) + exact + hnot + (Entailment.mdp (WeakerThan.pbl (search_empty_implies_absence d)) + (Entailment.mdp (WeakerThan.pbl hi) (he 0))) + +end HistoryWitnesses +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/HistoryWitnesses.lean b/LeanPool/PointwiseComposition/FailureOfComposition/HistoryWitnesses.lean new file mode 100644 index 000000000..e56d2c99a --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/HistoryWitnesses.lean @@ -0,0 +1,232 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteEvaluatorGraph +public import Mathlib.Tactic.FinCases + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +Arithmetic programs for the direct computation-search obstruction. The checked +function is the existing history evaluator at the diagonal input. All graph +equations in this file concern arbitrary PA-model inputs, not only numerals. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic FFL.Entailment + +open Nat.ArithPart₁ + +open CategoricalRiceShapiro.ArithmeticCode CategoricalRiceShapiro.Evaluator + +namespace FailureOfComposition +namespace HistoryWitnesses + +open ProofSearch + +/-- The history Code construction in `FailureOfComposition.HistoryWitnesses`. -/ +def historyCode (d : ℕ) : Code 1 := + codeHistoryEvaluator.comp ![Code.proj 0, codeConst d, codeConst d] + +/-- The guard Code construction in `FailureOfComposition.HistoryWitnesses`. -/ +def guardCode (d : ℕ) : Code 1 := + codeBind (codeLift (historyCode d)).rfind (Code.proj 1) + +/-- The search Code construction in `FailureOfComposition.HistoryWitnesses`. -/ +def searchCode (d : ℕ) : Code 1 := + codeRfindPos ((historyCode d).comp ![Code.proj 0]) + +/-- The raw History Graph construction in `FailureOfComposition.HistoryWitnesses`. -/ +def rawHistoryGraph (d : ℕ) : Graph := + .mkSigma (code (historyCode d)) (code_sigma_one (historyCode d)) + +/-- The history Graph construction in `FailureOfComposition.HistoryWitnesses`. -/ +def historyGraph (d : ℕ) : Graph := + (rawHistoryGraph d).rew (Rew.subst ![(#1 : ArithmeticSemiterm Empty 2), #0]) + +/-- The guard Graph construction in `FailureOfComposition.HistoryWitnesses`. -/ +def guardGraph (d : ℕ) : Graph := + .mkSigma (“x y. !(historyGraph d).val x 0 ∧ y = x”) + +/-- The search Graph construction in `FailureOfComposition.HistoryWitnesses`. -/ +def searchGraph (d : ℕ) : Graph := + .mkSigma + (“x y. (∃ z, 0 < z ∧ !(historyGraph d).val y z) ∧ ∀ r < y, !(historyGraph d).val r 0”) + +variable {M : Type*} [ORingStructure M] + +private theorem historyGraph_code_eval (d : ℕ) (s z : M) : + (historyGraph d).val.Evalb ![s, z] ↔ Semiformula.Evalb ![z, s] (code (historyCode d)) := + by + have hb : + (fun x : Fin 2 => + Semiterm.val ![s, z] (Empty.elim : Empty → M) + ((Rew.subst ![(#1 : ArithmeticSemiterm Empty 2), #0]) (#x : Semiterm ℒₒᵣ Empty 2))) = + ![z, s] := + by + funext x + refine Fin.cases ?_ ?_ x + · simp + · intro i + refine Fin.cases ?_ (fun j => Fin.elim0 j) i + simp + have hf : + (fun x : Empty => + Semiterm.val ![s, z] (Empty.elim : Empty → M) + ((Rew.subst ![(#1 : ArithmeticSemiterm Empty 2), #0]) (&x))) = + Empty.elim := + funext (fun x => x.elim) + simp only [historyGraph, rawHistoryGraph, HierarchySymbol.Semiformula.val_rew, + HierarchySymbol.Semiformula.val_mkSigma, Semiformula.eval_rew, Function.comp_def, hb, hf] + +@[simp] +theorem guardGraph_eval (d : ℕ) (v : Fin 2 → M) : + (guardGraph d).val.Evalb v ↔ (historyGraph d).val.Evalb ![v 0, 0] ∧ v 1 = v 0 := by + simp [guardGraph] + +@[simp] +theorem searchGraph_eval (d : ℕ) (v : Fin 2 → M) : + (searchGraph d).val.Evalb v ↔ + (∃ z : M, 0 < z ∧ (historyGraph d).val.Evalb ![v 1, z]) ∧ + ∀ r < v 1, (historyGraph d).val.Evalb ![r, 0] := + by simp [searchGraph] + +theorem eval_rfind_iff {n : ℕ} (c : Code (n + 1)) (y : M) (v : Fin n → M) : + Semiformula.Evalb (y :> v) (code c.rfind) ↔ + Semiformula.Evalb ((0 : M) :> y :> v) (code c) ∧ + ∀ r < y, ∃ z : M, z ≠ 0 ∧ Semiformula.Evalb (z :> r :> v) (code c) := + by + have bridge {k : ℕ} (a : Code k) (v : Fin (k + 1) → M) : + Semiformula.Evalb v (code a) ↔ Semiformula.Evalf v (codeAux a) := by + simp [code, Semiformula.eval_rew, Matrix.empty_eq, Function.comp_def] + simp only [bridge] + simp [codeAux, Semiformula.eval_rew, Function.comp_def, Matrix.empty_eq, Matrix.comp_vecCons'] + +theorem historyCode_eval [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (d : ℕ) (s z : M) : + Semiformula.Evalb ![z, s] (code (historyCode d)) ↔ + Semiformula.Evalb ![z, s, (d : M), (d : M)] (code codeHistoryEvaluator) := + by + rw [historyCode, eval_comp_iff] + constructor + · rintro ⟨v, hv, hi⟩ + have h0 := (eval_proj_iff 0 (v 0) ![s]).mp (hi 0) + have h1 := (eval_codeConst_iff d (v 1) ![s]).mp (hi 1) + have h2 := (eval_codeConst_iff d (v 2) ![s]).mp (hi 2) + have he : v = ![s, (d : M), (d : M)] := by ext i; fin_cases i <;> simp_all + simpa only [he] using hv + · intro h + refine ⟨![s, (d : M), (d : M)], h, ?_⟩ + intro i + fin_cases i + · exact (eval_proj_iff _ _ _).mpr rfl + · exact eval_codeConst d ![s] + · exact eval_codeConst d ![s] + +@[simp] +theorem historyGraph_eval [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (d : ℕ) (s z : M) : + (historyGraph d).val.Evalb ![s, z] ↔ + Semiformula.Evalb ![z, s, (d : M), (d : M)] (code codeHistoryEvaluator) := + by exact (historyGraph_code_eval d s z).trans (historyCode_eval d s z) + +theorem history_total [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (d : ℕ) (s : M) : + ∃ z : M, (historyGraph d).val.Evalb ![s, z] := by + simpa using eval_codeHistoryEvaluator_exists s (d : M) (d : M) + +theorem history_unique [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (d : ℕ) (s a b : M) + (ha : (historyGraph d).val.Evalb ![s, a]) (hb : (historyGraph d).val.Evalb ![s, b]) : + a = b := + eval_unique ((historyGraph_eval d s a).mp ha) ((historyGraph_eval d s b).mp hb) + +theorem headHistory_eval (d : ℕ) (s x z : M) : + Semiformula.Evalb ![z, s, x] (code ((historyCode d).comp ![Code.proj 0])) ↔ + Semiformula.Evalb ![z, s] (code (historyCode d)) := + by + rw [eval_comp_iff] + constructor + · rintro ⟨v, hv, hi⟩ + have h0 : v 0 = s := (eval_proj_iff _ _ _).mp (hi 0) + have he : v = ![s] := by ext i; fin_cases i; exact h0 + simpa only [he] using hv + · intro h + exact ⟨![s], h, fun i => by fin_cases i; exact (eval_proj_iff _ _ _).mpr rfl⟩ + +theorem guardCode_eval [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (d : ℕ) (x y : M) : + Semiformula.Evalb ![y, x] (code (guardCode d)) ↔ (guardGraph d).val.Evalb ![x, y] := + by + simp only [guardCode, eval_codeBind_iff, eval_proj_iff, eval_rfind_iff, eval_codeLift_iff, + Matrix.cons_val_one, Matrix.cons_val_fin_one] + rw [guardGraph_eval, historyGraph_code_eval] + constructor + · rintro ⟨_, ⟨h, _⟩, hy⟩ + exact ⟨h, hy⟩ + · rintro ⟨h, hy⟩ + refine ⟨0, ⟨h, ?_⟩, hy⟩ + intro r hr + exact False.elim ((not_lt_of_ge (Arithmetic.zero_le r)) hr) + +theorem searchCode_eval [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (d : ℕ) (x y : M) : + Semiformula.Evalb ![y, x] (code (searchCode d)) ↔ (searchGraph d).val.Evalb ![x, y] := + by + rw [searchCode, eval_codeRfindPos_iff] + rw [searchGraph_eval] + exact + and_congr + (exists_congr fun z => + and_congr Iff.rfl + ((headHistory_eval d y x z).trans (historyGraph_code_eval d y z).symm)) + (forall_congr' fun r => + imp_congr Iff.rfl + ((headHistory_eval d r x 0).trans (historyGraph_code_eval d r 0).symm)) + +theorem guard_functional (d : ℕ) : Functional (guardGraph d) := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + simp only [models_iff, functionalSentence_eval, guardGraph_eval, Matrix.cons_val_zero, + Matrix.cons_val_one] + intro x y z hy hz + exact hy.2.trans hz.2.symm + +theorem search_functional (d : ℕ) : Functional (searchGraph d) := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + have : M↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + rw [models_iff, functionalSentence_eval] + intro x y z hy hz + obtain ⟨⟨a, ha, hay⟩, hminy⟩ := (searchGraph_eval d _).mp hy + obtain ⟨⟨b, hb, hbz⟩, hminz⟩ := (searchGraph_eval d _).mp hz + rcases lt_trichotomy y z with h | h | h + · exact False.elim ((ne_of_gt ha) (history_unique d y a 0 hay (hminz y h))) + · exact h + · exact False.elim ((ne_of_gt hb) (history_unique d z b 0 hbz (hminy z h))) + +theorem guard_search_empty (d : ℕ) : Uniform 𝐏𝐀 (comp (guardGraph d) (searchGraph d)) empty := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + have : M↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + rw [models_iff, uniformSentence_eval] + intro x y + simp only [comp_eval, empty_eval, iff_false] + rintro ⟨z, hz, hg⟩ + obtain ⟨⟨a, ha, haz⟩, _⟩ := (searchGraph_eval d _).mp hz + have h0 := ((guardGraph_eval d _).mp hg).1 + exact (ne_of_gt ha) (history_unique d z a 0 haz h0) + +end HistoryWitnesses +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/KleeneNormalForm.lean b/LeanPool/PointwiseComposition/FailureOfComposition/KleeneNormalForm.lean new file mode 100644 index 000000000..fd4bfc103 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/KleeneNormalForm.lean @@ -0,0 +1,142 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.Productiveness + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +A concrete primitive recursive normal-form predicate for Mathlib's numbering. +A witness pairs a fuel bound with the output. It is not asserted to be the +historical computation-history coding of Odifreddi or Di Paola--Montagna. +All theorems in this module concern standard natural numbers, not PA derivations. +-/ + +@[expose] public section + +namespace FailureOfComposition +namespace Kleene + +open Encodable Denumerable _root_.Nat.Partrec + +/-- The eval construction in `FailureOfComposition.Kleene`. -/ +def eval (e x : ℕ) : Part ℕ := + Code.eval (ofNat Code e) x + +/-- The T₁ construction in `FailureOfComposition.Kleene`. -/ +def T₁ (e x s : ℕ) : Prop := + Code.evaln s.unpair.1 (ofNat Code e) x = some s.unpair.2 + +/-- The U construction in `FailureOfComposition.Kleene`. -/ +def U (s : ℕ) : ℕ := + s.unpair.2 + +instance (e x s : ℕ) : Decidable (T₁ e x s) := + inferInstanceAs (Decidable (Code.evaln s.unpair.1 (ofNat Code e) x = some s.unpair.2)) + +theorem T₁_primrec : PrimrecPred (fun p : (ℕ × ℕ) × ℕ => T₁ p.1.1 p.1.2 p.2) := + by + apply Primrec.eq.comp + · exact + Code.primrec_evaln.comp + (((Primrec.fst.comp (Primrec.unpair.comp Primrec.snd)).pair + ((Primrec.ofNat Code).comp (Primrec.fst.comp Primrec.fst))).pair + (Primrec.snd.comp Primrec.fst)) + · exact Primrec.option_some.comp (Primrec.snd.comp (Primrec.unpair.comp Primrec.snd)) + +theorem U_primrec : Primrec U := + Primrec.snd.comp Primrec.unpair + +theorem normal_form (e x y : ℕ) : y ∈ eval e x ↔ ∃ s, T₁ e x s ∧ U s = y := + by + rw [eval, Code.evaln_complete] + constructor + · rintro ⟨k, hk⟩ + exact ⟨Nat.pair k y, by simpa [T₁] using hk, by simp [U]⟩ + · rintro ⟨s, hs, rfl⟩ + exact ⟨s.unpair.1, hs⟩ + +theorem halts_iff (e x : ℕ) : (eval e x).Dom ↔ ∃ s, T₁ e x s := + by + constructor + · intro h + obtain ⟨s, hs, _⟩ := (normal_form e x _).mp (Part.get_mem h) + exact ⟨s, hs⟩ + · rintro ⟨s, hs⟩ + exact ((normal_form e x (U s)).mpr ⟨s, hs, rfl⟩).1 + +theorem output_unique {e x s t : ℕ} (hs : T₁ e x s) (ht : T₁ e x t) : U s = U t := + Part.mem_unique ((normal_form e x _).mpr ⟨s, hs, rfl⟩) ((normal_form e x _).mpr ⟨t, ht, rfl⟩) + +/-- The least successful witness computes the same output as any successful witness. -/ +theorem least_witness (e x : ℕ) (h : ∃ s, T₁ e x s) : + T₁ e x (Nat.find h) ∧ + (∀ t < Nat.find h, ¬T₁ e x t) ∧ (∀ y, y ∈ eval e x ↔ U (Nat.find h) = y) := + by + refine ⟨Nat.find_spec h, ?_, ?_⟩ + · intro t ht + exact Nat.find_min h ht + · intro y + constructor + · intro hy + exact Part.mem_unique ((normal_form e x _).mpr ⟨_, Nat.find_spec h, rfl⟩) hy + · intro hy + exact (normal_form e x y).mpr ⟨_, Nat.find_spec h, hy⟩ + +/-- Kleene's least-witness equation, with the concrete coding above. -/ +theorem normal_form_equation (e x : ℕ) : + eval e x = (Nat.rfind (fun s => Part.some (decide (T₁ e x s)))).map U := + by + apply Part.ext + intro y + rw [Part.mem_map_iff] + constructor + · intro hy + obtain ⟨s, hs, _⟩ := (normal_form e x y).mp hy + obtain ⟨ht, hmin, hout⟩ := least_witness e x ⟨s, hs⟩ + refine ⟨_, Nat.mem_rfind.mpr ?_, (hout y).mp hy⟩ + constructor + · simpa using ht + · intro m hm + simpa using hmin m hm + · rintro ⟨s, hs, hy⟩ + have hs' : T₁ e x s := by simpa using (Nat.mem_rfind.mp hs).1 + exact (normal_form e x y).mpr ⟨s, hs', hy⟩ + +/-- The comp Index construction in `FailureOfComposition.Kleene`. -/ +def compIndex (f g : ℕ) : ℕ := + encode (Code.comp (ofNat Code f) (ofNat Code g)) + +theorem compIndex_primrec : Primrec₂ compIndex := + Primrec.encode.comp + (Code.primrec₂_comp.comp ((Primrec.ofNat Code).comp Primrec.fst) + ((Primrec.ofNat Code).comp Primrec.snd)) + +theorem eval_compIndex (f g x : ℕ) : eval (compIndex f g) x = (eval g x).bind (eval f) := + by + simp only [eval, compIndex, Denumerable.ofNat_encode, Code.eval] + rfl + +theorem normal_form_comp (f g x z : ℕ) : + (∃ s, T₁ (compIndex f g) x s ∧ U s = z) ↔ + ∃ y, (∃ s, T₁ g x s ∧ U s = y) ∧ (∃ t, T₁ f y t ∧ U t = z) := + by simp only [← normal_form, eval_compIndex, Part.mem_bind_iff] + +theorem diagonalHalts_iff (d : ℕ) : FailureOfComposition.diagonalHalts d ↔ ∃ s, T₁ d d s := + halts_iff d d + +end Kleene +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/ManuscriptObstruction.lean b/LeanPool/PointwiseComposition/FailureOfComposition/ManuscriptObstruction.lean new file mode 100644 index 000000000..8565a75ad --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/ManuscriptObstruction.lean @@ -0,0 +1,343 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteWeakTotality + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +The four conclusions of manuscript Theorem 1, retaining uniform provable +equality in its two middle clauses. The concrete productive witnesses have +these uniform graph equations already in PA, before passing to the theory T. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic FFL.Entailment + +open CategoricalRiceShapiro.PartialRecursive + +namespace FailureOfComposition +namespace ConcreteIndices + +open ProofSearch ConcreteEvaluator HistoryWitnesses ProgramIndices ConcreteEmptyGraph + +/-- Uniform equality of the concrete arithmetic program graphs. -/ +def UniformIndex (T : ArithmeticTheory) (e f : ℕ) : Prop := + Uniform T (eventualGraph e) (eventualGraph f) + +/-- The manuscript's Kleene equality formula, universally quantified over inputs. -/ +def uniformKleeneSentence (F G : Graph) : ArithmeticSentence := + “∀ x, + ((∃ y, !F.val x y) ↔ (∃ y, !G.val x y)) ∧ + ((∃ y, !F.val x y) → ∃ y, !F.val x y ∧ !G.val x y)” + +@[simp] +theorem uniformKleeneSentence_eval {M : Type*} [ORingStructure M] (F G : Graph) : + (uniformKleeneSentence F G).Evalb (M := M) ![] ↔ + ∀ x : M, + ((∃ y, F.val.Evalb ![x, y]) ↔ ∃ y, G.val.Evalb ![x, y]) ∧ + ((∃ y, F.val.Evalb ![x, y]) → ∃ y, F.val.Evalb ![x, y] ∧ G.val.Evalb ![x, y]) := + by simp [uniformKleeneSentence] + +/-! +The implication from output-graph equality to Kleene equality is pure +first-order logic. The explicit LK construction below deliberately avoids the +converse direction, functionality, PA, semantic completeness, and the later +`uniformKleeneSentence_iff_uniformSentence`. -/ + +private theorem implication_context (a b : ArithmeticProposition) + (h : Nonempty (LK.Derivation ⦃a ⇒ₗ b⦄)) : Nonempty (LK.Derivation (⦃∼a⦄ + ⦃b⦄)) := + by + rcases h with ⟨d⟩ + have dn : LK.Derivation (⦃∼a⦄ + ⦃b⦄ + ⦃∼(a ⇒ₗ b)⦄) := by + refine + LK.Derivation.cast + (LK.Derivation.tensor (Γ := ⦃∼a⦄) (Δ := ⦃b⦄) (φ := a) (ψ := ∼b) + (Multiset.Traversal.atom _) (Multiset.Traversal.atom _) + ((LK.Derivation.eta a).cast (by simp [add_comm])) (LK.Derivation.eta b)) + (by simp [Semiformula.imp_eq, add_comm, add_assoc]) + refine + ⟨LK.Derivation.cast + (LK.Derivation.cut (Γ := 0) (Δ := ⦃∼a⦄ + ⦃b⦄) (φ := a ⇒ₗ b) + (LK.Derivation.cast d (by simp)) dn) + (by simp)⟩ + +private theorem all_imp_all (p q : ArithmeticSemiformula ℕ 1) + (h : Nonempty (LK.Derivation ⦃p.free ⇒ₗ q.free⦄)) : + Nonempty (LK.Derivation ⦃(∀¹ p) ⇒ₗ (∀¹ q)⦄) := + by + rcases implication_context p.free q.free h with ⟨d⟩ + refine ⟨?_⟩ + refine + LK.Derivation.cast (LK.Derivation.or (Γ := 0) (φ := ∼(∀¹ p)) (ψ := ∀¹ q) ?_) + (by simp [Semiformula.imp_eq]) + refine LK.Derivation.cast (LK.Derivation.all (Γ := ⦃∼(∀¹ p)⦄) (φ := q) ?_) (by simp) + refine + LK.Derivation.cast + (LK.Derivation.exs (Γ := ⦃q.free⦄) (φ := (∼p).shift) (t := &0) + (LK.Derivation.cast d (by simp [Semiformula.free, add_comm]))) + (by simp [Rewriting.shifts, Semiformula.free, add_comm]) + +private theorem implication_core (p q : ArithmeticSemiformula ℕ 1) : + Nonempty (LK.Derivation (⦃(∼p).free⦄ + ⦃q.free⦄ + ⦃(∼(p ⇒ₗ q)).free⦄)) := + by + refine ⟨?_⟩ + refine + LK.Derivation.cast + (LK.Derivation.tensor (Γ := ⦃(∼p).free⦄) (Δ := ⦃q.free⦄) (φ := p.free) (ψ := ∼q.free) + (Multiset.Traversal.atom _) (Multiset.Traversal.atom _) + ((LK.Derivation.eta p.free).cast (by simp [Semiformula.free, add_comm])) + (LK.Derivation.eta q.free)) + (by simp [Semiformula.free, Semiformula.imp_eq, add_comm, add_assoc]) + +private theorem implication_exs_right (p q : ArithmeticSemiformula ℕ 1) : + Nonempty (LK.Derivation (⦃(∼p).free⦄ + ⦃(∼(p ⇒ₗ q)).free⦄ + ⦃∃¹ q.shift⦄)) := + by + rcases implication_core p q with ⟨d⟩ + refine + ⟨LK.Derivation.cast + (LK.Derivation.exs (Γ := ⦃(∼p).free⦄ + ⦃(∼(p ⇒ₗ q)).free⦄) (φ := q.shift) (t := &0) + (LK.Derivation.cast d (by simp [Semiformula.free, add_comm, add_assoc]))) + (by simp [add_assoc])⟩ + +private theorem implication_exs_both (p q : ArithmeticSemiformula ℕ 1) : + Nonempty (LK.Derivation (⦃(∼p).free⦄ + ⦃∃¹ q.shift⦄ + ⦃∃¹ (∼(p ⇒ₗ q)).shift⦄)) := + by + rcases implication_exs_right p q with ⟨d⟩ + refine + ⟨LK.Derivation.cast + (LK.Derivation.exs (Γ := ⦃(∼p).free⦄ + ⦃∃¹ q.shift⦄) (φ := (∼(p ⇒ₗ q)).shift) (t := &0) + (LK.Derivation.cast d + (by simp [Semiformula.free, add_comm, add_left_comm, add_assoc]))) + (by simp [add_assoc])⟩ + +private theorem all_imp_exs (p q : ArithmeticSemiformula ℕ 1) : + Nonempty (LK.Derivation ⦃(∀¹ (p ⇒ₗ q)) ⇒ₗ ((∃¹ p) ⇒ₗ (∃¹ q))⦄) := + by + rcases implication_exs_both p q with ⟨d⟩ + refine ⟨?_⟩ + refine + LK.Derivation.cast + (LK.Derivation.or (L := ℒₒᵣ) (Γ := 0) (φ := ∼(∀¹ (p ⇒ₗ q))) (ψ := (∃¹ p) ⇒ₗ (∃¹ q)) ?_) + (by simp [Semiformula.imp_eq]) + refine + LK.Derivation.cast + (LK.Derivation.or (L := ℒₒᵣ) (Γ := ⦃∼(∀¹ (p ⇒ₗ q))⦄) (φ := ∼(∃¹ p)) (ψ := ∃¹ q) ?_) + (by simp [Semiformula.imp_eq]) + refine + LK.Derivation.cast (LK.Derivation.all (Γ := ⦃∼(∀¹ (p ⇒ₗ q)), ∃¹ q⦄) (φ := ∼p) ?_) + (by simp [add_comm, add_left_comm, add_assoc]) + exact LK.Derivation.cast d (by simp [Rewriting.shifts, Semiformula.free, add_comm, add_assoc]) + +private theorem uniform_one (p q : ArithmeticSemiformula ℕ 1) : + Nonempty (LK.Derivation ⦃(∀¹ (p ⇔ₗ q)) ⇒ₗ (((∃¹ p) ⇔ₗ (∃¹ q)) ⋏ ((∃¹ p) ⇒ₗ ∃¹ (p ⋏ q)))⦄) := + by + have hpq₀ : Nonempty (LK.Derivation ⦃(p.free ⇔ₗ q.free) ⇒ₗ (p.free ⇒ₗ q.free)⦄) := + by + change (𝐋𝐊¹ : FFL.FirstOrder.LK ℒₒᵣ) ⊢ (p.free ⇔ₗ q.free) ⇒ₗ (p.free ⇒ₗ q.free) + cl_prover + have hpq : Nonempty (LK.Derivation ⦃(p ⇔ₗ q).free ⇒ₗ (p ⇒ₗ q).free⦄) := by + simpa [Semiformula.free] using hpq₀ + have hqp₀ : Nonempty (LK.Derivation ⦃(p.free ⇔ₗ q.free) ⇒ₗ (q.free ⇒ₗ p.free)⦄) := + by + change (𝐋𝐊¹ : FFL.FirstOrder.LK ℒₒᵣ) ⊢ (p.free ⇔ₗ q.free) ⇒ₗ (q.free ⇒ₗ p.free) + cl_prover + have hqp : Nonempty (LK.Derivation ⦃(p ⇔ₗ q).free ⇒ₗ (q ⇒ₗ p).free⦄) := by + simpa [Semiformula.free] using hqp₀ + have hconj₀ : + Nonempty (LK.Derivation ⦃(p.free ⇔ₗ q.free) ⇒ₗ (p.free ⇒ₗ (p.free ⋏ q.free))⦄) := + by + change (𝐋𝐊¹ : FFL.FirstOrder.LK ℒₒᵣ) ⊢ (p.free ⇔ₗ q.free) ⇒ₗ (p.free ⇒ₗ (p.free ⋏ q.free)) + cl_prover + have hconj : Nonempty (LK.Derivation ⦃(p ⇔ₗ q).free ⇒ₗ (p ⇒ₗ (p ⋏ q)).free⦄) := by + simpa [Semiformula.free] using hconj₀ + have hallPQ : (𝐋𝐊¹ : FFL.FirstOrder.LK ℒₒᵣ) ⊢ (∀¹ (p ⇔ₗ q)) ⇒ₗ ∀¹ (p ⇒ₗ q) := + all_imp_all (p ⇔ₗ q) (p ⇒ₗ q) hpq + have hallQP : (𝐋𝐊¹ : FFL.FirstOrder.LK ℒₒᵣ) ⊢ (∀¹ (p ⇔ₗ q)) ⇒ₗ ∀¹ (q ⇒ₗ p) := + all_imp_all (p ⇔ₗ q) (q ⇒ₗ p) hqp + have hallConj : (𝐋𝐊¹ : FFL.FirstOrder.LK ℒₒᵣ) ⊢ (∀¹ (p ⇔ₗ q)) ⇒ₗ ∀¹ (p ⇒ₗ (p ⋏ q)) := + all_imp_all (p ⇔ₗ q) (p ⇒ₗ (p ⋏ q)) hconj + have hexPQ : (𝐋𝐊¹ : FFL.FirstOrder.LK ℒₒᵣ) ⊢ (∀¹ (p ⇒ₗ q)) ⇒ₗ ((∃¹ p) ⇒ₗ (∃¹ q)) := + all_imp_exs p q + have hexQP : (𝐋𝐊¹ : FFL.FirstOrder.LK ℒₒᵣ) ⊢ (∀¹ (q ⇒ₗ p)) ⇒ₗ ((∃¹ q) ⇒ₗ (∃¹ p)) := + all_imp_exs q p + have hexConj : + (𝐋𝐊¹ : FFL.FirstOrder.LK ℒₒᵣ) ⊢ (∀¹ (p ⇒ₗ (p ⋏ q))) ⇒ₗ ((∃¹ p) ⇒ₗ ∃¹ (p ⋏ q)) := + all_imp_exs p (p ⋏ q) + change + (𝐋𝐊¹ : FFL.FirstOrder.LK ℒₒᵣ) ⊢ + (∀¹ (p ⇔ₗ q)) ⇒ₗ (((∃¹ p) ⇔ₗ (∃¹ q)) ⋏ ((∃¹ p) ⇒ₗ ∃¹ (p ⋏ q))) + cl_prover[hallPQ, hallQP, hallConj, hexPQ, hexQP, hexConj] + +/-- Pure LK proves that an internally universal graph biconditional implies +the manuscript's internally universal Kleene-equality sentence. -/ +theorem uniformSentence_imp_uniformKleeneSentence (F G : Graph) : + (∅ : ArithmeticTheory) ⊢ uniformSentence F G ⇒ₗ uniformKleeneSentence F G := + by + let p : ArithmeticSemiformula ℕ 1 := + Rewriting.free ((Rewriting.emb F.val : ArithmeticSemiformula ℕ 2).subst ![#1, #0]) + let q : ArithmeticSemiformula ℕ 1 := + Rewriting.free ((Rewriting.emb G.val : ArithmeticSemiformula ℕ 2).subst ![#1, #0]) + let source : ArithmeticSemiproposition 1 := “x. ∀ y, !F.val x y ↔ !G.val x y” + let target : ArithmeticSemiproposition 1 := + “x. + ((∃ y, !F.val x y) ↔ (∃ y, !G.val x y)) ∧ + ((∃ y, !F.val x y) → ∃ y, !F.val x y ∧ !G.val x y)” + have hone₀ := uniform_one p q + have hone : Nonempty (LK.Derivation ⦃source.free ⇒ₗ target.free⦄) := by + simpa [source, target, p, q, Semiformula.free] using hone₀ + have hall := all_imp_all source target hone + apply FFL.FirstOrder.Theory.Proof.of_LK_provable + rcases hall with ⟨d⟩ + refine ⟨LK.Derivation.cast d ?_⟩ + simp [uniformSentence, uniformKleeneSentence, source, target, + Semiformula.coe_subst_eq_subst_coe, Matrix.fun_eq_vec_two] + +/-- The one direction needed by the obstruction transport, over any theory. -/ +theorem uniformKleeneSentence_of_uniformSentence (T : ArithmeticTheory) (F G : Graph) + (h : T ⊢ uniformSentence F G) : T ⊢ uniformKleeneSentence F G := + by + have himp : T ⊢ uniformSentence F G ⇒ₗ uniformKleeneSentence F G := + Entailment.wkProof (by simp) (uniformSentence_imp_uniformKleeneSentence F G) + exact himp⨀h + +/-- PA functionality equates the two uniform encodings, at all internal inputs. -/ +theorem uniformKleeneSentence_iff_uniformSentence (F G : Graph) (hF : Functional F) + (hG : Functional G) : 𝐏𝐀 ⊢ uniformKleeneSentence F G ⇔ₗ uniformSentence F G := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + have hf := consequence_iff.mp (Theory.Proof.sound hF) M inferInstance + have hg := consequence_iff.mp (Theory.Proof.sound hG) M inferInstance + simp only [models_iff, functionalSentence_eval] at hf hg + simp only [models_iff, LogicalConnective.HomClass.map_iff, uniformKleeneSentence_eval, + uniformSentence_eval, LogicalConnective.Prop.iff_eq] + apply forall_congr' + intro x + constructor + · rintro ⟨hdom, hcommon⟩ y + constructor + · intro hy + obtain ⟨z, hzF, hzG⟩ := hcommon ⟨y, hy⟩ + exact (hf x y z hy hzF).symm ▸ hzG + · intro hy + obtain ⟨z, hzF, hzG⟩ := hcommon (hdom.mpr ⟨y, hy⟩) + exact (hg x y z hy hzG).symm ▸ hzF + · intro h + exact ⟨exists_congr h, fun ⟨y, hy⟩ => ⟨y, hy, (h y).mp hy⟩⟩ + +/-- UniformIndex is precisely provability of the manuscript's uniform formula. -/ +theorem uniformIndex_iff_kleene (T : ArithmeticTheory) [𝐏𝐀 ≼ T] (e f : ℕ) : + UniformIndex T e f ↔ T ⊢ uniformKleeneSentence (eventualGraph e) (eventualGraph f) := + by + have h : + T ⊢ + uniformKleeneSentence (eventualGraph e) (eventualGraph f) ⇔ₗ + uniformSentence (eventualGraph e) (eventualGraph f) := + WeakerThan.pbl + (uniformKleeneSentence_iff_uniformSentence _ _ (eventualGraph_functional e) + (eventualGraph_functional f)) + constructor + · intro he + have he' : T ⊢ uniformSentence (eventualGraph e) (eventualGraph f) := he + cl_prover[h, he'] + · intro he + change T ⊢ uniformSentence (eventualGraph e) (eventualGraph f) + cl_prover[h, he] + +private theorem uniform_trans {F G H : Graph} (hFG : Uniform 𝐏𝐀 F G) (hGH : Uniform 𝐏𝐀 G H) : + Uniform 𝐏𝐀 F H := by + apply complete.{0} 𝐏𝐀 + intro M _ _ + have hFG' := consequence_iff.mp (Theory.Proof.sound hFG) M inferInstance + have hGH' := consequence_iff.mp (Theory.Proof.sound hGH) M inferInstance + simp only [models_iff, uniformSentence_eval] at hFG' hGH' ⊢ + exact fun x y => (hFG' x y).trans (hGH' x y) + +private theorem uniform_symm {F G : Graph} (hFG : Uniform 𝐏𝐀 F G) : Uniform 𝐏𝐀 G F := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + have hFG' := consequence_iff.mp (Theory.Proof.sound hFG) M inferInstance + simp only [models_iff, uniformSentence_eval] at hFG' ⊢ + exact fun x y => (hFG' x y).symm + +/-- The concrete identity law is uniformly provable already in PA. -/ +theorem identity_comp_uniformIndex (e : ℕ) : + UniformIndex 𝐏𝐀 (canonicalPartrecCompIndex Kleene.identityIndex e) e := + by + have hRefl : Uniform 𝐏𝐀 (eventualGraph e) (eventualGraph e) := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + simp [models_iff, uniformSentence_eval] + exact + uniform_trans (eventualGraph_composition _ _) + (uniform_trans (uniform_comp eventualGraph_identity hRefl) + (identity_comp (eventualGraph e))) + +/-- The guard-search composite has uniformly empty graph already in PA. -/ +theorem guard_search_uniformIndex_empty (d : ℕ) : + UniformIndex 𝐏𝐀 (canonicalPartrecCompIndex (guardIndex d) (searchIndex d)) + concreteEmptyIndex := + uniform_trans (eventualGraph_composition _ _) + (uniform_trans (uniform_comp (guardIndex_realizes d) (searchIndex_realizes d)) + (uniform_trans (HistoryWitnesses.guard_search_empty d) + (uniform_symm eventualGraph_empty))) + +/-- The four manuscript properties, with the stronger PA-uniform middle clauses. -/ +theorem index_four_witnesses_uniform_of_history_divergence (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (d : ℕ) (hdiv : ¬diagonalHistoryFormula.Evalb ![d]) + (hnot : T ⊬ ∼diagonalHistoryFormula/[d]) : + PointwiseIndex T (guardIndex d) Kleene.identityIndex ∧ + UniformIndex 𝐏𝐀 (canonicalPartrecCompIndex (guardIndex d) (searchIndex d)) + concreteEmptyIndex ∧ + UniformIndex 𝐏𝐀 (canonicalPartrecCompIndex Kleene.identityIndex (searchIndex d)) + (searchIndex d) ∧ + ¬PointwiseIndex T (searchIndex d) concreteEmptyIndex := + ⟨guardIndex_pointwise_identity T d hdiv, guard_search_uniformIndex_empty d, + identity_comp_uniformIndex (searchIndex d), searchIndex_not_pointwise_empty T d hnot⟩ + +/-- Theorem 1's four properties for every consistent recursively axiomatized +extension of PA. Uniform provability is retained, not replaced by its instances. -/ +theorem obstruction_four_properties_of_re_axioms (T : ArithmeticTheory) [𝐏𝐀 ≼ T] [Consistent T] + (hT : REPred (AxiomCodes T)) : + ∃ f g : ℕ, + PointwiseIndex T f Kleene.identityIndex ∧ + UniformIndex T (canonicalPartrecCompIndex f g) concreteEmptyIndex ∧ + UniformIndex T (canonicalPartrecCompIndex Kleene.identityIndex g) g ∧ + ¬PointwiseIndex T g concreteEmptyIndex := + by + obtain ⟨d, hdiv, hnot⟩ := + exists_true_unprovable_history_divergence_of_theorem_codes T + (theorem_codes_re_of_axiom_codes T hT) + obtain ⟨hfi, hfg, hig, hgz⟩ := + index_four_witnesses_uniform_of_history_divergence T d hdiv hnot + exact ⟨guardIndex d, searchIndex d, hfi, WeakerThan.pbl hfg, WeakerThan.pbl hig, hgz⟩ + +/-- The explicit partial-recursive axiom-enumerator presentation of Theorem 1. -/ +theorem obstruction_four_properties_of_axiom_enumerator (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + [Consistent T] (a : ℕ) (ha : ∀ n : ℕ, AxiomCodes T n ↔ ∃ x : ℕ, n ∈ Kleene.eval a x) : + ∃ f g : ℕ, + PointwiseIndex T f Kleene.identityIndex ∧ + UniformIndex T (canonicalPartrecCompIndex f g) concreteEmptyIndex ∧ + UniformIndex T (canonicalPartrecCompIndex Kleene.identityIndex g) g ∧ + ¬PointwiseIndex T g concreteEmptyIndex := + obstruction_four_properties_of_re_axioms T (axiom_codes_re_of_program_enumerator T a ha) + +end ConcreteIndices +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/MinimizationPersistence.lean b/LeanPool/PointwiseComposition/FailureOfComposition/MinimizationPersistence.lean new file mode 100644 index 000000000..297d274a3 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/MinimizationPersistence.lean @@ -0,0 +1,472 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.PersistenceInduction + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +Persistence for constructor 7 of the existing Mathlib-index history evaluator. +The subsidiary-index premise is discharged by the external induction on indices; +the same-index recursive lookup is handled by PA induction on the source stage. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +open scoped FFL.FirstOrder.Arithmetic + +open Nat.ArithPart₁ + +open CategoricalRiceShapiro.ArithmeticCode + +open CategoricalRiceShapiro.PartialRecursive + +namespace CategoricalRiceShapiro +namespace Evaluator + +variable {M : Type*} [ORingStructure M] + +private theorem bodd_toNat_eq_mod_two (n : ℕ) : n.bodd.toNat = n % 2 := by + rw [Nat.mod_two_of_bodd] + +/-- The production tag decoder, written with remainders. -/ +private theorem partrecCodeTag_eq (q : ℕ) : + partrecCodeTag q = if q < 4 then q else 4 + 2 * ((q - 4) % 2) + Nat.div2 (q - 4) % 2 := by + simp only [partrecCodeTag, bodd_toNat_eq_mod_two] + +/-- The constructor number of a standard index, read inside a model. -/ +private theorem read_tag [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) (v : Fin r → M) + (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : + Semiformula.Evalb (((partrecCodeTag q : ℕ) : M) :> v) (code (codePartrecTag d)) := + by + have h4 : Semiformula.Evalb (((4 : ℕ) : M) :> v) (code (codeConst (n := r) 4)) := + eval_codeConst 4 v + have h2 : Semiformula.Evalb (((2 : ℕ) : M) :> v) (code (codeConst (n := r) 2)) := + eval_codeConst 2 v + have hrr := eval_codeSub_natCast d (codeConst 4) q 4 v hd (by simpa using h4) + have hbodd0 := eval_codeBodd_natCast (codeSub d (codeConst 4)) (q - 4) v hrr + have hbodd1 := + eval_codeBodd_natCast (codeDiv2 (codeSub d (codeConst 4))) (Nat.div2 (q - 4)) v + (eval_codeDiv2_natCast _ (q - 4) v hrr) + have hmul : + Semiformula.Evalb ((((2 * ((q - 4) % 2) : ℕ)) : M) :> v) + (code (codeMul (codeConst 2) (codeBodd (codeSub d (codeConst 4))))) := + by + refine (eval_codeMul_iff _ _ _ v).mpr ⟨_, _, h2, hbodd0, ?_⟩ + push_cast + norm_num + have hadd1 : + Semiformula.Evalb ((((4 + 2 * ((q - 4) % 2) : ℕ)) : M) :> v) + (code + (codeAdd (codeConst 4) (codeMul (codeConst 2) (codeBodd (codeSub d (codeConst 4)))))) := + by + refine (eval_codeAdd_iff _ _ _ v).mpr ⟨_, _, h4, hmul, ?_⟩ + push_cast + norm_num + have hbig : + Semiformula.Evalb ((((4 + 2 * ((q - 4) % 2) + Nat.div2 (q - 4) % 2 : ℕ)) : M) :> v) + (code + (codeAdd + (codeAdd (codeConst 4) (codeMul (codeConst 2) (codeBodd (codeSub d (codeConst 4))))) + (codeBodd (codeDiv2 (codeSub d (codeConst 4)))))) := + by + refine (eval_codeAdd_iff _ _ _ v).mpr ⟨_, _, hadd1, hbodd1, ?_⟩ + push_cast + norm_num + rw [partrecCodeTag_eq] + simp only [codePartrecTag] + by_cases hq : q < 4 + · have hlt1 : Semiformula.Evalb ((1 : M) :> v) (code (codeLt d (codeConst 4))) := + by + refine (eval_codeLt_iff _ _ _ v).mpr ⟨_, _, hd, by simpa using h4, Or.inl ⟨?_, rfl⟩⟩ + exact_mod_cast hq + rw [ite_eq_left hq] + exact + eval_codeIfPos_of _ _ _ (1 : M) (((q : ℕ)) : M) _ _ v hlt1 hd hbig + (Or.inl ⟨_root_.zero_lt_one, rfl⟩) + · have hlt0 : Semiformula.Evalb ((0 : M) :> v) (code (codeLt d (codeConst 4))) := + by + refine (eval_codeLt_iff _ _ _ v).mpr ⟨_, _, hd, by simpa using h4, Or.inr ⟨?_, rfl⟩⟩ + intro hc + exact hq (by exact_mod_cast hc) + rw [ite_eq_right hq] + exact eval_codeIfPos_of _ _ _ (0 : M) (((q : ℕ)) : M) _ _ v hlt0 hd hbig (Or.inr ⟨rfl, rfl⟩) + +/-- The payload of a standard compound index, read inside a model. -/ +private theorem read_payload [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) (v : Fin r → M) + (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : + Semiformula.Evalb (((partrecCodePayload q : ℕ) : M) :> v) (code (codePartrecPayload d)) := + by + have h4 : Semiformula.Evalb (((4 : ℕ) : M) :> v) (code (codeConst (n := r) 4)) := + eval_codeConst 4 v + have hrr := eval_codeSub_natCast d (codeConst 4) q 4 v hd (by simpa using h4) + simpa only [codePartrecPayload, partrecCodePayload] using + eval_codeDiv2_natCast _ _ v (eval_codeDiv2_natCast _ (q - 4) v hrr) + +private theorem min_succ_pred [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : M} (hk : 0 < k) : k - 1 + 1 = k := + FFL.FirstOrder.Arithmetic.sub_add_self_of_le + (FFL.FirstOrder.Arithmetic.one_le_of_zero_lt k hk) + +/-- The decremented fuel, as the dispatcher computes it. -/ +private theorem min_decremented_fuel [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] + (s qCode u : M) : + Semiformula.Evalb ((s - 1) :> ![s, qCode, u]) + (code + (codeSub (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell)) + (codeConst 1))) := + by + have hone : Semiformula.Evalb ((1 : M) :> ![s, qCode, u]) (code (codeConst (n := 3) 1)) := + by + have h := eval_codeConst (M := M) (k := 3) 1 ![s, qCode, u] + have hcast : (((1 : ℕ)) : M) = (1 : M) := by simp + rwa [hcast] at h + exact + eval_codeSub _ (codeConst 1) s (1 : M) ![s, qCode, u] + (eval_codeEvaluatorCell_fuel s qCode u) hone + +/-- The key of the base lookup is the fuel. -/ +private theorem min_base_key [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] (s qCode u : M) + (hs : 0 < s) : + Semiformula.Evalb (s :> ![s, qCode, u]) + (code + (codeSucc + (codeSub (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell)) + (codeConst 1)))) := + by + refine (eval_codeSucc_iff _ _ _).mpr ⟨s - 1, min_decremented_fuel s qCode u, ?_⟩ + exact (min_succ_pred hs).symm + +private theorem ifpos_select [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (df dg dh : Code r) (v : Fin r → M) + (z a : M) (ha : Semiformula.Evalb (a :> v) (code df)) + (hz : Semiformula.Evalb (z :> v) (code (codeIfPos df dg dh))) : + (0 < a → Semiformula.Evalb (z :> v) (code dg)) ∧ + (a = 0 → Semiformula.Evalb (z :> v) (code dh)) := + by + obtain ⟨b, hb, hcase⟩ := eval_codeIfPos_cases df dg dh z v hz + have hba := eval_unique hb ha + subst b + rcases hcase with ⟨hp, hg⟩ | ⟨h0, hh⟩ + · exact ⟨fun _ => hg, fun h0 => False.elim ((ne_of_gt hp) h0)⟩ + · exact ⟨fun hp => False.elim ((ne_of_gt hp) h0), fun _ => hh⟩ + +private theorem min_branch [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (dtable dn : Code r) (v : Fin r → M) + (z k : M) (hk : Semiformula.Evalb (k :> v) (code (codeUnpair₁ (codeListLength dtable)))) + (hkpos : 0 < k) + (htag : + Semiformula.Evalb ((7 : M) :> v) + (code (codePartrecTag (codeUnpair₂ (codeListLength dtable))))) + (hcell : Semiformula.Evalb (z :> v) (code (codeEvaluatorCell dtable dn))) : + Semiformula.Evalb (z :> v) + (code + (codeRfindEvaluatorCell dtable + (codeSub (codeUnpair₁ (codeListLength dtable)) (codeConst 1)) + (codeUnpair₂ (codeListLength dtable)) + (codePartrecPayload (codeUnpair₂ (codeListLength dtable))) dn)) := + by + have heq (n : ℕ) (hn : (7 : M) ≠ (n : M)) : + Semiformula.Evalb ((0 : M) :> v) + (code (codeEq (codePartrecTag (codeUnpair₂ (codeListLength dtable))) (codeConst n))) := + (eval_codeEq_iff _ _ _ v).mpr ⟨7, n, htag, eval_codeConst n v, Or.inr ⟨hn, rfl⟩⟩ + have h4 := heq 4 (by norm_num) + have h5 := heq 5 (by norm_num) + have h6 := heq 6 (by norm_num) + have h7 : + Semiformula.Evalb ((1 : M) :> v) + (code (codeEq (codePartrecTag (codeUnpair₂ (codeListLength dtable))) (codeConst 7))) := + (eval_codeEq_iff _ _ _ v).mpr + ⟨7, 7, htag, by simpa using eval_codeConst (M := M) 7 v, Or.inl ⟨rfl, rfl⟩⟩ + simp only [codeEvaluatorCell] at hcell + have hc := (ifpos_select _ _ _ v z k hk hcell).1 hkpos + have hc := (ifpos_select _ _ _ v z 0 h4 hc).2 rfl + have hc := (ifpos_select _ _ _ v z 0 h5 hc).2 rfl + have hc := (ifpos_select _ _ _ v z 0 h6 hc).2 rfl + exact (ifpos_select _ _ _ v z 1 h7 hc).1 _root_.zero_lt_one + +private theorem min_payload_lt (q : ℕ) (hq : partrecCodeTag q = 7) : partrecCodePayload q < q := + by + have hq4 : ¬q < 4 := by + intro hlt + simp only [partrecCodeTag, hlt, ite_true] at hq + omega + simp only [partrecCodePayload, Nat.div2_val] + omega + +/-- Success of the minimization branch: the subsidiary program returns a value; +zero terminates the search, and a positive result makes the recursive lookup. -/ +private theorem min_cell_iff [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] {r : ℕ} + (dtable dk' dq dcf dn : Code r) (table k' qv u y : M) (v : Fin r → M) + (htable : Semiformula.Evalb (table :> v) (code dtable)) + (hk' : Semiformula.Evalb (k' :> v) (code dk')) (hq : Semiformula.Evalb (qv :> v) (code dq)) + (hn : Semiformula.Evalb (u :> v) (code dn)) : + Semiformula.Evalb ((y + 1) :> v) (code (codeRfindEvaluatorCell dtable dk' dq dcf dn)) ↔ + ∃ x : M, + Semiformula.Evalb ((x + 1) :> v) + (code + (codeTableLookup dtable (codeSucc dk') dcf + (codePair (codeUnpair₁ dn) (codeUnpair₂ dn)))) ∧ + ((0 < x ∧ + Semiformula.Evalb ((y + 1) :> x :> v) + (code + (codeTableLookup (codeLift dtable) (codeLift dk') (codeLift dq) + (codePair (codeLift (codeUnpair₁ dn)) + (codeSucc (codeLift (codeUnpair₂ dn))))))) ∨ + (x = 0 ∧ y = FFL.FirstOrder.Arithmetic.pi₂ u)) := + by + have hz := eval_codeUnpair₁ dn u v hn + have hm := eval_codeUnpair₂ dn u v hn + have hL (x : M) (X : Code r) (a : M) (h : Semiformula.Evalb (a :> v) (code X)) : + Semiformula.Evalb (a :> x :> v) (code (codeLift X)) := (eval_codeLift_iff X a x v).mpr h + have hs (x : M) : + Semiformula.Evalb ((FFL.FirstOrder.Arithmetic.pi₂ u + 1) :> x :> v) + (code (codeSucc (codeLift (codeUnpair₂ dn)))) := + (eval_codeSucc_iff _ _ _).mpr ⟨_, hL x _ _ hm, rfl⟩ + simp only [codeRfindEvaluatorCell, eval_codeOptionBind_succ_iff] + apply exists_congr + intro x + apply and_congr_right + intro _ + constructor + · intro h + obtain ⟨a, ha, hcase⟩ := eval_codeIfPos_cases _ _ _ _ (x :> v) h + have hax : a = x := (eval_codeHead_iff _ _).mp ha + subst a + rcases hcase with ⟨hx, hr⟩ | ⟨hx, hr⟩ + · exact Or.inl ⟨hx, hr⟩ + · exact Or.inr ⟨hx, add_right_cancel (eval_unique hr (hs x))⟩ + · rintro (⟨hx, hr⟩ | ⟨hx, hy⟩) + · exact + eval_codeIfPos_of _ _ _ x (y + 1) (FFL.FirstOrder.Arithmetic.pi₂ u + 1) _ (x :> v) + ((eval_codeHead_iff _ _).mpr rfl) hr (hs x) (Or.inl ⟨hx, rfl⟩) + · obtain ⟨o, ho⟩ := + eval_codeTableLookup_exists_of_values (codeLift dtable) (codeLift dk') (codeLift dq) + (codePair (codeLift (codeUnpair₁ dn)) (codeSucc (codeLift (codeUnpair₂ dn)))) table k' + qv + (FFL.FirstOrder.Arithmetic.pair (FFL.FirstOrder.Arithmetic.pi₁ u) + (FFL.FirstOrder.Arithmetic.pi₂ u + 1)) + (x :> v) (hL x _ _ htable) (hL x _ _ hk') (hL x _ _ hq) + (eval_codePair _ _ _ _ (x :> v) (hL x _ _ hz) (hs x)) + exact + eval_codeIfPos_of _ _ _ x o (FFL.FirstOrder.Arithmetic.pi₂ u + 1) _ (x :> v) + ((eval_codeHead_iff _ _).mpr rfl) ho (hs x) (Or.inr ⟨hx, by rw [hy]⟩) + +private abbrev min_table : Code 3 := + codeEvaluatorHistoryBeforeCell + +private abbrev min_prev : Code 3 := + codeSub (codeUnpair₁ (codeListLength min_table)) (codeConst 1) + +private abbrev min_index : Code 3 := + codeUnpair₂ (codeListLength min_table) + +private abbrev min_subindex : Code 3 := + codePartrecPayload min_index + +private abbrev min_input : Code 3 := + Code.proj (2 : Fin 3) + +/-- The complete tag-7 equation for the existing raw computation formula, +valid at arbitrary stages and arguments of every model of PA. -/ +theorem evalnCertificateFormula_tag_seven_iff [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (q : ℕ) + (hq : partrecCodeTag q = 7) (s u y : M) (hs : 0 < s) : + Semiformula.Evalb ![s, ((q : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) ↔ + u < s ∧ + ∃ x : M, + Semiformula.Evalb ![s, ((partrecCodePayload q : ℕ) : M), u, x] + (evalnCertificateFormula : ArithmeticSemisentence 4) ∧ + ((0 < x ∧ + Semiformula.Evalb + ![s - 1, ((q : ℕ) : M), + FFL.FirstOrder.Arithmetic.pair (FFL.FirstOrder.Arithmetic.pi₁ u) + (FFL.FirstOrder.Arithmetic.pi₂ u + 1), + y] + (evalnCertificateFormula : ArithmeticSemisentence 4)) ∨ + (x = 0 ∧ y = FFL.FirstOrder.Arithmetic.pi₂ u)) := + by + obtain ⟨H, hH, hHist⟩ := eval_codeEvaluatorHistoryBeforeCell_exists s ((q : ℕ) : M) u + have hn : Semiformula.Evalb (u :> ![s, ((q : ℕ) : M), u]) (code min_input) := + (eval_proj_iff _ _ _).mpr rfl + have hi := eval_codeEvaluatorCell_index s ((q : ℕ) : M) u + have hp := read_payload min_index q ![s, ((q : ℕ) : M), u] hi + have htag : + Semiformula.Evalb ((7 : M) :> ![s, ((q : ℕ) : M), u]) (code (codePartrecTag min_index)) := + by + have h := read_tag min_index q ![s, ((q : ℕ) : M), u] hi + simpa only [hq, Nat.cast_ofNat] using h + have hprev : s - 1 < s := by + have h := lt_add_one (s - 1) + rwa [min_succ_pred hs] at h + have hz := eval_codeUnpair₁ min_input u ![s, ((q : ℕ) : M), u] hn + have hm := eval_codeUnpair₂ min_input u ![s, ((q : ℕ) : M), u] hn + have harg : + Semiformula.Evalb (u :> ![s, ((q : ℕ) : M), u]) + (code (codePair (codeUnpair₁ min_input) (codeUnpair₂ min_input))) := + by + have h := eval_codePair _ _ _ _ ![s, ((q : ℕ) : M), u] hz hm + rwa [FFL.FirstOrder.Arithmetic.pair_unpair] at h + have hsub (x : M) : + Semiformula.Evalb ((x + 1) :> ![s, ((q : ℕ) : M), u]) + (code + (codeTableLookup min_table (codeSucc min_prev) min_subindex + (codePair (codeUnpair₁ min_input) (codeUnpair₂ min_input)))) ↔ + Semiformula.Evalb ![s, ((partrecCodePayload q : ℕ) : M), u, x] + (evalnCertificateFormula : ArithmeticSemisentence 4) := + by + rw [evalnCertificateFormula_eval_history_iff] + exact + eval_codeTableLookup_succ_iff_codeHistoryEvaluator_of_history min_table + (codeSucc min_prev) min_subindex _ ![s, ((q : ℕ) : M), u] + (FFL.FirstOrder.Arithmetic.pair s ((q : ℕ) : M)) H s u x (partrecCodePayload q) hHist + (FFL.FirstOrder.Arithmetic.pair_lt_pair_right s (by exact_mod_cast min_payload_lt q hq)) + hH (min_base_key s ((q : ℕ) : M) u hs) hp harg + have hrec (x : M) : + Semiformula.Evalb ((y + 1) :> x :> ![s, ((q : ℕ) : M), u]) + (code + (codeTableLookup (codeLift min_table) (codeLift min_prev) (codeLift min_index) + (codePair (codeLift (codeUnpair₁ min_input)) + (codeSucc (codeLift (codeUnpair₂ min_input)))))) ↔ + Semiformula.Evalb + ![s - 1, ((q : ℕ) : M), + FFL.FirstOrder.Arithmetic.pair (FFL.FirstOrder.Arithmetic.pi₁ u) + (FFL.FirstOrder.Arithmetic.pi₂ u + 1), + y] + (evalnCertificateFormula : ArithmeticSemisentence 4) := + by + rw [evalnCertificateFormula_eval_history_iff] + apply + eval_codeTableLookup_succ_iff_codeHistoryEvaluator_of_history (codeLift min_table) + (codeLift min_prev) (codeLift min_index) _ (x :> ![s, ((q : ℕ) : M), u]) + (FFL.FirstOrder.Arithmetic.pair s ((q : ℕ) : M)) H (s - 1) _ y q hHist + (FFL.FirstOrder.Arithmetic.pair_lt_pair_left hprev _) + ((eval_codeLift_iff _ _ _ _).mpr hH) + ((eval_codeLift_iff _ _ _ _).mpr (min_decremented_fuel s ((q : ℕ) : M) u)) + ((eval_codeLift_iff _ _ _ _).mpr hi) + exact + eval_codePair _ _ _ _ (x :> ![s, ((q : ℕ) : M), u]) ((eval_codeLift_iff _ _ _ _).mpr hz) + ((eval_codeSucc_iff _ _ _).mpr ⟨_, (eval_codeLift_iff _ _ _ _).mpr hm, rfl⟩) + have hbranch := + min_cell_iff min_table min_prev min_index min_subindex min_input H (s - 1) ((q : ℕ) : M) u y + ![s, ((q : ℕ) : M), u] hH (min_decremented_fuel s ((q : ℕ) : M) u) hi hn + have hbranch' : + Semiformula.Evalb ((y + 1) :> ![s, ((q : ℕ) : M), u]) + (code (codeRfindEvaluatorCell min_table min_prev min_index min_subindex min_input)) ↔ + ∃ x : M, + Semiformula.Evalb ![s, ((partrecCodePayload q : ℕ) : M), u, x] + (evalnCertificateFormula : ArithmeticSemisentence 4) ∧ + ((0 < x ∧ + Semiformula.Evalb + ![s - 1, ((q : ℕ) : M), + FFL.FirstOrder.Arithmetic.pair (FFL.FirstOrder.Arithmetic.pi₁ u) + (FFL.FirstOrder.Arithmetic.pi₂ u + 1), + y] + (evalnCertificateFormula : ArithmeticSemisentence 4)) ∨ + (x = 0 ∧ y = FFL.FirstOrder.Arithmetic.pi₂ u)) := + by + rw [hbranch] + exact + exists_congr fun x => + and_congr (hsub x) (or_congr (and_congr_right fun _ => hrec x) Iff.rfl) + rw [evalnCertificateFormula_eval_history_iff, eval_codeHistoryEvaluator_succ_iff_cell] + apply and_congr_right + intro _ + constructor + · intro hc + apply hbranch'.mp + exact + min_branch min_table min_input ![s, ((q : ℕ) : M), u] (y + 1) s + (eval_codeEvaluatorCell_fuel s ((q : ℕ) : M) u) hs htag hc + · intro h + have hb := hbranch'.mpr h + obtain ⟨w, hw⟩ := + eval_codeEvaluatorCell_exists_of_values min_table min_input H u ![s, ((q : ℕ) : M), u] hH + hn + have hb' := + min_branch min_table min_input ![s, ((q : ℕ) : M), u] w s + (eval_codeEvaluatorCell_fuel s ((q : ℕ) : M) u) hs htag hw + have he := eval_unique hb' hb + rwa [he] at hw + +private theorem min_successor_persistence [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (q : ℕ) + (hq : partrecCodeTag q = 7) + (ih : + ∀ p : ℕ, + p < q → + ∀ s t u y : M, + s ≤ t → + Semiformula.Evalb ![s, ((p : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) → + Semiformula.Evalb ![t, ((p : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4)) + (k : M) + (hpred : + ∀ t u y : M, + k ≤ t → + Semiformula.Evalb ![k, ((q : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) → + Semiformula.Evalb ![t, ((q : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4)) : + ∀ t u y : M, + k + 1 ≤ t → + Semiformula.Evalb ![k + 1, ((q : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) → + Semiformula.Evalb ![t, ((q : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) := + by + intro t u y hkt hc + have hk : (0 : M) < k + 1 := + lt_of_le_of_lt (FFL.FirstOrder.Arithmetic.zero_le k) (lt_add_one k) + have ht : (0 : M) < t := lt_of_lt_of_le hk hkt + obtain ⟨hus, x, hx, hcase⟩ := + (evalnCertificateFormula_tag_seven_iff q hq (k + 1) u y hk).mp hc + apply (evalnCertificateFormula_tag_seven_iff q hq t u y ht).mpr + refine + ⟨lt_of_lt_of_le hus hkt, x, + ih (partrecCodePayload q) (min_payload_lt q hq) (k + 1) t u x hkt hx, ?_⟩ + rcases hcase with ⟨hpos, hrec⟩ | hz + · left + refine ⟨hpos, hpred (t - 1) _ y ?_ ?_⟩ + · apply le_of_add_le_add_right (a := (1 : M)) + rwa [min_succ_pred ht] + · simpa only [add_sub_self] using hrec + · exact Or.inr hz + +/-- Constructor-7 persistence of the accepted computation formula. The only +premise is persistence for strictly smaller standard program indices. -/ +theorem evalnCertificateFormula_natCode_persist_of_tag_seven [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + (q : ℕ) (hq : partrecCodeTag q = 7) + (ih : + ∀ p : ℕ, + p < q → + ∀ s t u y : M, + s ≤ t → + Semiformula.Evalb ![s, ((p : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) → + Semiformula.Evalb ![t, ((p : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4)) : + ∀ s t u y : M, + s ≤ t → + Semiformula.Evalb ![s, ((q : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) → + Semiformula.Evalb ![t, ((q : ℕ) : M), u, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) := + certificate_persistence_of_stage_induction q + (evalnCertificateFormula_natCode_persist_of_stage_zero q) + (min_successor_persistence q hq ih) + +end Evaluator +end CategoricalRiceShapiro + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/PartialRecursiveQuotient.lean b/LeanPool/PointwiseComposition/FailureOfComposition/PartialRecursiveQuotient.lean new file mode 100644 index 000000000..6b3b11485 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/PartialRecursiveQuotient.lean @@ -0,0 +1,145 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteGeneratedCongruence + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +The generated quotient of a Sigma-one sound PA extension is the monoid of +unary partial recursive functions. The target consists of actual partial maps, +with partial composition as multiplication and the total identity as its unit. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +namespace FailureOfComposition + +/-- Unary partial recursive functions, identified by equality of partial maps. -/ +def UnaryPartrec := + { f : ℕ → Part ℕ // Nat.Partrec f } + +namespace UnaryPartrec + +instance : Mul UnaryPartrec where + mul f g := ⟨fun x => (g.val x).bind f.val, Nat.Partrec.comp f.property g.property⟩ + +instance : One UnaryPartrec where + one := + ⟨Part.some, + Nat.Partrec.Code.exists_code.mpr ⟨Nat.Partrec.Code.id, funext Nat.Partrec.Code.eval_id⟩⟩ + +/-- Multiplication is ordinary partial composition, with the right map applied first. -/ +@[simp] +theorem mul_apply (f g : UnaryPartrec) (x : ℕ) : (f * g).val x = (g.val x).bind f.val := + rfl + +@[simp] +theorem one_apply (x : ℕ) : (1 : UnaryPartrec).val x = Part.some x := + rfl + +instance : Monoid UnaryPartrec + where + mul_assoc f g + h := by + apply Subtype.ext + funext x + exact (Part.bind_assoc (h.val x) g.val f.val).symm + one_mul + f := by + apply Subtype.ext + funext x + exact Part.bind_some_right (f.val x) + mul_one + f := by + apply Subtype.ext + funext x + exact Part.bind_some x f.val + +/-- The partial recursive function denoted by a concrete natural-number index. -/ +def ofIndex (e : ℕ) : UnaryPartrec := + ⟨Kleene.eval e, Nat.Partrec.Code.exists_code.mpr ⟨Denumerable.ofNat Nat.Partrec.Code e, rfl⟩⟩ + +@[simp] +theorem ofIndex_val (e : ℕ) : (ofIndex e).val = Kleene.eval e := + rfl + +/-- Every unary partial recursive function has an index in the fixed numbering. -/ +theorem ofIndex_surjective : Function.Surjective ofIndex := + by + rintro ⟨f, hf⟩ + obtain ⟨c, hc⟩ := Nat.Partrec.Code.exists_code.mp hf + refine ⟨Encodable.encode c, Subtype.ext ?_⟩ + change Nat.Partrec.Code.eval (Denumerable.ofNat Nat.Partrec.Code (Encodable.encode c)) = f + simpa only [Denumerable.ofNat_encode] using hc + +end UnaryPartrec + +namespace ConcreteIndices + +/-- Evaluation descends to the generated quotient of a Sigma-one sound theory. -/ +noncomputable def generatedQuotientDenotation (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (hT : GeneratedCongruence.SigmaOneSound T) : GeneratedQuotient T → UnaryPartrec := + Quotient.lift UnaryPartrec.ofIndex fun e d h => + Subtype.ext ((generated_iff_extensional_of_sound T hT e d).mp h) + +@[simp] +theorem generatedQuotientDenotation_mk (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (hT : GeneratedCongruence.SigmaOneSound T) (e : ℕ) : + generatedQuotientDenotation T hT (generatedQuotientMk T e) = UnaryPartrec.ofIndex e := + rfl + +theorem generatedQuotientDenotation_bijective (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (hT : GeneratedCongruence.SigmaOneSound T) : + Function.Bijective (generatedQuotientDenotation T hT) := + by + constructor + · intro a b + refine Quotient.inductionOn₂ a b ?_ + intro e d heq + apply Quotient.sound + exact (generated_iff_extensional_of_sound T hT e d).mpr (congrArg Subtype.val heq) + · intro f + obtain ⟨e, he⟩ := UnaryPartrec.ofIndex_surjective f + exact ⟨generatedQuotientMk T e, he⟩ + +/-- In the sound case, the generated quotient is isomorphic to the monoid of +all unary partial recursive functions under partial composition. -/ +noncomputable def generatedQuotientPartialRecursiveEquiv (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (hT : GeneratedCongruence.SigmaOneSound T) : GeneratedQuotient T ≃* UnaryPartrec := + { + Equiv.ofBijective (generatedQuotientDenotation T hT) + (generatedQuotientDenotation_bijective T hT) with + map_mul' := by + intro a b + refine Quotient.inductionOn₂ a b ?_ + intro e d + apply Subtype.ext + funext x + exact Kleene.eval_compIndex e d x } + +@[simp] +theorem generatedQuotientPartialRecursiveEquiv_mk (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (hT : GeneratedCongruence.SigmaOneSound T) (e : ℕ) : + generatedQuotientPartialRecursiveEquiv T hT (generatedQuotientMk T e) = + UnaryPartrec.ofIndex e := + rfl + +end ConcreteIndices + +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/PiOneCharacterization.lean b/LeanPool/PointwiseComposition/FailureOfComposition/PiOneCharacterization.lean new file mode 100644 index 000000000..6ce981125 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/PiOneCharacterization.lean @@ -0,0 +1,97 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.PiOneNecessity +public import LeanPool.PointwiseComposition.FailureOfComposition.PiOneExtensionality +public import LeanPool.PointwiseComposition.FailureOfComposition.PiOneCongruence +public import LeanPool.PointwiseComposition.FailureOfComposition.QuotientComposition + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +Characterization of congruence by Pi-one completeness. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic FFL.Entailment + +namespace FailureOfComposition +namespace PiOneCharacterization + +open ProofSearch + +/-- For a consistent extension of PA, right composition is compatible exactly +when every true Pi-one sentence is provable. No enumerability is assumed. -/ +theorem rightCompatible_iff_piOneComplete (T : ArithmeticTheory) [𝐏𝐀 ≼ T] [Consistent T] : + RightCompatible T ↔ PiOneComplete T := + by + constructor + · exact rightCompatible_implies_piOneComplete T + · intro h + exact + rightCompatible_of_pointwise_iff_extensional T + (fun F G hF hG => pointwise_iff_extensional T h F G hF hG) + +theorem compositionCongruence_iff_piOneComplete (T : ArithmeticTheory) [𝐏𝐀 ≼ T] [Consistent T] : + CompositionCongruence T ↔ PiOneComplete T := + (congruence_iff_rightCompatible T).trans (rightCompatible_iff_piOneComplete T) + +theorem agreesWithExtensional_iff_piOneComplete (T : ArithmeticTheory) [𝐏𝐀 ≼ T] [Consistent T] : + AgreesWithExtensional T ↔ PiOneComplete T := + by + constructor + · intro h + exact + rightCompatible_implies_piOneComplete T (rightCompatible_of_pointwise_iff_extensional T h) + · intro h F G hF hG + exact pointwise_iff_extensional T h F G hF hG + +/-- The four statements in the manuscript's characterization theorem. -/ +theorem characterization (T : ArithmeticTheory) [𝐏𝐀 ≼ T] [Consistent T] : + (RightCompatible T ↔ CompositionCongruence T) ∧ + (CompositionCongruence T ↔ PiOneComplete T) ∧ + (PiOneComplete T ↔ AgreesWithExtensional T) := + ⟨(congruence_iff_rightCompatible T).symm, compositionCongruence_iff_piOneComplete T, + (agreesWithExtensional_iff_piOneComplete T).symm⟩ + +theorem quotient_composition_exists_iff_congruence (T : ArithmeticTheory) [𝐏𝐀 ≼ T] : + (∃ C : + Quotient (pointwiseSetoid T) → + Quotient (pointwiseSetoid T) → Quotient (pointwiseSetoid T), + ∀ F G, + C (Quotient.mk (pointwiseSetoid T) F) (Quotient.mk (pointwiseSetoid T) G) = + Quotient.mk (pointwiseSetoid T) (functionalComp F G)) ↔ + CompositionCongruence T := + by + rw [FailureOfComposition.quotient_composition_exists_iff] + constructor + · intro h F F' G G' hF hF' hG hG' hFF' hGG' + exact h ⟨F, hF⟩ ⟨F', hF'⟩ ⟨G, hG⟩ ⟨G', hG'⟩ hFF' hGG' + · intro h F F' G G' hFF' hGG' + exact h F.val F'.val G.val G'.val F.property F'.property G.property G'.property hFF' hGG' + +theorem no_quotient_composition_iff_not_piOneComplete (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + [Consistent T] : NoQuotientComposition T ↔ ¬PiOneComplete T := + by + unfold NoQuotientComposition + exact + not_congr + ((quotient_composition_exists_iff_congruence T).trans + (compositionCongruence_iff_piOneComplete T)) + +end PiOneCharacterization +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/PiOneCongruence.lean b/LeanPool/PointwiseComposition/FailureOfComposition/PiOneCongruence.lean new file mode 100644 index 000000000..b72b62856 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/PiOneCongruence.lean @@ -0,0 +1,92 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.PiOneDefinitions + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +Elementary composition laws for the Pi-one completeness characterization. +The input quantifier in pointwise provability remains external throughout. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic FFL.Entailment + +namespace FailureOfComposition +namespace PiOneCharacterization + +open ProofSearch + +/-- Composing on the left by a fixed graph always preserves pointwise +provability. The quantified intermediate value remains inside each proof. -/ +theorem pointwise_comp_left (T : ArithmeticTheory) [𝐏𝐀 ≼ T] (F G H : Graph) + (hGH : Pointwise T G H) : Pointwise T (comp F G) (comp F H) := + by + intro n + have h : 𝐏𝐀 ⊢ eqAt G H n ⇒ₗ eqAt (comp F G) (comp F H) n := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + have : M↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + simp only [Semantics.Imp.models_imply, models_iff, eqAt_eval, Nat.succ_eq_add_one, + Nat.reduceAdd, comp_eval, Fin.isValue, Matrix.cons_val_zero, Matrix.cons_val_one, + Fin.Fin1.eq_one, Matrix.cons_val_fin_one] + intro hg z + exact exists_congr fun y => and_congr (hg y) Iff.rfl + exact Entailment.mdp (WeakerThan.pbl h) (hGH n) + +/-- Standard equality of graph extensions is preserved in both arguments of +composition, without a functionality hypothesis. -/ +theorem extensional_comp {F F' G G' : Graph} (hF : Extensional F F') (hG : Extensional G G') : + Extensional (comp F G) (comp F' G') := by + intro x z + simp only [comp_eval, Matrix.cons_val_zero, Matrix.cons_val_one, Matrix.cons_val_fin_one] + exact exists_congr fun y => and_congr (hG x y) (hF y z) + +/-- The other variable of composition is automatically compatible, so full +congruence is equivalent to compatibility under right composition. -/ +theorem congruence_iff_rightCompatible (T : ArithmeticTheory) [𝐏𝐀 ≼ T] : + CompositionCongruence T ↔ RightCompatible T := + by + constructor + · intro h F H G hF hH hG hFH + exact h F H G G hF hH hG hG hFH ((pointwise_equivalence T).refl G) + · intro h F F' G G' hF hF' hG _ hFF' hGG' + exact + (pointwise_equivalence T).trans (h F F' G hF hF' hG hFF') + (pointwise_comp_left T F' G G' hGG') + +/-- Agreement between pointwise provability and standard graph equality on +functional graphs suffices for compatibility under right composition. -/ +theorem rightCompatible_of_pointwise_iff_extensional (T : ArithmeticTheory) + (h : AgreesWithExtensional T) : RightCompatible T := + by + intro F H G hF hH hG hFH + apply (h (comp F G) (comp H G) (comp_functional hF hG) (comp_functional hH hG)).mpr + exact extensional_comp ((h F H hF hH).mp hFH) (fun _ _ => Iff.rfl) + +/-- The same agreement gives full compatibility with composition. -/ +theorem compositionCongruence_of_pointwise_iff_extensional (T : ArithmeticTheory) + (h : AgreesWithExtensional T) : CompositionCongruence T := + by + intro F F' G G' hF hF' hG hG' hFF' hGG' + apply (h (comp F G) (comp F' G') (comp_functional hF hG) (comp_functional hF' hG')).mpr + exact extensional_comp ((h F F' hF hF').mp hFF') ((h G G' hG hG').mp hGG') + +end PiOneCharacterization +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/PiOneDefinitions.lean b/LeanPool/PointwiseComposition/FailureOfComposition/PiOneDefinitions.lean new file mode 100644 index 000000000..6badd394d --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/PiOneDefinitions.lean @@ -0,0 +1,62 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.GraphQuotient + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +Definitions for the Pi-one completeness characterization. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic FFL.Entailment + +namespace FailureOfComposition +namespace PiOneCharacterization + +open ProofSearch + +/-- Every true arithmetical Pi-one sentence is provable in `T`. -/ +def PiOneComplete (T : ArithmeticTheory) : Prop := + ∀ σ : ArithmeticSentence, Hierarchy Π 1 σ → ℕ↓[ℒₒᵣ] ⊧ σ → T ⊢ σ + +/-- Equality of the graphs on standard natural-number inputs and outputs. -/ +def Extensional (F G : Graph) : Prop := + ∀ x y : ℕ, F.val.Evalb ![x, y] ↔ G.val.Evalb ![x, y] + +/-- Right composition replaces the outer graph and fixes the inner graph. -/ +def RightCompatible (T : ArithmeticTheory) : Prop := + ∀ F H G : Graph, + Functional F → + Functional H → Functional G → Pointwise T F H → Pointwise T (comp F G) (comp H G) + +/-- The pointwise equivalence is preserved by composition in both arguments. -/ +def CompositionCongruence (T : ArithmeticTheory) : Prop := + ∀ F F' G G' : Graph, + Functional F → + Functional F' → + Functional G → + Functional G' → + Pointwise T F F' → Pointwise T G G' → Pointwise T (comp F G) (comp F' G') + +/-- Pointwise provability agrees with standard equality on functional graphs. -/ +def AgreesWithExtensional (T : ArithmeticTheory) : Prop := + ∀ F G : Graph, Functional F → Functional G → (Pointwise T F G ↔ Extensional F G) + +end PiOneCharacterization +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/PiOneExtensionality.lean b/LeanPool/PointwiseComposition/FailureOfComposition/PiOneExtensionality.lean new file mode 100644 index 000000000..691df3990 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/PiOneExtensionality.lean @@ -0,0 +1,188 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.PiOneDefinitions + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +Pi-one completeness identifies external pointwise provability with equality +of functional Sigma-one graphs on the natural numbers. No enumerability +assumption is used. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic FFL.Entailment + +namespace FailureOfComposition +namespace PiOneCharacterization + +open ProofSearch + +/-- A closed convergence assertion with both arguments standard numerals. -/ +def graphInstance (F : Graph) (n m : ℕ) : ArithmeticSentence := + “!F.val !!(n)!!(m)” + +/-- Absence of an output at one fixed standard input. -/ +def divergesAt (F : Graph) (n : ℕ) : ArithmeticSentence := + “∀ y, ¬!F.val !!(n)y” + +theorem graphInstance_sigma_one (F : Graph) (n m : ℕ) : Hierarchy Σ 1 (graphInstance F n m) := + by simp [graphInstance] + +theorem divergesAt_pi_one (F : Graph) (n : ℕ) : Hierarchy Π 1 (divergesAt F n) := by + simp [divergesAt] + +section Semantics + +variable {M : Type*} [ORingStructure M] [M↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +@[simp] +theorem graphInstance_eval (F : Graph) (n m : ℕ) : + (graphInstance F n m).Evalb (M := M) ![] ↔ F.val.Evalb ![(n : M), (m : M)] := by + simp [graphInstance, numeral_eq_natCast] + +@[simp] +theorem divergesAt_eval (F : Graph) (n : ℕ) : + (divergesAt F n).Evalb (M := M) ![] ↔ ∀ y : M, ¬F.val.Evalb ![(n : M), y] := by + simp [divergesAt, numeral_eq_natCast] + +end Semantics + +/-- A consistent Pi-one-complete theory cannot prove a false Sigma-one +sentence: it already proves that sentence's true Pi-one negation. -/ +theorem sigma_one_sound_of_pi_one_complete (T : ArithmeticTheory) [Consistent T] + (hT : PiOneComplete T) (σ : ArithmeticSentence) (hσ : Hierarchy Σ 1 σ) (hp : T ⊢ σ) : + ℕ↓[ℒₒᵣ] ⊧ σ := by + by_contra hn + have hnσ : T ⊢ ∼σ := hT (∼σ) (by simpa using hσ.neg) (by simpa using hn) + apply Consistent.not_bot (𝓢 := T) + cl_prover[hp, hnσ] + +/-- True ground convergence assertions are provable already in PA. -/ +theorem true_graph_instance_provable (F : Graph) (n m : ℕ) (h : F.val.Evalb ![n, m]) : + 𝐏𝐀 ⊢ graphInstance F n m := + by + apply sigma_one_completeness (graphInstance_sigma_one F n m) + simpa only [models_iff, graphInstance_eval, natCast_nat] using h + +private theorem ground_proof_of_pointwise (T : ArithmeticTheory) [𝐏𝐀 ≼ T] (F G : Graph) + (hFG : Pointwise T F G) (n m : ℕ) (hF : F.val.Evalb ![n, m]) : T ⊢ graphInstance G n m := + by + have hpF : T ⊢ graphInstance F n m := WeakerThan.pbl (true_graph_instance_provable F n m hF) + apply complete.{0} T + intro M _ _ + have : M↓[ℒₒᵣ] ⊧* 𝐏𝐀 := models_of_subtheory (U := T) inferInstance + have : M↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + have hEq : M↓[ℒₒᵣ] ⊧ eqAt F G n := + consequence_iff.mp (Theory.Proof.sound (hFG n)) M inferInstance + have hVal : M↓[ℒₒᵣ] ⊧ graphInstance F n m := + consequence_iff.mp (Theory.Proof.sound hpF) M inferInstance + simp only [models_iff, eqAt_eval] at hEq + simp only [models_iff, graphInstance_eval] at hVal ⊢ + exact (hEq (m : M)).mp hVal + +/-- Pi-one completeness and consistency make pointwise provability sound for +the represented graphs, including their individual convergence assertions. -/ +theorem pointwise_implies_extensional (T : ArithmeticTheory) [𝐏𝐀 ≼ T] [Consistent T] + (hT : PiOneComplete T) (F G : Graph) (hFG : Pointwise T F G) : Extensional F G := + by + intro n m + have forward {F G : Graph} (hFG : Pointwise T F G) (hF : F.val.Evalb ![n, m]) : + G.val.Evalb ![n, m] := + by + have hp := ground_proof_of_pointwise T F G hFG n m hF + have hs := sigma_one_sound_of_pi_one_complete T hT _ (graphInstance_sigma_one G n m) hp + simpa only [models_iff, graphInstance_eval, natCast_nat] using hs + exact ⟨forward hFG, forward ((pointwise_equivalence T).symm hFG)⟩ + +private theorem eqAt_provable_of_common_value (F G : Graph) (hF : Functional F) + (hG : Functional G) (n m : ℕ) (hnF : F.val.Evalb ![n, m]) (hnG : G.val.Evalb ![n, m]) : + 𝐏𝐀 ⊢ eqAt F G n := + by + have hpF := true_graph_instance_provable F n m hnF + have hpG := true_graph_instance_provable G n m hnG + apply complete.{0} 𝐏𝐀 + intro M _ _ + have : M↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + have hf : M↓[ℒₒᵣ] ⊧ functionalSentence F := + consequence_iff.mp (Theory.Proof.sound hF) M inferInstance + have hg : M↓[ℒₒᵣ] ⊧ functionalSentence G := + consequence_iff.mp (Theory.Proof.sound hG) M inferInstance + have hvF : M↓[ℒₒᵣ] ⊧ graphInstance F n m := + consequence_iff.mp (Theory.Proof.sound hpF) M inferInstance + have hvG : M↓[ℒₒᵣ] ⊧ graphInstance G n m := + consequence_iff.mp (Theory.Proof.sound hpG) M inferInstance + simp only [models_iff, functionalSentence_eval] at hf hg + simp only [models_iff, graphInstance_eval] at hvF hvG + rw [models_iff, eqAt_eval] + intro y + constructor + · intro hy + simpa only [hf (n : M) y (m : M) hy hvF] using hvG + · intro hy + simpa only [hg (n : M) y (m : M) hy hvG] using hvF + +private theorem eqAt_provable_of_divergence (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (hT : PiOneComplete T) (F G : Graph) (n : ℕ) (hF : ∀ m : ℕ, ¬F.val.Evalb ![n, m]) + (hG : ∀ m : ℕ, ¬G.val.Evalb ![n, m]) : T ⊢ eqAt F G n := + by + have hdF : T ⊢ divergesAt F n := + hT _ (divergesAt_pi_one F n) + (by simpa only [models_iff, divergesAt_eval, natCast_nat] using hF) + have hdG : T ⊢ divergesAt G n := + hT _ (divergesAt_pi_one G n) + (by simpa only [models_iff, divergesAt_eval, natCast_nat] using hG) + apply complete.{0} T + intro M _ _ + have : M↓[ℒₒᵣ] ⊧* 𝐏𝐀 := models_of_subtheory (U := T) inferInstance + have : M↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + have hf : M↓[ℒₒᵣ] ⊧ divergesAt F n := + consequence_iff.mp (Theory.Proof.sound hdF) M inferInstance + have hg : M↓[ℒₒᵣ] ⊧ divergesAt G n := + consequence_iff.mp (Theory.Proof.sound hdG) M inferInstance + simp only [models_iff, divergesAt_eval] at hf hg + rw [models_iff, eqAt_eval] + intro y + exact iff_of_false (hf y) (hg y) + +/-- Equality of functional standard graphs gives pointwise provability: +common values use PA computation proofs; joint divergence uses Pi-one +completeness. This direction does not require consistency. -/ +theorem extensional_implies_pointwise (T : ArithmeticTheory) [𝐏𝐀 ≼ T] (hT : PiOneComplete T) + (F G : Graph) (hF : Functional F) (hG : Functional G) (hFG : Extensional F G) : + Pointwise T F G := by + intro n + classical + by_cases hconv : ∃ m : ℕ, F.val.Evalb ![n, m] + · obtain ⟨m, hm⟩ := hconv + exact WeakerThan.pbl (eqAt_provable_of_common_value F G hF hG n m hm ((hFG n m).mp hm)) + · have hnF : ∀ m : ℕ, ¬F.val.Evalb ![n, m] := fun m hm => hconv ⟨m, hm⟩ + have hnG : ∀ m : ℕ, ¬G.val.Evalb ![n, m] := fun m hm => hnF m ((hFG n m).mpr hm) + exact eqAt_provable_of_divergence T hT F G n hnF hnG + +theorem pointwise_iff_extensional (T : ArithmeticTheory) [𝐏𝐀 ≼ T] [Consistent T] + (hT : PiOneComplete T) (F G : Graph) (hF : Functional F) (hG : Functional G) : + Pointwise T F G ↔ Extensional F G := + ⟨pointwise_implies_extensional T hT F G, extensional_implies_pointwise T hT F G hF hG⟩ + +theorem piOneComplete_implies_agreesWithExtensional (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + [Consistent T] (hT : PiOneComplete T) : AgreesWithExtensional T := fun F G hF hG => + pointwise_iff_extensional T hT F G hF hG + +end PiOneCharacterization +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/PiOneIndexCharacterization.lean b/LeanPool/PointwiseComposition/FailureOfComposition/PiOneIndexCharacterization.lean new file mode 100644 index 000000000..e4efcf252 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/PiOneIndexCharacterization.lean @@ -0,0 +1,226 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.ProgramIndices +public import LeanPool.PointwiseComposition.FailureOfComposition.PiOneCharacterization + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +The Pi-one characterization at program indices. Realization transports the +functional graph statements to every index in the given arithmetization; +standard adequacy identifies graph equality with equality of partial functions. +No effective presentation of the ambient theory is required. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic FFL.Entailment + +namespace FailureOfComposition +namespace ProgramIndices + +open ProofSearch + +/-- Right composition fixes the inner program and replaces the outer one. -/ +def RightCompatible (A : Arithmetization) (T : ArithmeticTheory) : Prop := + ∀ f h g : ℕ, PointwiseIndex A T f h → PointwiseIndex A T (A.compIndex f g) (A.compIndex h g) + +/-- Composition respects pointwise equality in both arguments. -/ +def CompositionCongruence (A : Arithmetization) (T : ArithmeticTheory) : Prop := + ∀ f f' g g' : ℕ, + PointwiseIndex A T f f' → + PointwiseIndex A T g g' → PointwiseIndex A T (A.compIndex f g) (A.compIndex f' g') + +/-- The two programs denote the same standard partial function. -/ +def ExtensionalIndex (A : Arithmetization) (e d : ℕ) : Prop := + A.evaluation e = A.evaluation d + +/-- Pointwise provability coincides with equality of denoted partial functions. -/ +def AgreesWithExtensional (A : Arithmetization) (T : ArithmeticTheory) : Prop := + ∀ e d : ℕ, PointwiseIndex A T e d ↔ ExtensionalIndex A e d + +/-- Adequacy turns equality of denotations into standard graph equality. -/ +theorem extensionalIndex_iff (A : Arithmetization) (e d : ℕ) : + ExtensionalIndex A e d ↔ PiOneCharacterization.Extensional (A.graph e) (A.graph d) := + by + constructor + · intro h x y + rw [A.adequate, A.adequate] + rw [show A.evaluation e = A.evaluation d from h] + · intro h + funext x + apply Part.ext + intro y + exact (A.adequate e x y).symm.trans ((h x y).trans (A.adequate d x y)) + +private theorem uniform_extensional {F G : Graph} (h : Uniform 𝐏𝐀 F G) : + PiOneCharacterization.Extensional F G := + by + have hs : ℕ↓[ℒₒᵣ] ⊧ uniformSentence F G := + consequence_iff.mp (Theory.Proof.sound h) ℕ inferInstance + simpa only [PiOneCharacterization.Extensional, models_iff, uniformSentence_eval] using hs + +/-- The composition graph equations transport compatibility to indices. -/ +theorem rightCompatible_of_graph (A : Arithmetization) (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (h : PiOneCharacterization.RightCompatible T) : RightCompatible A T := + by + intro f i g hfi + have heq := pointwise_equivalence T + apply (pointwiseIndex_iff A T _ _).mpr + exact + heq.trans (uniform_to_pointwise T (A.composition f g)) + (heq.trans + (h (A.graph f) (A.graph i) (A.graph g) (A.functional f) (A.functional i) + (A.functional g) ((pointwiseIndex_iff A T _ _).mp hfi)) + (heq.symm (uniform_to_pointwise T (A.composition i g)))) + +/-- Realization makes compatibility at indices sufficient for all functional +Sigma-one graphs. -/ +theorem rightCompatible_iff_graph (A : Arithmetization) (T : ArithmeticTheory) [𝐏𝐀 ≼ T] : + RightCompatible A T ↔ PiOneCharacterization.RightCompatible T := + by + constructor + · intro h F H G hF hH hG hFH + by_contra hn + obtain ⟨f, i, g, hfi, hcomp⟩ := + index_noncongruence_of_graph_noncongruence A T ⟨F, H, G, hF, hH, hG, hFH, hn⟩ + exact hcomp (h f i g hfi) + · exact rightCompatible_of_graph A T + +/-- Left composition is compatible for every extension of PA. -/ +theorem pointwiseIndex_comp_left (A : Arithmetization) (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (f g h : ℕ) (hgh : PointwiseIndex A T g h) : + PointwiseIndex A T (A.compIndex f g) (A.compIndex f h) := + by + have heq := pointwise_equivalence T + apply (pointwiseIndex_iff A T _ _).mpr + exact + heq.trans (uniform_to_pointwise T (A.composition f g)) + (heq.trans + (PiOneCharacterization.pointwise_comp_left T (A.graph f) (A.graph g) (A.graph h) + ((pointwiseIndex_iff A T _ _).mp hgh)) + (heq.symm (uniform_to_pointwise T (A.composition f h)))) + +/-- Automatic left compatibility supplies the other argument of composition. -/ +theorem congruence_iff_rightCompatible (A : Arithmetization) (T : ArithmeticTheory) [𝐏𝐀 ≼ T] : + CompositionCongruence A T ↔ RightCompatible A T := + by + constructor + · intro h f i g hfi + exact h f i g g hfi ((indexSetoid A T).refl g) + · intro h f f' g g' hff' hgg' + exact (indexSetoid A T).trans (h f f' g hff') (pointwiseIndex_comp_left A T f' g g' hgg') + +/-- The full composition property is unchanged by passing to indices. -/ +theorem compositionCongruence_iff_graph (A : Arithmetization) (T : ArithmeticTheory) [𝐏𝐀 ≼ T] : + CompositionCongruence A T ↔ PiOneCharacterization.CompositionCongruence T := + (congruence_iff_rightCompatible A T).trans + ((rightCompatible_iff_graph A T).trans + (PiOneCharacterization.congruence_iff_rightCompatible T).symm) + +/-- The graph and index formulations of agreement with extensional equality +are equivalent; PA proofs of realization are used only via PA soundness. -/ +theorem agreesWithExtensional_iff_graph (A : Arithmetization) (T : ArithmeticTheory) [𝐏𝐀 ≼ T] : + AgreesWithExtensional A T ↔ PiOneCharacterization.AgreesWithExtensional T := + by + constructor + · intro h F G hF hG + obtain ⟨e, he⟩ := A.realization F hF + obtain ⟨d, hd⟩ := A.realization G hG + have hep := uniform_to_pointwise T he + have hdp := uniform_to_pointwise T hd + have hee := uniform_extensional he + have hde := uniform_extensional hd + have heq := pointwise_equivalence T + constructor + · intro hFG + have hed : PointwiseIndex A T e d := + (pointwiseIndex_iff A T _ _).mpr (heq.trans hep (heq.trans hFG (heq.symm hdp))) + have hext := (extensionalIndex_iff A e d).mp ((h e d).mp hed) + intro x y + exact (hee x y).symm.trans ((hext x y).trans (hde x y)) + · intro hFG + have hext : PiOneCharacterization.Extensional (A.graph e) (A.graph d) := fun x y => + (hee x y).trans ((hFG x y).trans (hde x y).symm) + have hed := (h e d).mpr ((extensionalIndex_iff A e d).mpr hext) + exact heq.trans (heq.symm hep) (heq.trans ((pointwiseIndex_iff A T _ _).mp hed) hdp) + · intro h e d + exact + (pointwiseIndex_iff A T e d).trans + ((h (A.graph e) (A.graph d) (A.functional e) (A.functional d)).trans + (extensionalIndex_iff A e d).symm) + +/-- Right composition is compatible exactly for Pi-one complete theories. -/ +theorem rightCompatible_iff_piOneComplete (A : Arithmetization) (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + [Consistent T] : RightCompatible A T ↔ PiOneCharacterization.PiOneComplete T := + (rightCompatible_iff_graph A T).trans + (PiOneCharacterization.rightCompatible_iff_piOneComplete T) + +/-- Full composition congruence has the same Pi-one completeness criterion. -/ +theorem compositionCongruence_iff_piOneComplete (A : Arithmetization) (T : ArithmeticTheory) + [𝐏𝐀 ≼ T] [Consistent T] : + CompositionCongruence A T ↔ PiOneCharacterization.PiOneComplete T := + (compositionCongruence_iff_graph A T).trans + (PiOneCharacterization.compositionCongruence_iff_piOneComplete T) + +/-- The fourth statement uses equality of actual partial-function denotations. -/ +theorem agreesWithExtensional_iff_piOneComplete (A : Arithmetization) (T : ArithmeticTheory) + [𝐏𝐀 ≼ T] [Consistent T] : + AgreesWithExtensional A T ↔ PiOneCharacterization.PiOneComplete T := + (agreesWithExtensional_iff_graph A T).trans + (PiOneCharacterization.agreesWithExtensional_iff_piOneComplete T) + +/-- For a consistent Pi-one complete extension of PA, pointwise provability +is exactly extensional equality of the interpreted programs. -/ +theorem pointwiseIndex_iff_evaluation_eq (A : Arithmetization) (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + [Consistent T] (h : PiOneCharacterization.PiOneComplete T) (e d : ℕ) : + PointwiseIndex A T e d ↔ A.evaluation e = A.evaluation d := + ((agreesWithExtensional_iff_piOneComplete A T).mpr h) e d + +/-- All four manuscript statements, without an enumerability hypothesis. -/ +theorem characterization (A : Arithmetization) (T : ArithmeticTheory) [𝐏𝐀 ≼ T] [Consistent T] : + (RightCompatible A T ↔ CompositionCongruence A T) ∧ + (CompositionCongruence A T ↔ PiOneCharacterization.PiOneComplete T) ∧ + (PiOneCharacterization.PiOneComplete T ↔ AgreesWithExtensional A T) := + ⟨(congruence_iff_rightCompatible A T).symm, compositionCongruence_iff_piOneComplete A T, + (agreesWithExtensional_iff_piOneComplete A T).symm⟩ + +/-- An operation on the quotient inducing program composition exists exactly +when the index relation is a composition congruence. -/ +theorem quotient_composition_exists_iff_congruence (A : Arithmetization) (T : ArithmeticTheory) + [𝐏𝐀 ≼ T] : + (∃ C : Quotient (indexSetoid A T) → Quotient (indexSetoid A T) → Quotient (indexSetoid A T), + ∀ e d, + C (Quotient.mk (indexSetoid A T) e) (Quotient.mk (indexSetoid A T) d) = + Quotient.mk (indexSetoid A T) (A.compIndex e d)) ↔ + CompositionCongruence A T := + FailureOfComposition.quotient_composition_exists_iff (indexSetoid A T) A.compIndex + +/-- The obstruction to quotient composition is precisely failure of Pi-one +completeness, even for theories without an effective presentation. -/ +theorem no_index_quotient_iff_not_piOneComplete (A : Arithmetization) (T : ArithmeticTheory) + [𝐏𝐀 ≼ T] [Consistent T] : + NoIndexQuotientComposition A T ↔ ¬PiOneCharacterization.PiOneComplete T := + by + unfold NoIndexQuotientComposition + exact + not_congr + ((quotient_composition_exists_iff_congruence A T).trans + (compositionCongruence_iff_piOneComplete A T)) + +end ProgramIndices +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/PiOneNecessity.lean b/LeanPool/PointwiseComposition/FailureOfComposition/PiOneNecessity.lean new file mode 100644 index 000000000..128a5ae6f --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/PiOneNecessity.lean @@ -0,0 +1,75 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.PiOneDefinitions +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Incompleteness.Definability + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +Right compatibility forces every true Pi-one sentence to be provable. The +witnesses search for PA proofs of the negation of the proposed sentence. +Only PA standard soundness is used; no soundness or consistency of T is assumed. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +open FFL.FirstOrder.Arithmetic.Bootstrapping FFL.Entailment + +namespace FailureOfComposition +namespace PiOneCharacterization + +/-- A true Pi-one sentence omitted by T gives functional graphs witnessing +failure of right compatibility. -/ +theorem graph_noncongruence_of_true_unprovable_pi_one (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (σ : ArithmeticSentence) (hσ : Hierarchy Π 1 σ) (htrue : ℕ↓[ℒₒᵣ] ⊧ σ) (hnot : T ⊬ σ) : + ∃ F H G : ProofSearch.Graph, + ProofSearch.Functional F ∧ + ProofSearch.Functional H ∧ + ProofSearch.Functional G ∧ + ProofSearch.Pointwise T F H ∧ + ¬ProofSearch.Pointwise T (ProofSearch.comp F G) (ProofSearch.comp H G) := + by + let : 𝐈Σ₁ ≼ T := WeakerThan.trans (𝓣 := 𝐏𝐀) inferInstance inferInstance + have hneg : Hierarchy Σ 1 (∼σ) := by simpa using hσ + have hPA : 𝐏𝐀 ⊬ ∼σ := by + intro hp + have hn : ℕ↓[ℒₒᵣ] ⊧ ∼σ := consequence_iff.mp (Theory.Proof.sound hp) ℕ inferInstance + have hfalse : ¬ℕ↓[ℒₒᵣ] ⊧ σ := by simpa [models_iff] using hn + exact hfalse htrue + have hAbs : T ⊬ ∼provabilityPred 𝐏𝐀 (∼σ) := + by + intro hp + apply hnot + have hs : T ⊢ ∼σ ⇒ₗ provabilityPred 𝐏𝐀 (∼σ) := + WeakerThan.pbl (provable_sigma_one_complete (T := 𝐏𝐀) hneg) + cl_prover[hs, hp] + exact ProofSearch.functional_graph_noncongruence 𝐏𝐀 (∼σ) T hPA hAbs + +/-- No consistency or effective presentation of T is needed for necessity. -/ +theorem rightCompatible_implies_piOneComplete (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (h : RightCompatible T) : PiOneComplete T := + by + intro σ hσ htrue + by_contra hnot + obtain ⟨F, H, G, hF, hH, hG, hFH, hcomp⟩ := + graph_noncongruence_of_true_unprovable_pi_one T σ hσ htrue hnot + exact hcomp (h F H G hF hH hG hFH) + +end PiOneCharacterization +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/ProductiveDivergence.lean b/LeanPool/PointwiseComposition/FailureOfComposition/ProductiveDivergence.lean new file mode 100644 index 000000000..7e1384a24 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/ProductiveDivergence.lean @@ -0,0 +1,129 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.Meta.ClProver +public import LeanPool.PointwiseComposition.FailureOfComposition.Productiveness +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.DerivabilityCondition.D1 +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.R0.Representation + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +The productiveness proof of a true unprovable divergence sentence. +This module does not import or invoke second incompleteness. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +open FFL.FirstOrder.Arithmetic.Bootstrapping FFL.Entailment + +open Encodable Denumerable _root_.Nat.Partrec + +namespace FailureOfComposition + +noncomputable section + +theorem diagonalHalts_re : REPred diagonalHalts := by + exact (Code.eval_part.comp (Computable.ofNat Code) Computable.id).dom_re + +/-- The diagonal Halting Formula construction in `FailureOfComposition`. -/ +def diagonalHaltingFormula : ArithmeticSemisentence 1 := + codeOfREPred diagonalHalts + +theorem diagonalHaltingFormula_sigma : Hierarchy Σ 1 diagonalHaltingFormula := by + simp [diagonalHaltingFormula, codeOfREPred, codeOfPartrec'] + +theorem diagonalHaltingFormula_nat (n : ℕ) : + diagonalHaltingFormula.Evalb ![n] ↔ diagonalHalts n := + codeOfREPred_spec diagonalHalts_re + +/-- The provable Divergence construction in `FailureOfComposition`. -/ +def provableDivergence (T : ArithmeticTheory) (n : ℕ) : Prop := + T ⊢ ∼diagonalHaltingFormula/[n] + +/-- The numerical set of all theorem codes, using Foundation's sentence coding. -/ +def TheoremCodes (T : ArithmeticTheory) (n : ℕ) : Prop := + ∃ σ : ArithmeticSentence, (⌜σ⌝ : ℕ) = n ∧ T ⊢ σ + +/-- Enumerability of the theorem-code set suffices; no Delta-one presentation +of T is used in this theorem. -/ +theorem provableDivergence_re_of_theorem_codes (T : ArithmeticTheory) + (hT : REPred (TheoremCodes T)) : REPred (provableDivergence T) := + by + let code : ℕ → ℕ := fun n => + neg ℒₒᵣ (subst ℒₒᵣ ?[Bootstrapping.ObjectArithmetic.numeral n] ⌜diagonalHaltingFormula⌝) + have hcode : Computable code := + computable_iff_sigma1.mpr + (by + dsimp [code] + definability) + apply REPred.of_eq (hT.comp hcode) + intro n + have heq : code n = (⌜(∼diagonalHaltingFormula/[n] : ArithmeticSentence)⌝ : ℕ) := by + simp [code, Sentence.quote_def, Semiformula.quote_def, Rewriting.emb_subst_eq_subst_coe₁] + simp [TheoremCodes, heq, provableDivergence] + +theorem provableDivergence_re (T : ArithmeticTheory) [T.Δ₁] : REPred (provableDivergence T) := + by + have h : + Σ₁-Predicate fun n : ℕ => + Bootstrapping.Provable T + (neg ℒₒᵣ + (subst ℒₒᵣ ?[Bootstrapping.ObjectArithmetic.numeral n] ⌜diagonalHaltingFormula⌝)) := + by definability + apply REPred.of_eq (rePred_iff_sigma1.mpr h) + intro n + constructor + · intro hp + apply Bootstrapping.Provable.sound + simpa [Sentence.quote_def, Semiformula.quote_def, Rewriting.emb_subst_eq_subst_coe₁] using + hp + · intro hp + simpa [Sentence.quote_def, Semiformula.quote_def, Rewriting.emb_subst_eq_subst_coe₁] using + internalize_provability (V := ℕ) hp + +/-- Consistency suffices; Sigma-one soundness is not assumed. -/ +theorem provableDivergence_sound (T : ArithmeticTheory) [𝐑₀ ≼ T] [Consistent T] (n : ℕ) : + provableDivergence T n → ¬diagonalHalts n := + by + intro hn hhalt + have hp : T ⊢ diagonalHaltingFormula/[n] := + by + apply sigma_one_completeness (by simp [diagonalHaltingFormula_sigma]) + simpa [models_iff, Semiformula.eval_substs, Matrix.constant_eq_singleton] using + (diagonalHaltingFormula_nat n).mpr hhalt + apply Consistent.not_bot (𝓢 := T) + have hn : T ⊢ ∼diagonalHaltingFormula/[n] := hn + cl_prover[hp, hn] + +/-- A concrete diagonal computation diverges, but its represented divergence +is not provable in the consistent Delta-one-presented theory. -/ +theorem exists_true_unprovable_divergence (T : ArithmeticTheory) [T.Δ₁] [𝐑₀ ≼ T] + [Consistent T] : ∃ d : ℕ, ¬diagonalHalts d ∧ T ⊬ ∼diagonalHaltingFormula/[d] := by + exact productive_escape_re (provableDivergence_re T) (provableDivergence_sound T) + +theorem exists_true_unprovable_divergence_of_theorem_codes (T : ArithmeticTheory) [𝐑₀ ≼ T] + [Consistent T] (hT : REPred (TheoremCodes T)) : + ∃ d : ℕ, ¬diagonalHalts d ∧ T ⊬ ∼diagonalHaltingFormula/[d] := by + exact + productive_escape_re (provableDivergence_re_of_theorem_codes T hT) + (provableDivergence_sound T) + +end + +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/ProductiveGraph.lean b/LeanPool/PointwiseComposition/FailureOfComposition/ProductiveGraph.lean new file mode 100644 index 000000000..6cbc94e60 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/ProductiveGraph.lean @@ -0,0 +1,99 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.GraphQuotient +public import LeanPool.PointwiseComposition.FailureOfComposition.ProductiveDivergence +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Incompleteness.Definability + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +Productiveness supplies a true unprovable divergence sentence. Searching for PA +proofs of its halting counterpart gives a Delta-one witness predicate. Internal +Sigma-one completeness connects absence of those proofs to divergence. +This proof does not invoke the second incompleteness theorem. +The proof-search witnesses are a variant of v36's direct computation search. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +open FFL.FirstOrder.Arithmetic.Bootstrapping FFL.Entailment + +namespace FailureOfComposition + +theorem graph_noncongruence_of_unprovable_divergence (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (hex : ∃ d : ℕ, ¬diagonalHalts d ∧ T ⊬ ∼diagonalHaltingFormula/[d]) : + ∃ F I G : ProofSearch.Graph, + ProofSearch.Functional F ∧ + ProofSearch.Functional I ∧ + ProofSearch.Functional G ∧ + ProofSearch.Pointwise T F I ∧ + ¬ProofSearch.Pointwise T (ProofSearch.comp F G) (ProofSearch.comp I G) := + by + let : 𝐈Σ₁ ≼ T := WeakerThan.trans (𝓣 := 𝐏𝐀) inferInstance inferInstance + obtain ⟨d, hdiv, hnot⟩ := hex + let σ : ArithmeticSentence := diagonalHaltingFormula/[d] + have hσ : Hierarchy Σ 1 σ := by simp [σ, diagonalHaltingFormula_sigma] + have hPA : 𝐏𝐀 ⊬ σ := by + intro hp + have hnat : ℕ↓[ℒₒᵣ] ⊧ σ := consequence_iff.mp (Theory.Proof.sound hp) ℕ inferInstance + apply hdiv + apply (diagonalHaltingFormula_nat d).mp + simpa [σ, models_iff, Semiformula.eval_substs, Matrix.constant_eq_singleton] using hnat + have hAbs : T ⊬ ∼provabilityPred 𝐏𝐀 σ := by + intro hp + apply hnot + have hs : T ⊢ σ ⇒ₗ provabilityPred 𝐏𝐀 σ := + WeakerThan.pbl (provable_sigma_one_complete (T := 𝐏𝐀) hσ) + change T ⊢ ∼σ + cl_prover[hs, hp] + exact ProofSearch.functional_graph_noncongruence 𝐏𝐀 σ T hPA hAbs + +theorem graph_noncongruence_via_productiveness (T : ArithmeticTheory) [T.Δ₁] [Consistent T] + [𝐏𝐀 ≼ T] : + ∃ F I G : ProofSearch.Graph, + ProofSearch.Functional F ∧ + ProofSearch.Functional I ∧ + ProofSearch.Functional G ∧ + ProofSearch.Pointwise T F I ∧ + ¬ProofSearch.Pointwise T (ProofSearch.comp F G) (ProofSearch.comp I G) := + by exact graph_noncongruence_of_unprovable_divergence T (exists_true_unprovable_divergence T) + +theorem pa_graph_noncongruence_via_productiveness : + ∃ F I G : ProofSearch.Graph, + ProofSearch.Functional F ∧ + ProofSearch.Functional I ∧ + ProofSearch.Functional G ∧ + ProofSearch.Pointwise 𝐏𝐀 F I ∧ + ¬ProofSearch.Pointwise 𝐏𝐀 (ProofSearch.comp F G) (ProofSearch.comp I G) := + graph_noncongruence_via_productiveness 𝐏𝐀 + +theorem no_graph_quotient_composition_via_productiveness (T : ArithmeticTheory) [T.Δ₁] + [Consistent T] [𝐏𝐀 ≼ T] : ProofSearch.NoQuotientComposition T := + ProofSearch.no_quotient_composition_of_graph_noncongruence T + (graph_noncongruence_via_productiveness T) + +/-- R.e. is stated directly for the complete theorem-code set. This theorem +has no Delta-one presentation or soundness assumption on T. -/ +theorem no_graph_quotient_composition_of_re_theorem_codes (T : ArithmeticTheory) [Consistent T] + [𝐏𝐀 ≼ T] (hT : REPred (TheoremCodes T)) : ProofSearch.NoQuotientComposition T := + ProofSearch.no_quotient_composition_of_graph_noncongruence T + (graph_noncongruence_of_unprovable_divergence T + (exists_true_unprovable_divergence_of_theorem_codes T hT)) + +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/Productiveness.lean b/LeanPool/PointwiseComposition/FailureOfComposition/Productiveness.lean new file mode 100644 index 000000000..7581fbd73 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/Productiveness.lean @@ -0,0 +1,70 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import Mathlib.Computability.RE + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +The productiveness step in v36, for Mathlib's program numbering. +The productivity function is the identity on program numbers. +-/ + +@[expose] public section + +namespace FailureOfComposition + +open Encodable Denumerable _root_.Nat.Partrec + +/-- The W construction in `FailureOfComposition`. -/ +def W (e n : ℕ) : Prop := + (Code.eval (ofNat Code e) n).Dom + +/-- The diagonal Halts construction in `FailureOfComposition`. -/ +def diagonalHalts (n : ℕ) : Prop := + W n n + +/-- The usual productive-set condition, including computability of the witness. -/ +def Productive (A : ℕ → Prop) : Prop := + ∃ p : ℕ → ℕ, Computable p ∧ ∀ d, (∀ n, W d n → A n) → A (p d) ∧ ¬W d (p d) + +theorem diagonal_escape (d : ℕ) (h : ∀ n, W d n → ¬diagonalHalts n) : + ¬diagonalHalts d ∧ ¬W d d := + by + have hd : ¬W d d := fun hd => h d hd hd + exact ⟨hd, hd⟩ + +theorem complement_diagonal_productive : Productive (fun n => ¬diagonalHalts n) := by + exact ⟨id, Computable.id, diagonal_escape⟩ + +/-- A domain presentation of an r.e. predicate, with the numbering made explicit. -/ +theorem exists_domain_index {D : ℕ → Prop} (hD : REPred D) : ∃ d, ∀ n, W d n ↔ D n := + by + have hf := hD.map (Computable.const (0 : ℕ)).to₂ + obtain ⟨c, hc⟩ := Code.exists_code.mp (Partrec.nat_iff.mp hf) + refine ⟨encode c, ?_⟩ + intro n + simp [W, hc, Part.assert] + +/-- The diagonal index itself escapes any r.e. subset of the divergent diagonal. -/ +theorem productive_escape_re {D : ℕ → Prop} (hD : REPred D) + (hSound : ∀ n, D n → ¬diagonalHalts n) : ∃ d, ¬diagonalHalts d ∧ ¬D d := + by + obtain ⟨d, hd⟩ := exists_domain_index hD + obtain ⟨hdiv, hnot⟩ := diagonal_escape d (fun n hn => hSound n ((hd n).mp hn)) + exact ⟨d, hdiv, fun hn => hnot ((hd d).mpr hn)⟩ + +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/ProgramGraph.lean b/LeanPool/PointwiseComposition/FailureOfComposition/ProgramGraph.lean new file mode 100644 index 000000000..115cf2cb4 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/ProgramGraph.lean @@ -0,0 +1,111 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteEvaluatorGraph +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteConstructorGraphs + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +Program graphs indexed by actual Mathlib program descriptions. -/ + +@[expose] public section + +open Encodable FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +open CategoricalRiceShapiro.PartialRecursive + +namespace FailureOfComposition +namespace ProgramGraph + +open ConcreteEvaluator + +/-- The PCode construction in `FailureOfComposition.ProgramGraph`. -/ +abbrev PCode := + Nat.Partrec.Code + +/-- The Computes construction in `FailureOfComposition.ProgramGraph`. -/ +def Computes {M : Type*} [ORingStructure M] (c : PCode) (x y : M) : Prop := + (eventualGraph (encode c)).val.Evalb ![x, y] + +variable {M : Type*} [ORingStructure M] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + +omit [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] in +theorem computes_comp (f g : PCode) (x z : M) : + Computes (.comp f g) x z ↔ ∃ y : M, Computes g x y ∧ Computes f y z := + by + have he : + canonicalPartrecCompIndex (encode f) (encode g) = encode (Nat.Partrec.Code.comp f g) := by + simp only [canonicalPartrecCompIndex, Denumerable.ofNat_encode] + simpa only [he, Computes] using eventualGraph_comp_eval (encode f) (encode g) x z + +theorem computes_zero (x y : M) : Computes .zero x y ↔ y = 0 := + by + simp only [Computes, show encode (Nat.Partrec.Code.zero) = 0 from rfl, eventualGraph_eval, + numeral_eq_natCast_app, Matrix.cons_val_zero, Matrix.cons_val_one] + simpa [ConcreteWitnessGraphs.baseOutput] using + ConcreteWitnessGraphs.base_unbounded_computation_iff 0 (by decide) x y + +theorem computes_succ (x y : M) : Computes .succ x y ↔ y = x + 1 := + by + simp only [Computes, show encode (Nat.Partrec.Code.succ) = 1 from rfl, eventualGraph_eval, + numeral_eq_natCast_app, Matrix.cons_val_zero, Matrix.cons_val_one] + simpa [ConcreteWitnessGraphs.baseOutput] using + ConcreteWitnessGraphs.base_unbounded_computation_iff 1 (by decide) x y + +theorem computes_left (x y : M) : Computes .left x y ↔ y = pi₁ x := + by + simp only [Computes, show encode (Nat.Partrec.Code.left) = 2 from rfl, eventualGraph_eval, + numeral_eq_natCast_app, Matrix.cons_val_zero, Matrix.cons_val_one] + simpa [ConcreteWitnessGraphs.baseOutput] using + ConcreteWitnessGraphs.base_unbounded_computation_iff 2 (by decide) x y + +theorem computes_right (x y : M) : Computes .right x y ↔ y = pi₂ x := + by + simp only [Computes, show encode (Nat.Partrec.Code.right) = 3 from rfl, eventualGraph_eval, + numeral_eq_natCast_app, Matrix.cons_val_zero, Matrix.cons_val_one] + simpa [ConcreteWitnessGraphs.baseOutput] using + ConcreteWitnessGraphs.base_unbounded_computation_iff 3 (by decide) x y + +theorem computes_id (x y : M) : Computes Nat.Partrec.Code.id x y ↔ y = x := + by + have hu : + M↓[ℒₒᵣ] ⊧ + ProofSearch.uniformSentence (eventualGraph Kleene.identityIndex) ProofSearch.identity := + consequence_iff.mp (Theory.Proof.sound eventualGraph_identity) M inferInstance + simp only [models_iff, ProofSearch.uniformSentence_eval] at hu + simpa only [Computes, Kleene.identityIndex, ProofSearch.identity_eval, Matrix.cons_val_zero, + Matrix.cons_val_one] using hu x y + +theorem computes_pair (f g : PCode) (x z : M) : + Computes (.pair f g) x z ↔ ∃ a b : M, Computes f x a ∧ Computes g x b ∧ z = pair a b := + eventualGraph_pair_code_eval f g x z + +theorem computes_const (n : ℕ) (x y : M) : + Computes (Nat.Partrec.Code.const n) x y ↔ y = (n : M) := by + induction n generalizing x y with + | zero => simpa only [Nat.Partrec.Code.const, Nat.cast_zero] using computes_zero x y + | succ n ih => + rw [Nat.Partrec.Code.const, computes_comp] + simp only [ih, computes_succ, exists_eq_left, Nat.cast_add, Nat.cast_one] + +omit [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] in +theorem computes_unique (c : PCode) (x y z : M) (hy : Computes c x y) (hz : Computes c x z) : + y = z := + eventualGraph_output_unique (encode c) x y z hy hz + +end ProgramGraph +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/ProgramIndices.lean b/LeanPool/PointwiseComposition/FailureOfComposition/ProgramIndices.lean new file mode 100644 index 000000000..6e2e2d7d1 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/ProgramIndices.lean @@ -0,0 +1,218 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.GodelGraph +public import LeanPool.PointwiseComposition.FailureOfComposition.ProductiveGraph + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +Index-level consequence of the arithmetization assumptions explicitly stated +in v36, equations (composition-graph) and (graph-realization). + +`Arithmetization` is a hypothesis, not a constructed instance for Mathlib's +evaluator. In particular, the realization field is not discharged here. +No theorem in this file identifies standard-model equivalence with PA provability. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic FFL.Entailment + +namespace FailureOfComposition +namespace ProgramIndices + +open ProofSearch + +noncomputable section + +/-- The paper's definedness equivalence and common-value clause. -/ +def kleeneEqAt (F G : Graph) (n : ℕ) : ArithmeticSentence := + “((∃ y, !F.val !!(n)y) ↔ (∃ y, !G.val !!(n)y)) ∧ + ((∃ y, !F.val !!(n)y) → ∃ y, !F.val !!(n)y ∧ !G.val !!(n)y)” + +/-- Functionality is what makes output-quantified graph equality the same +as the manuscript's equality, including agreement on divergence. -/ +theorem kleeneEqAt_iff_eqAt (F G : Graph) (hF : Functional F) (hG : Functional G) (n : ℕ) : + 𝐏𝐀 ⊢ kleeneEqAt F G n ⇔ₗ eqAt F G n := + by + apply complete.{0} 𝐏𝐀 + intro V _ _ + have : V↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + have hf : V↓[ℒₒᵣ] ⊧ functionalSentence F := + consequence_iff.mp (Theory.Proof.sound hF) V inferInstance + have hg : V↓[ℒₒᵣ] ⊧ functionalSentence G := + consequence_iff.mp (Theory.Proof.sound hG) V inferInstance + simp only [models_iff, functionalSentence_eval] at hf hg + simp only [kleeneEqAt, Nat.reduceAdd, Fin.Fin1.eq_one, Fin.isValue, eqAt, + Semantics.models_iff, Semantics.And.models_and, models_iff, Semiformula.eval_ex, + Nat.succ_eq_add_one, Semiformula.eval_substs, Matrix.comp₂, Semiterm.val_operator, + Matrix.comp₀, Tarski.Structure.numeral_eq_numeral, numeral_eq_natCast, Semiterm.val_bvar, + Matrix.cons_val_fin_one, Semantics.Imp.models_imply, LogicalConnective.HomClass.map_and, + LogicalConnective.Prop.and_eq, forall_exists_index, Semiformula.eval_all, + LogicalConnective.HomClass.map_iff, LogicalConnective.Prop.iff_eq] + constructor + · rintro ⟨hdom, hcommon⟩ y + constructor + · intro hy + obtain ⟨z, hzF, hzG⟩ := hcommon y hy + have heq := hf (n : V) y z hy hzF + simpa [heq] using hzG + · intro hy + obtain ⟨w, hw⟩ := hdom.mpr ⟨y, hy⟩ + obtain ⟨z, hzF, hzG⟩ := hcommon w hw + have heq := hg (n : V) y z hy hzG + simpa [heq] using hzF + · intro h + refine ⟨exists_congr h, ?_⟩ + intro y hy + exact ⟨y, hy, (h y).mp hy⟩ + +/-- The two PA-level arithmetization theorems assumed in v36, together with +functionality. Supplying this structure is a substantial separate obligation. -/ +structure Arithmetization where + /-- The evaluation construction in `FailureOfComposition.ProgramIndices.Arithmetization`. -/ + evaluation : ℕ → ℕ → Part ℕ + /-- The graph construction in `FailureOfComposition.ProgramIndices.Arithmetization`. -/ + graph : ℕ → Graph + /-- The comp Index construction in `FailureOfComposition.ProgramIndices.Arithmetization`. -/ + compIndex : ℕ → ℕ → ℕ + compIndex_primrec : Primrec₂ compIndex + adequate : ∀ e x y, (graph e).val.Evalb ![x, y] ↔ y ∈ evaluation e x + functional : ∀ e, Functional (graph e) + composition : ∀ e d, Uniform 𝐏𝐀 (graph (compIndex e d)) (comp (graph e) (graph d)) + realization : ∀ F : Graph, Functional F → ∃ e, Uniform 𝐏𝐀 (graph e) F + +theorem uniform_to_pointwise (T : ArithmeticTheory) [𝐏𝐀 ≼ T] {F G : Graph} + (h : Uniform 𝐏𝐀 F G) : Pointwise T F G := + by + intro n + apply WeakerThan.pbl (𝓢 := 𝐏𝐀) + apply complete.{0} 𝐏𝐀 + intro V _ _ + have : V↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + have hu : V↓[ℒₒᵣ] ⊧ uniformSentence F G := + consequence_iff.mp (Theory.Proof.sound h) V inferInstance + simp only [models_iff, uniformSentence_eval] at hu + simpa only [models_iff, eqAt_eval] using hu (n : V) + +theorem uniform_comp {F F' G G' : Graph} (hF : Uniform 𝐏𝐀 F F') (hG : Uniform 𝐏𝐀 G G') : + Uniform 𝐏𝐀 (comp F G) (comp F' G') := + by + apply complete.{0} 𝐏𝐀 + intro V _ _ + have hf : V↓[ℒₒᵣ] ⊧ uniformSentence F F' := + consequence_iff.mp (Theory.Proof.sound hF) V inferInstance + have hg : V↓[ℒₒᵣ] ⊧ uniformSentence G G' := + consequence_iff.mp (Theory.Proof.sound hG) V inferInstance + simp only [models_iff, uniformSentence_eval] at hf hg ⊢ + intro x z + simp only [comp_eval, Matrix.cons_val_zero, Matrix.cons_val_one, Matrix.cons_val_fin_one] + exact exists_congr fun y => and_congr (hg x y) (hf y z) + +/-- The Pointwise Index construction in `FailureOfComposition.ProgramIndices`. -/ +def PointwiseIndex (A : Arithmetization) (T : ArithmeticTheory) (e d : ℕ) : Prop := + ∀ n, T ⊢ kleeneEqAt (A.graph e) (A.graph d) n + +theorem pointwiseIndex_iff (A : Arithmetization) (T : ArithmeticTheory) [𝐏𝐀 ≼ T] (e d : ℕ) : + PointwiseIndex A T e d ↔ Pointwise T (A.graph e) (A.graph d) := + by + have h (n : ℕ) : T ⊢ kleeneEqAt (A.graph e) (A.graph d) n ⇔ₗ eqAt (A.graph e) (A.graph d) n := + WeakerThan.pbl (kleeneEqAt_iff_eqAt _ _ (A.functional e) (A.functional d) n) + constructor + · intro he n + have hn := he n + cl_prover[h n, hn] + · intro he n + have hn := he n + cl_prover[h n, hn] + +/-- The index Setoid construction in `FailureOfComposition.ProgramIndices`. -/ +def indexSetoid (A : Arithmetization) (T : ArithmeticTheory) [𝐏𝐀 ≼ T] : Setoid ℕ + where + r := PointwiseIndex A T + iseqv := + { refl := fun e => (pointwiseIndex_iff A T e e).mpr ((pointwise_equivalence T).refl _) + symm := fun {e d} h => + (pointwiseIndex_iff A T d e).mpr + ((pointwise_equivalence T).symm ((pointwiseIndex_iff A T e d).mp h)) + trans := fun {e d f} h₁ h₂ => + (pointwiseIndex_iff A T e f).mpr + ((pointwise_equivalence T).trans ((pointwiseIndex_iff A T e d).mp h₁) + ((pointwiseIndex_iff A T d f).mp h₂)) } + +/-- The No Index Quotient Composition construction in `FailureOfComposition.ProgramIndices`. -/ +def NoIndexQuotientComposition (A : Arithmetization) (T : ArithmeticTheory) [𝐏𝐀 ≼ T] : Prop := + ¬∃ C : Quotient (indexSetoid A T) → Quotient (indexSetoid A T) → Quotient (indexSetoid A T), + ∀ e d, + C (Quotient.mk (indexSetoid A T) e) (Quotient.mk (indexSetoid A T) d) = + Quotient.mk (indexSetoid A T) (A.compIndex e d) + +theorem index_noncongruence_of_graph_noncongruence (A : Arithmetization) (T : ArithmeticTheory) + [𝐏𝐀 ≼ T] + (h : + ∃ F I G : Graph, + Functional F ∧ + Functional I ∧ Functional G ∧ Pointwise T F I ∧ ¬Pointwise T (comp F G) (comp I G)) : + ∃ f i g : ℕ, + PointwiseIndex A T f i ∧ ¬PointwiseIndex A T (A.compIndex f g) (A.compIndex i g) := + by + obtain ⟨F, I, G, hF, hI, hG, hFI, hn⟩ := h + obtain ⟨f, hf⟩ := A.realization F hF + obtain ⟨i, hi⟩ := A.realization I hI + obtain ⟨g, hg⟩ := A.realization G hG + have eqv := pointwise_equivalence T + have hfg : Pointwise T (A.graph (A.compIndex f g)) (comp F G) := + eqv.trans (uniform_to_pointwise T (A.composition f g)) + (uniform_to_pointwise T (uniform_comp hf hg)) + have hig : Pointwise T (A.graph (A.compIndex i g)) (comp I G) := + eqv.trans (uniform_to_pointwise T (A.composition i g)) + (uniform_to_pointwise T (uniform_comp hi hg)) + refine + ⟨f, i, g, + (pointwiseIndex_iff A T f i).mpr + (eqv.trans (uniform_to_pointwise T hf) + (eqv.trans hFI (eqv.symm (uniform_to_pointwise T hi)))), + ?_⟩ + intro hc + exact hn (eqv.trans (eqv.symm hfg) (eqv.trans ((pointwiseIndex_iff A T _ _).mp hc) hig)) + +theorem no_index_quotient_of_graph_noncongruence (A : Arithmetization) (T : ArithmeticTheory) + [𝐏𝐀 ≼ T] + (h : + ∃ F I G : Graph, + Functional F ∧ + Functional I ∧ Functional G ∧ Pointwise T F I ∧ ¬Pointwise T (comp F G) (comp I G)) : + NoIndexQuotientComposition A T := + by + obtain ⟨f, i, g, hfi, hcomp⟩ := index_noncongruence_of_graph_noncongruence A T h + exact no_quotient_composition_of_noncongruence (indexSetoid A T) A.compIndex f i g hfi hcomp + +theorem no_index_quotient_via_godel (A : Arithmetization) (T : ArithmeticTheory) [T.Δ₁] + [Consistent T] [𝐏𝐀 ≼ T] : NoIndexQuotientComposition A T := + no_index_quotient_of_graph_noncongruence A T (graph_noncongruence_via_godel T) + +/-- Independent productiveness route, with r.e. theorem codes explicit. -/ +theorem no_index_quotient_via_productiveness (A : Arithmetization) (T : ArithmeticTheory) + [Consistent T] [𝐏𝐀 ≼ T] (hT : REPred (TheoremCodes T)) : NoIndexQuotientComposition A T := + no_index_quotient_of_graph_noncongruence A T + (graph_noncongruence_of_unprovable_divergence T + (exists_true_unprovable_divergence_of_theorem_codes T hT)) + +end + +end ProgramIndices +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/ProofSearchTemplate.lean b/LeanPool/PointwiseComposition/FailureOfComposition/ProofSearchTemplate.lean new file mode 100644 index 000000000..ea0091bae --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/ProofSearchTemplate.lean @@ -0,0 +1,302 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.Meta.ClProver +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Incompleteness.StandardProvability + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +Common arithmetic proof-search obstruction. This module does not use Gödel II. +U is the theory whose proofs are searched; T is the theory of pointwise equality. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +open FFL.FirstOrder.Arithmetic.Bootstrapping FFL.Entailment + +namespace FailureOfComposition +namespace ProofSearch + +noncomputable section + +/-- The Graph construction in `FailureOfComposition.ProofSearch`. -/ +abbrev Graph := + Σ₁.Semisentence 2 + +variable (U : ArithmeticTheory) [U.Δ₁] (σ : ArithmeticSentence) + +/-- The proof Target construction in `FailureOfComposition.ProofSearch`. -/ +def proofTarget : ∆₁.Semisentence 1 := + .mkDelta (.mkSigma (“p. !(proof U).sigma p !!(⌜σ⌝)”)) (.mkPi (“p. !(proof U).pi p !!(⌜σ⌝)”)) + +/-- The not Proof Target construction in `FailureOfComposition.ProofSearch`. -/ +def notProofTarget : Σ₁.Semisentence 1 := + .mkSigma (“p. ¬!(proofTarget U σ).pi p”) + +/-- The guard construction in `FailureOfComposition.ProofSearch`. -/ +def guard : Graph := + .mkSigma (“x y. ¬!(proofTarget U σ).pi x ∧ y = x”) + +/-- The search construction in `FailureOfComposition.ProofSearch`. -/ +def search : Graph := + .mkSigma (“x p. !(proofTarget U σ).sigma p ∧ ∀ r < p, ¬!(proofTarget U σ).pi r”) + +/-- The identity construction in `FailureOfComposition.ProofSearch`. -/ +def identity : Graph := + .mkSigma (“x y. y = x”) + +/-- The empty construction in `FailureOfComposition.ProofSearch`. -/ +def empty : Graph := + .mkSigma “x y. ⊥” + +/-- The comp construction in `FailureOfComposition.ProofSearch`. -/ +def comp (F G : Graph) : Graph := + .mkSigma (“x z. ∃ y, !G.val x y ∧ !F.val y z”) + +/-- The eq At construction in `FailureOfComposition.ProofSearch`. -/ +def eqAt (F G : Graph) (n : ℕ) : ArithmeticSentence := + “∀ y, !F.val !!(n)y ↔ !G.val !!(n)y” + +/-- The Pointwise construction in `FailureOfComposition.ProofSearch`. -/ +def Pointwise (T : ArithmeticTheory) (F G : Graph) : Prop := + ∀ n : ℕ, T ⊢ eqAt F G n + +/-- The uniform Sentence construction in `FailureOfComposition.ProofSearch`. -/ +def uniformSentence (F G : Graph) : ArithmeticSentence := + “∀ x y, !F.val x y ↔ !G.val x y” + +/-- The Uniform construction in `FailureOfComposition.ProofSearch`. -/ +def Uniform (T : ArithmeticTheory) (F G : Graph) : Prop := + T ⊢ uniformSentence F G + +/-- The functional Sentence construction in `FailureOfComposition.ProofSearch`. -/ +def functionalSentence (F : Graph) : ArithmeticSentence := + “∀ x y z, (!F.val x y ∧ !F.val x z) → y = z” + +/-- The Functional construction in `FailureOfComposition.ProofSearch`. -/ +def Functional (F : Graph) : Prop := + 𝐏𝐀 ⊢ functionalSentence F + +section Semantics + +variable {V : Type*} [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +@[simp] +theorem proofTarget_sigma_eval (v : Fin 1 → V) : + (proofTarget U σ).sigma.val.Evalb v ↔ Proof U (v 0) (⌜σ⌝ : V) := by + simp only [proofTarget, HierarchySymbol.Semiformula.sigma_mkDelta, + HierarchySymbol.Semiformula.val_mkSigma, Semiformula.eval_substs, + HierarchySymbol.Defined.iff_delta_sigma, + Function.comp_apply, Matrix.cons_val_zero, Matrix.cons_val_one, Matrix.cons_val_fin_one, + Semiterm.val_bvar, Sentence.val_quote] + +@[simp] +theorem proofTarget_pi_eval (v : Fin 1 → V) : + (proofTarget U σ).pi.val.Evalb v ↔ Proof U (v 0) (⌜σ⌝ : V) := by + simp only [proofTarget, HierarchySymbol.Semiformula.pi_mkDelta, + HierarchySymbol.Semiformula.val_mkPi, Semiformula.eval_substs, + HierarchySymbol.Defined.iff_delta_pi, + Function.comp_apply, Matrix.cons_val_zero, Matrix.cons_val_one, Matrix.cons_val_fin_one, + Semiterm.val_bvar, Sentence.val_quote] + +@[simp] +theorem notProofTarget_eval (v : Fin 1 → V) : + (notProofTarget U σ).val.Evalb v ↔ ¬Proof U (v 0) (⌜σ⌝ : V) := by simp [notProofTarget] + +@[simp] +theorem guard_eval (v : Fin 2 → V) : + (guard U σ).val.Evalb v ↔ ¬Proof U (v 0) (⌜σ⌝ : V) ∧ v 1 = v 0 := by simp [guard] + +@[simp] +theorem search_eval (v : Fin 2 → V) : + (search U σ).val.Evalb v ↔ Proof U (v 1) (⌜σ⌝ : V) ∧ ∀ r < v 1, ¬Proof U r (⌜σ⌝ : V) := by + simp [search] + +omit [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] in +@[simp] +theorem identity_eval (v : Fin 2 → V) : identity.val.Evalb v ↔ v 1 = v 0 := by simp [identity] + +omit [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] in +@[simp] +theorem empty_eval (v : Fin 2 → V) : empty.val.Evalb v ↔ False := by simp [empty] + +omit [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] in +@[simp] +theorem comp_eval (F G : Graph) (v : Fin 2 → V) : + (comp F G).val.Evalb v ↔ ∃ y : V, G.val.Evalb ![v 0, y] ∧ F.val.Evalb ![y, v 1] := by + simp [comp] + +@[simp] +theorem eqAt_eval (F G : Graph) (n : ℕ) : + (eqAt F G n).Evalb (M := V) ![] ↔ + ∀ y : V, F.val.Evalb ![(n : V), y] ↔ G.val.Evalb ![(n : V), y] := + by simp [eqAt, numeral_eq_natCast] + +omit [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] in +@[simp] +theorem uniformSentence_eval (F G : Graph) : + (uniformSentence F G).Evalb (M := V) ![] ↔ + ∀ x y : V, F.val.Evalb ![x, y] ↔ G.val.Evalb ![x, y] := + by simp [uniformSentence] + +omit [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] in +@[simp] +theorem functionalSentence_eval (F : Graph) : + (functionalSentence F).Evalb (M := V) ![] ↔ + ∀ x y z : V, F.val.Evalb ![x, y] → F.val.Evalb ![x, z] → y = z := + by simp [functionalSentence] + +end Semantics + +/-- U does not prove σ, so PA proves every fixed negative proof check. -/ +theorem numeral_negative (hσ : U ⊬ σ) (n : ℕ) : 𝐏𝐀 ⊢ (notProofTarget U σ).val/[n] := + by + apply sigma_one_completeness (by simp [notProofTarget]) + simp only [models_iff, Semiformula.eval_substs] + simp only [notProofTarget_eval] + intro h + exact hσ (Bootstrapping.Provable.sound ⟨n, by simpa using h⟩) + +/-- An internal bridge for this exact named proof predicate. -/ +theorem universal_negative_bridge : + 𝐏𝐀 ⊢ (“(∀ p, ¬!(proofTarget U σ).sigma p) ↔ ¬!(provabilityPred U σ)”) := + by + apply complete.{0} 𝐏𝐀 + intro V _ _ + have : V↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + simp [models_iff, provabilityPred, Bootstrapping.Provable] + +theorem guard_functional : Functional (guard U σ) := + by + apply complete.{0} 𝐏𝐀 + intro V _ _ + have : V↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + rw [models_iff, functionalSentence_eval] + intro x y z hy hz + exact (guard_eval U σ _).mp hy |>.2 |>.trans ((guard_eval U σ _).mp hz).2.symm + +theorem identity_functional : Functional identity := + by + apply complete.{0} 𝐏𝐀 + intro V _ _ + have : V↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + simp [models_iff] + +theorem search_functional : Functional (search U σ) := + by + apply complete.{0} 𝐏𝐀 + intro V _ _ + have : V↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + rw [models_iff, functionalSentence_eval] + intro x y z hy hz + rw [search_eval] at hy hz + rcases lt_trichotomy y z with h | h | h + · exact False.elim (hz.2 y h hy.1) + · exact h + · exact False.elim (hy.2 z h hz.1) + +theorem guard_pointwise_identity (T : ArithmeticTheory) [𝐏𝐀 ≼ T] (hσ : U ⊬ σ) : + Pointwise T (guard U σ) identity := by + intro n + have h : 𝐏𝐀 ⊢ (notProofTarget U σ).val/[n] ⇒ₗ eqAt (guard U σ) identity n := + by + apply complete.{0} 𝐏𝐀 + intro V _ _ + simp [models_iff, notProofTarget, eqAt, guard, identity, Semiformula.eval_substs] + exact WeakerThan.pbl (Entailment.mdp h (numeral_negative U σ hσ n)) + +theorem guard_search_empty : Uniform 𝐏𝐀 (comp (guard U σ) (search U σ)) empty := + by + apply complete.{0} 𝐏𝐀 + intro V _ _ + have : V↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + simp only [models_iff, uniformSentence_eval, Nat.succ_eq_add_one, Nat.reduceAdd, comp_eval, + Fin.isValue, Matrix.cons_val_zero, search_eval, Matrix.cons_val_one, Fin.Fin1.eq_one, + Matrix.cons_val_fin_one, guard_eval, exists_eq_right_right', empty_eval, iff_false, not_and, + not_not, and_imp, forall_const] + intro y hy _ + exact hy + +theorem identity_comp (G : Graph) : Uniform 𝐏𝐀 (comp identity G) G := + by + apply complete.{0} 𝐏𝐀 + intro V _ _ + have : V↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + simp [models_iff] + +theorem search_empty_implies_absence : 𝐏𝐀 ⊢ eqAt (search U σ) empty 0 ⇒ₗ ∼provabilityPred U σ := + by + apply complete.{0} 𝐏𝐀 + intro V _ _ + have : V↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + simp only [provabilityPred, Semantics.Imp.models_imply, models_iff, eqAt_eval, + Nat.succ_eq_add_one, Nat.reduceAdd, Nat.cast_zero, search_eval, Fin.isValue, + Matrix.cons_val_one, Fin.Fin1.eq_one, Matrix.cons_val_fin_one, empty_eval, iff_false, + not_and, not_forall, not_not, Semantics.Not.models_not, Semiformula.eval_substs, + Matrix.comp₁, Sentence.val_quote, HierarchySymbol.Defined.iff, Bootstrapping.Provable, + not_exists] + intro h p hp + obtain ⟨q, hq, hmin⟩ := + InductionOnHierarchy.least_number_sigma ∆ 1 (P := fun p : V => Proof U p (⌜σ⌝ : V)) + (by definability) hp + obtain ⟨r, hr, hpr⟩ := h q hq + exact hmin r hr hpr + +theorem composites_not_pointwise_equal (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (hAbs : T ⊬ ∼provabilityPred U σ) : + ¬Pointwise T (comp (guard U σ) (search U σ)) (comp identity (search U σ)) := + by + intro h + have himp : + 𝐏𝐀 ⊢ + eqAt (comp (guard U σ) (search U σ)) (comp identity (search U σ)) 0 ⇒ₗ + eqAt (search U σ) empty 0 := + by + apply complete.{0} 𝐏𝐀 + intro V _ _ + have : V↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + simp only [Semantics.Imp.models_imply, models_iff, eqAt_eval, Nat.succ_eq_add_one, + Nat.reduceAdd, Nat.cast_zero, comp_eval, Fin.isValue, Matrix.cons_val_zero, search_eval, + Matrix.cons_val_one, Fin.Fin1.eq_one, Matrix.cons_val_fin_one, guard_eval, + exists_eq_right_right', identity_eval, exists_eq_right', and_iff_left_iff_imp, and_imp, + empty_eval, iff_false, not_and, not_forall, not_not] + intro h y hy + by_contra hn + have hmin : ∀ r < y, ¬Proof U r (⌜σ⌝ : V) := by simpa using hn + exact h y hy hmin hy + exact + hAbs + (Entailment.mdp (WeakerThan.pbl (search_empty_implies_absence U σ)) + (Entailment.mdp (WeakerThan.pbl himp) (h 0))) + +theorem functional_graph_noncongruence (T : ArithmeticTheory) [𝐏𝐀 ≼ T] (hσ : U ⊬ σ) + (hAbs : T ⊬ ∼provabilityPred U σ) : + ∃ F I G : Graph, + Functional F ∧ + Functional I ∧ Functional G ∧ Pointwise T F I ∧ ¬Pointwise T (comp F G) (comp I G) := + by + exact + ⟨guard U σ, identity, search U σ, guard_functional U σ, identity_functional, + search_functional U σ, guard_pointwise_identity U σ T hσ, + composites_not_pointwise_equal U σ T hAbs⟩ + +end + +end ProofSearch +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/QuotientComposition.lean b/LeanPool/PointwiseComposition/FailureOfComposition/QuotientComposition.lean new file mode 100644 index 000000000..2093dde3e --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/QuotientComposition.lean @@ -0,0 +1,54 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.QuotientObstruction + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +Composition on program quotients and its obstruction. +-/ + +@[expose] public section + +namespace FailureOfComposition + +universe u + +/-- A binary operation descends to a quotient exactly when it preserves the +equivalence relation in both arguments. -/ +theorem quotient_composition_exists_iff {A : Type u} (s : Setoid A) (comp : A → A → A) : + (∃ C : Quotient s → Quotient s → Quotient s, + ∀ a b, C (Quotient.mk s a) (Quotient.mk s b) = Quotient.mk s (comp a b)) ↔ + (∀ a a' b b', s.r a a' → s.r b b' → s.r (comp a b) (comp a' b')) := + by + constructor + · rintro ⟨C, hC⟩ a a' b b' ha hb + apply Quotient.exact + calc + Quotient.mk s (comp a b) = C (Quotient.mk s a) (Quotient.mk s b) := (hC a b).symm + _ = C (Quotient.mk s a') (Quotient.mk s b') := by + rw [Quotient.sound ha, Quotient.sound hb] + _ = Quotient.mk s (comp a' b') := hC a' b' + · intro h + refine + ⟨Quotient.lift₂ (fun a b => Quotient.mk s (comp a b)) + (fun a b a' b' ha hb => Quotient.sound (h a a' b b' ha hb)), + ?_⟩ + intro a b + rfl + +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/QuotientObstruction.lean b/LeanPool/PointwiseComposition/FailureOfComposition/QuotientObstruction.lean new file mode 100644 index 000000000..22243f84c --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/QuotientObstruction.lean @@ -0,0 +1,76 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import Mathlib.Init + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +The algebraic consequence of the four witness properties in v36. +This file alone makes no assertion about arithmetic or program indices. +-/ + +@[expose] public section + +namespace FailureOfComposition + +universe u + +theorem no_quotient_composition_of_noncongruence {A : Type u} (s : Setoid A) (comp : A → A → A) + (f i g : A) (hfi : s.r f i) (hcomp : ¬s.r (comp f g) (comp i g)) : + ¬∃ C : Quotient s → Quotient s → Quotient s, + ∀ a b, C (Quotient.mk s a) (Quotient.mk s b) = Quotient.mk s (comp a b) := + by + rintro ⟨C, hC⟩ + apply hcomp + apply Quotient.exact + calc + Quotient.mk s (comp f g) = C (Quotient.mk s f) (Quotient.mk s g) := (hC f g).symm + _ = C (Quotient.mk s i) (Quotient.mk s g) := by rw [Quotient.sound hfi] + _ = Quotient.mk s (comp i g) := hC i g + +theorem no_quotient_composition {A : Type u} (s : Setoid A) (comp : A → A → A) (f i g z : A) + (hfi : s.r f i) (hfg : s.r (comp f g) z) (hig : s.r (comp i g) g) (hgz : ¬s.r g z) : + ¬∃ C : Quotient s → Quotient s → Quotient s, + ∀ a b, C (Quotient.mk s a) (Quotient.mk s b) = Quotient.mk s (comp a b) := + by + rintro ⟨C, hC⟩ + apply hgz + apply Quotient.exact + calc + Quotient.mk s g = Quotient.mk s (comp i g) := (Quotient.sound hig).symm + _ = C (Quotient.mk s i) (Quotient.mk s g) := (hC i g).symm + _ = C (Quotient.mk s f) (Quotient.mk s g) := by rw [Quotient.sound hfi] + _ = Quotient.mk s (comp f g) := (hC f g) + _ = Quotient.mk s z := Quotient.sound hfg + +/-- The Weakly Total construction in `FailureOfComposition`. -/ +def WeaklyTotal {A : Type u} (s : Setoid A) (comp : A → A → A) (z e : A) : Prop := + ∀ d, s.r (comp e d) z → s.r d z + +theorem weaklyTotal_identity {A : Type u} (s : Setoid A) (comp : A → A → A) (i z : A) + (hi : ∀ d, s.r (comp i d) d) : WeaklyTotal s comp z i := + by + intro d hd + exact s.trans (s.symm (hi d)) hd + +theorem not_weaklyTotal_guard {A : Type u} (s : Setoid A) (comp : A → A → A) (f g z : A) + (hfg : s.r (comp f g) z) (hgz : ¬s.r g z) : ¬WeaklyTotal s comp z f := + by + intro hf + exact hgz (hf g hfg) + +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/RangeAssignment.lean b/LeanPool/PointwiseComposition/FailureOfComposition/RangeAssignment.lean new file mode 100644 index 000000000..e99c00725 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/RangeAssignment.lean @@ -0,0 +1,161 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteIndexObstruction +public import LeanPool.PointwiseComposition.FailureOfComposition.SigmaOneRealization +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteAdequacy + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +The range partial identity of a Sigma-one graph and its realization by an index +of the fixed evaluator. The defining range equation holds in every PA model. +PA-uniformly equivalent choices of realizing indices are pointwise equivalent +over every PA extension. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic FFL.Entailment + +namespace FailureOfComposition +namespace ConcreteIndices + +open ProofSearch ConcreteEvaluator ProgramIndices + +/-- The partial identity on the range of a Sigma-one graph. -/ +def rangeOfGraph (F : Graph) : Graph := + .mkSigma (“r w. r = w ∧ ∃ x, !F.val x r”) + +@[simp] +theorem rangeOfGraph_eval {M : Type*} [ORingStructure M] (F : Graph) (v : Fin 2 → M) : + (rangeOfGraph F).val.Evalb v ↔ v 0 = v 1 ∧ ∃ x : M, F.val.Evalb ![x, v 0] := by + simp [rangeOfGraph] + +/-- Range partial identities are PA-provably functional, even if the source +graph has not been assumed functional. -/ +theorem rangeOfGraph_functional (F : Graph) : Functional (rangeOfGraph F) := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + rw [models_iff, functionalSentence_eval] + intro x y z hy hz + exact ((rangeOfGraph_eval F _).mp hy).1.symm.trans ((rangeOfGraph_eval F _).mp hz).1 + +/-- PA-uniform graph equality is preserved by taking the range partial identity. -/ +theorem uniform_rangeOfGraph {F G : Graph} (h : Uniform 𝐏𝐀 F G) : + Uniform 𝐏𝐀 (rangeOfGraph F) (rangeOfGraph G) := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + have heq := consequence_iff.mp (Theory.Proof.sound h) M inferInstance + simp only [models_iff, uniformSentence_eval] at heq ⊢ + intro r w + simp only [rangeOfGraph_eval, Matrix.cons_val_zero, Matrix.cons_val_one] + exact and_congr_right fun _ => exists_congr fun x => heq x r + +/-- The range partial identity of a program in the fixed evaluator. -/ +def rangeGraph (e : ℕ) : Graph := + rangeOfGraph (eventualGraph e) + +@[simp] +theorem rangeGraph_eval {M : Type*} [ORingStructure M] (e : ℕ) (v : Fin 2 → M) : + (rangeGraph e).val.Evalb v ↔ v 0 = v 1 ∧ ∃ x : M, (eventualGraph e).val.Evalb ![x, v 0] := + rangeOfGraph_eval (eventualGraph e) v + +theorem rangeGraph_functional (e : ℕ) : Functional (rangeGraph e) := + rangeOfGraph_functional (eventualGraph e) + +/-- Choose a range program using the proved Sigma-one graph realization theorem. -/ +noncomputable def rangeIndex (e : ℕ) : ℕ := + Classical.choose (SigmaOneRealization.realize_graph (rangeGraph e) (rangeGraph_functional e)) + +theorem rangeIndex_realizes (e : ℕ) : + Uniform 𝐏𝐀 (eventualGraph (rangeIndex e)) (rangeGraph e) := + Classical.choose_spec + (SigmaOneRealization.realize_graph (rangeGraph e) (rangeGraph_functional e)) + +/-- The selected range index satisfies the defining equation in every PA model. -/ +theorem rangeIndex_graph_equation {M : Type*} [ORingStructure M] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] (e : ℕ) + (r w : M) : + (eventualGraph (rangeIndex e)).val.Evalb ![r, w] ↔ + r = w ∧ ∃ x : M, (eventualGraph e).val.Evalb ![x, r] := + by + have h := consequence_iff.mp (Theory.Proof.sound (rangeIndex_realizes e)) M inferInstance + simp only [models_iff, uniformSentence_eval] at h + exact (h r w).trans (rangeGraph_eval e _) + +/-- In the standard model this is the partial identity on the program's range. -/ +theorem rangeIndex_eval (e r w : ℕ) : + w ∈ Kleene.eval (rangeIndex e) r ↔ r = w ∧ ∃ x : ℕ, r ∈ Kleene.eval e x := + by + rw [← eventualGraph_adequate] + simpa only [eventualGraph_adequate] using rangeIndex_graph_equation e r w + +/-- A PA-uniform description of a source graph transports to its selected range. -/ +theorem rangeIndex_of_uniform {e : ℕ} {F : Graph} (h : Uniform 𝐏𝐀 (eventualGraph e) F) : + Uniform 𝐏𝐀 (eventualGraph (rangeIndex e)) (rangeOfGraph F) := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + have heq := consequence_iff.mp (Theory.Proof.sound h) M inferInstance + simp only [models_iff, uniformSentence_eval] at heq ⊢ + intro r w + rw [rangeIndex_graph_equation, rangeOfGraph_eval] + simp only [Matrix.cons_val_zero, Matrix.cons_val_one] + exact and_congr_right fun _ => exists_congr fun x => heq x r + +/-- The empty graph has empty range in PA. -/ +theorem rangeOfGraph_empty : Uniform 𝐏𝐀 (rangeOfGraph empty) empty := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + simp [models_iff, uniformSentence_eval] + +/-- The selected range of the concrete empty program is uniformly empty in PA. -/ +theorem rangeIndex_empty : + Uniform 𝐏𝐀 (eventualGraph (rangeIndex ConcreteEmptyGraph.concreteEmptyIndex)) empty := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + have hempty := consequence_iff.mp (Theory.Proof.sound eventualGraph_empty) M inferInstance + simp only [models_iff, uniformSentence_eval, empty_eval] at hempty ⊢ + intro r w + rw [rangeIndex_graph_equation] + simp only [hempty, exists_false, and_false] + +/-- Any two indices realizing the same range graph are PA-uniformly equivalent. -/ +theorem rangeIndex_realization_unique {e r s : ℕ} + (hr : Uniform 𝐏𝐀 (eventualGraph r) (rangeGraph e)) + (hs : Uniform 𝐏𝐀 (eventualGraph s) (rangeGraph e)) : + Uniform 𝐏𝐀 (eventualGraph r) (eventualGraph s) := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + have hr' := consequence_iff.mp (Theory.Proof.sound hr) M inferInstance + have hs' := consequence_iff.mp (Theory.Proof.sound hs) M inferInstance + simp only [models_iff, uniformSentence_eval] at hr' hs' ⊢ + exact fun x y => (hr' x y).trans (hs' x y).symm + +/-- Replacing the selected range index by any PA-uniform realization leaves its +pointwise class unchanged over every PA extension. -/ +theorem rangeIndex_choice_independent (T : ArithmeticTheory) [𝐏𝐀 ≼ T] {e r : ℕ} + (hr : Uniform 𝐏𝐀 (eventualGraph r) (rangeGraph e)) : PointwiseIndex T r (rangeIndex e) := + (pointwiseIndex_iff T r (rangeIndex e)).mpr + (uniform_to_pointwise T (rangeIndex_realization_unique hr (rangeIndex_realizes e))) + +end ConcreteIndices +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/RangeGodel.lean b/LeanPool/PointwiseComposition/FailureOfComposition/RangeGodel.lean new file mode 100644 index 000000000..a71b336e7 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/RangeGodel.lean @@ -0,0 +1,156 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.GodelGraph +public import LeanPool.PointwiseComposition.FailureOfComposition.CraigPresentation +public import LeanPool.PointwiseComposition.FailureOfComposition.RangeWitness + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +The manuscript's range obstruction via Gödel's second incompleteness theorem. +A program that outputs zero on codes of proofs of contradiction agrees +pointwise with the empty program. Its range at zero encodes the existence +of a contradiction proof. +Craig's presentation removes the Delta-one axiom-presentation hypothesis. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic FFL.Entailment + +open CategoricalRiceShapiro.PartialRecursive + +namespace FailureOfComposition +namespace ConcreteIndices + +open ConcreteEmptyGraph + +/-- The positive proof-of-contradiction predicate of the chosen presentation. -/ +noncomputable def proofBotPredicate (T : ArithmeticTheory) [T.Δ₁] : Σ₁.Semisentence 1 := + (ProofSearch.proofTarget T ⊥).sigma + +/-- Consistency refutes each fixed proof code in PA, including the Sigma-one form. -/ +theorem proofBotPredicate_numeral_refutation (T : ArithmeticTheory) [T.Δ₁] [Consistent T] + (n : ℕ) : 𝐏𝐀 ⊢ ∼(proofBotPredicate T).val/[n] := + by + have h : 𝐏𝐀 ⊢ (ProofSearch.notProofTarget T ⊥).val/[n] ⇒ₗ ∼(proofBotPredicate T).val/[n] := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + have : M↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + simp [models_iff, Semiformula.eval_substs, proofBotPredicate] + exact Entailment.mdp h (numeral_nonproof_of_consistency T n) + +/-- Universal absence of contradiction proofs would establish the theory's +own consistency, which Gödel's second incompleteness theorem excludes. -/ +theorem proofBotPredicate_absence_unprovable (T : ArithmeticTheory) [T.Δ₁] [𝐏𝐀 ≼ T] + [Consistent T] : T ⊬ absenceSentence (proofBotPredicate T) := + by + have : 𝐈Σ₁ ≼ T := WeakerThan.trans (𝓣 := 𝐏𝐀) inferInstance inferInstance + have hb : 𝐏𝐀 ⊢ absenceSentence (proofBotPredicate T) ⇔ₗ T.consistent.val := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + have hBridge := + consequence_iff.mp (Theory.Proof.sound (proofBot_consistency_bridge T)) M inferInstance + simpa [models_iff, absenceSentence, proofBotPredicate] using hBridge + intro h + apply consistent_unprovable T + have hbT : T ⊢ absenceSentence (proofBotPredicate T) ⇔ₗ T.consistent.val := WeakerThan.pbl hb + cl_prover[h, hbT] + +/-- The manuscript's zero-output proof probe is pointwise empty, but its +range program is not pointwise equal to the empty program's range. -/ +theorem range_counterexample_via_godel (T : ArithmeticTheory) [T.Δ₁] [𝐏𝐀 ≼ T] [Consistent T] : + PointwiseIndex T (probeIndex (proofBotPredicate T)) concreteEmptyIndex ∧ + ¬PointwiseIndex T (rangeIndex (probeIndex (proofBotPredicate T))) + (rangeIndex concreteEmptyIndex) := + range_counterexample_of_instance_refutations T (proofBotPredicate T) + (proofBotPredicate_numeral_refutation T) (proofBotPredicate_absence_unprovable T) + +/-- A quotient range operation would contradict the concrete Gödel-II witnesses. -/ +theorem no_index_quotient_range_via_godel (T : ArithmeticTheory) [T.Δ₁] [𝐏𝐀 ≼ T] + [Consistent T] : NoIndexQuotientRange T := + no_quotient_range_of_instance_refutations T (proofBotPredicate T) + (proofBotPredicate_numeral_refutation T) (proofBotPredicate_absence_unprovable T) + +/-- Deductive equivalence transports the same natural-number witnesses. The +chosen range indices depend on their programs, not on the theory presentation. -/ +theorem range_counterexample_of_equivalent_presentation (S T : ArithmeticTheory) [S.Δ₁] [𝐏𝐀 ≼ T] + [Consistent T] (hST : S ≼ T) (hTS : T ≼ S) : + ∃ u : ℕ, + PointwiseIndex T u concreteEmptyIndex ∧ + ¬PointwiseIndex T (rangeIndex u) (rangeIndex concreteEmptyIndex) := + by + let : S ≼ T := hST + let : T ≼ S := hTS + have : 𝐏𝐀 ≼ S := WeakerThan.trans (𝓣 := T) inferInstance hTS + have : Consistent S := + consistent_iff_unprovable_bot.mpr fun h => + consistent_iff_unprovable_bot.mp (inferInstance : Consistent T) (WeakerThan.pbl h) + obtain ⟨hu, hrange⟩ := range_counterexample_via_godel S + refine ⟨probeIndex (proofBotPredicate S), fun n => WeakerThan.pbl (hu n), ?_⟩ + intro h + exact hrange (fun n => WeakerThan.pbl (h n)) + +/-- For every consistent recursively axiomatized extension of PA, range +assignment fails to preserve the external pointwise relation. -/ +theorem range_counterexample_of_re_axioms (T : ArithmeticTheory) [𝐏𝐀 ≼ T] [Consistent T] + (hT : REPred (AxiomCodes T)) : + ∃ u : ℕ, + PointwiseIndex T u concreteEmptyIndex ∧ + ¬PointwiseIndex T (rangeIndex u) (rangeIndex concreteEmptyIndex) := + by + obtain ⟨S, ⟨hS⟩, hST, hTS⟩ := CraigPresentation.exists_craig_presentation T hT + let : S.Δ₁ := hS + exact range_counterexample_of_equivalent_presentation S T hST hTS + +/-- The range assignment does not descend to the quotient in the manuscript's +full recursively enumerable axiom setting. -/ +theorem no_index_quotient_range_of_re_axioms (T : ArithmeticTheory) [𝐏𝐀 ≼ T] [Consistent T] + (hT : REPred (AxiomCodes T)) : NoIndexQuotientRange T := + by + obtain ⟨u, hu, hrange⟩ := range_counterexample_of_re_axioms T hT + exact no_index_quotient_range_of_counterexample T u concreteEmptyIndex hu hrange + +/-- The explicit axiom-program enumeration used in the manuscript suffices. -/ +theorem range_counterexample_of_axiom_enumerator (T : ArithmeticTheory) [𝐏𝐀 ≼ T] [Consistent T] + (a : ℕ) (ha : ∀ n : ℕ, AxiomCodes T n ↔ ∃ x : ℕ, n ∈ Kleene.eval a x) : + ∃ u : ℕ, + PointwiseIndex T u concreteEmptyIndex ∧ + ¬PointwiseIndex T (rangeIndex u) (rangeIndex concreteEmptyIndex) := + range_counterexample_of_re_axioms T (axiom_codes_re_of_program_enumerator T a ha) + +/-- No quotient range operation exists for an explicitly enumerated axiom set. -/ +theorem no_index_quotient_range_of_axiom_enumerator (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + [Consistent T] (a : ℕ) (ha : ∀ n : ℕ, AxiomCodes T n ↔ ∃ x : ℕ, n ∈ Kleene.eval a x) : + NoIndexQuotientRange T := + no_index_quotient_range_of_re_axioms T (axiom_codes_re_of_program_enumerator T a ha) + +/-- The proof-of-contradiction probe supplies the obstruction already over PA. -/ +theorem pa_range_counterexample : + ∃ u : ℕ, + PointwiseIndex 𝐏𝐀 u concreteEmptyIndex ∧ + ¬PointwiseIndex 𝐏𝐀 (rangeIndex u) (rangeIndex concreteEmptyIndex) := + ⟨probeIndex (proofBotPredicate 𝐏𝐀), range_counterexample_via_godel 𝐏𝐀⟩ + +/-- The range assignment does not descend to the external pointwise quotient of PA. -/ +theorem pa_no_index_quotient_range : NoIndexQuotientRange 𝐏𝐀 := + no_index_quotient_range_via_godel 𝐏𝐀 + +end ConcreteIndices +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/RangeProductive.lean b/LeanPool/PointwiseComposition/FailureOfComposition/RangeProductive.lean new file mode 100644 index 000000000..fab435646 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/RangeProductive.lean @@ -0,0 +1,134 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.RangeWitness + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +An independent productive-set proof of the range-assignment obstruction. +The probe tests whether the concrete diagonal history has a positive result +at the supplied stage. Every standard stage is separately PA-refutable, while +the internally quantified absence sentence is unprovable in the ambient theory. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic FFL.Entailment + +namespace FailureOfComposition +namespace ConcreteIndices + +open ProofSearch ConcreteEvaluator HistoryWitnesses ProgramIndices ConcreteEmptyGraph + +private theorem eval_numeral_substitution {M : Type*} [ORingStructure M] [M↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + (P : ArithmeticSemisentence 1) (n : ℕ) : (P/[n]).Evalb (M := M) ![] ↔ P.Evalb ![(n : M)] := + by simp [Semiformula.eval_substs, numeral_eq_natCast] + +/-- True diagonal divergence refutes the positive-history test at each standard stage. -/ +theorem historyPositive_refutable_of_divergence (d : ℕ) + (hdiv : ¬diagonalHistoryFormula.Evalb ![d]) (n : ℕ) : + 𝐏𝐀 ⊢ ∼(historyPositiveFormula d).val/[n] := + by + have hi : 𝐏𝐀 ⊢ eqAt (guardGraph d) identity n ⇒ₗ ∼(historyPositiveFormula d).val/[n] := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + have : M↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + simp only [models_iff, LogicalConnective.HomClass.map_imply, + LogicalConnective.HomClass.map_neg, eqAt_eval] + intro he + have hg := (he (n : M)).mpr ((identity_eval _).mpr rfl) + have hzero := ((guardGraph_eval d _).mp hg).1 + have hn := (history_zero_iff_no_positive d (n : M)).mp hzero + have hP : ¬(historyPositiveFormula d).val.Evalb ![(n : M)] := by + simpa [historyPositiveFormula] using hn + exact fun hp => hP ((eval_numeral_substitution (historyPositiveFormula d).val n).mp hp) + exact Entailment.mdp hi (guard_pointwise_identity 𝐏𝐀 d hdiv n) + +/-- Absence of all positive history stages is exactly diagonal divergence in PA. -/ +theorem history_absence_iff_divergence (d : ℕ) : + 𝐏𝐀 ⊢ absenceSentence (historyPositiveFormula d) ⇔ₗ ∼diagonalHistoryFormula/[d] := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + have : M↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + simp only [models_iff, LogicalConnective.HomClass.map_iff, LogicalConnective.HomClass.map_neg, + absenceSentence_eval] + rw [diagonalHistory_iff d] + simp [historyPositiveFormula] + +theorem history_absence_unprovable (T : ArithmeticTheory) [𝐏𝐀 ≼ T] (d : ℕ) + (hnot : T ⊬ ∼diagonalHistoryFormula/[d]) : T ⊬ absenceSentence (historyPositiveFormula d) := + by + intro hp + have hi : T ⊢ absenceSentence (historyPositiveFormula d) ⇔ₗ ∼diagonalHistoryFormula/[d] := + WeakerThan.pbl (history_absence_iff_divergence d) + apply hnot + cl_prover[hi, hp] + +/-- A concrete productive divergence witness gives the required range counterexample. -/ +theorem range_counterexample_of_history_divergence (T : ArithmeticTheory) [𝐏𝐀 ≼ T] (d : ℕ) + (hdiv : ¬diagonalHistoryFormula.Evalb ![d]) (hnot : T ⊬ ∼diagonalHistoryFormula/[d]) : + PointwiseIndex T (probeIndex (historyPositiveFormula d)) concreteEmptyIndex ∧ + ¬PointwiseIndex T (rangeIndex (probeIndex (historyPositiveFormula d))) + (rangeIndex concreteEmptyIndex) := + range_counterexample_of_instance_refutations T (historyPositiveFormula d) + (historyPositive_refutable_of_divergence d hdiv) (history_absence_unprovable T d hnot) + +/-- Productiveness supplies the witness for an enumerable theorem-code set. -/ +theorem range_counterexample_via_productiveness (T : ArithmeticTheory) [𝐏𝐀 ≼ T] [Consistent T] + (hT : REPred (TheoremCodes T)) : + ∃ u : ℕ, + PointwiseIndex T u concreteEmptyIndex ∧ + ¬PointwiseIndex T (rangeIndex u) (rangeIndex concreteEmptyIndex) := + by + obtain ⟨d, hdiv, hnot⟩ := exists_true_unprovable_history_divergence_of_theorem_codes T hT + exact + ⟨probeIndex (historyPositiveFormula d), + range_counterexample_of_history_divergence T d hdiv hnot⟩ + +/-- The productive proof requires only recursively enumerable axiom codes. -/ +theorem range_counterexample_via_productiveness_of_re_axioms (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + [Consistent T] (hT : REPred (AxiomCodes T)) : + ∃ u : ℕ, + PointwiseIndex T u concreteEmptyIndex ∧ + ¬PointwiseIndex T (rangeIndex u) (rangeIndex concreteEmptyIndex) := + range_counterexample_via_productiveness T (theorem_codes_re_of_axiom_codes T hT) + +/-- The explicit program-enumerator specialization of the productive route. -/ +theorem range_counterexample_via_productiveness_of_axiom_enumerator (T : ArithmeticTheory) + [𝐏𝐀 ≼ T] [Consistent T] (a : ℕ) + (ha : ∀ n : ℕ, AxiomCodes T n ↔ ∃ x : ℕ, n ∈ Kleene.eval a x) : + ∃ u : ℕ, + PointwiseIndex T u concreteEmptyIndex ∧ + ¬PointwiseIndex T (rangeIndex u) (rangeIndex concreteEmptyIndex) := + range_counterexample_via_productiveness_of_re_axioms T + (axiom_codes_re_of_program_enumerator T a ha) + +/-- The same productive witness rules out an induced operation on the quotient. -/ +theorem no_index_quotient_range_via_productiveness_of_re_axioms (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + [Consistent T] (hT : REPred (AxiomCodes T)) : NoIndexQuotientRange T := + by + obtain ⟨d, hdiv, hnot⟩ := + exists_true_unprovable_history_divergence_of_theorem_codes T + (theorem_codes_re_of_axiom_codes T hT) + exact + no_quotient_range_of_instance_refutations T (historyPositiveFormula d) + (historyPositive_refutable_of_divergence d hdiv) (history_absence_unprovable T d hnot) + +end ConcreteIndices +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/RangeWitness.lean b/LeanPool/PointwiseComposition/FailureOfComposition/RangeWitness.lean new file mode 100644 index 000000000..22972ba48 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/RangeWitness.lean @@ -0,0 +1,182 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.RangeAssignment + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +A zero-output probe separates external pointwise equality from equality of +range partial identities. Every standard input may have its own PA proof of +divergence, while the range at input zero tests an internal existential over +all possible probe inputs. No passage from these individual proofs to a +universal proof is assumed. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic FFL.Entailment + +namespace FailureOfComposition +namespace ConcreteIndices + +open ProofSearch ConcreteEvaluator ProgramIndices ConcreteEmptyGraph + +/-- The zero-output probe for a Sigma-one predicate on possible witnesses. -/ +def probeGraph (P : Σ₁.Semisentence 1) : Graph := + .mkSigma (“p y. !P.val p ∧ y = 0”) + +@[simp] +theorem probeGraph_eval {M : Type*} [ORingStructure M] (P : Σ₁.Semisentence 1) (v : Fin 2 → M) : + (probeGraph P).val.Evalb v ↔ P.val.Evalb ![v 0] ∧ v 1 = 0 := by simp [probeGraph] + +/-- A probe has at most one output, whether or not its predicate holds. -/ +theorem probeGraph_functional (P : Σ₁.Semisentence 1) : Functional (probeGraph P) := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + rw [models_iff, functionalSentence_eval] + intro x y z hy hz + exact ((probeGraph_eval P _).mp hy).2.trans ((probeGraph_eval P _).mp hz).2.symm + +/-- A concrete program index supplied by the proved Sigma-one realization theorem. -/ +noncomputable def probeIndex (P : Σ₁.Semisentence 1) : ℕ := + Classical.choose (SigmaOneRealization.realize_graph (probeGraph P) (probeGraph_functional P)) + +theorem probeIndex_realizes (P : Σ₁.Semisentence 1) : + Uniform 𝐏𝐀 (eventualGraph (probeIndex P)) (probeGraph P) := + Classical.choose_spec + (SigmaOneRealization.realize_graph (probeGraph P) (probeGraph_functional P)) + +/-- The equation holds for all inputs of every PA model, including nonstandard ones. -/ +theorem probeIndex_graph_equation {M : Type*} [ORingStructure M] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] + (P : Σ₁.Semisentence 1) (x y : M) : + (eventualGraph (probeIndex P)).val.Evalb ![x, y] ↔ P.val.Evalb ![x] ∧ y = 0 := + by + have h := consequence_iff.mp (Theory.Proof.sound (probeIndex_realizes P)) M inferInstance + simp only [models_iff, uniformSentence_eval] at h + exact (h x y).trans (probeGraph_eval P _) + +/-- The internal assertion that the probe predicate has no witness. -/ +def absenceSentence (P : Σ₁.Semisentence 1) : ArithmeticSentence := + “∀ p, ¬!P.val p” + +@[simp] +theorem absenceSentence_eval {M : Type*} [ORingStructure M] (P : Σ₁.Semisentence 1) : + (absenceSentence P).Evalb (M := M) ![] ↔ ∀ p : M, ¬P.val.Evalb ![p] := by + simp [absenceSentence] + +/-- Separate numeralwise refutations suffice for external pointwise equality. -/ +theorem probeGraph_pointwise_empty (T : ArithmeticTheory) [𝐏𝐀 ≼ T] (P : Σ₁.Semisentence 1) + (href : ∀ n : ℕ, 𝐏𝐀 ⊢ ∼P.val/[n]) : Pointwise T (probeGraph P) empty := + by + intro n + have h : 𝐏𝐀 ⊢ ∼P.val/[n] ⇒ₗ eqAt (probeGraph P) empty n := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + simp [models_iff, eqAt, probeGraph, empty, Semiformula.eval_substs] + exact WeakerThan.pbl (Entailment.mdp h (href n)) + +theorem probeIndex_pointwise_empty (T : ArithmeticTheory) [𝐏𝐀 ≼ T] (P : Σ₁.Semisentence 1) + (href : ∀ n : ℕ, 𝐏𝐀 ⊢ ∼P.val/[n]) : PointwiseIndex T (probeIndex P) concreteEmptyIndex := + by + apply (pointwiseIndex_iff T _ _).mpr + have eqv := pointwise_equivalence T + exact + eqv.trans (uniform_to_pointwise T (probeIndex_realizes P)) + (eqv.trans (probeGraph_pointwise_empty T P href) + (eqv.symm (uniform_to_pointwise T eventualGraph_empty))) + +/-- The range at zero records the internal existential over all probe inputs. -/ +theorem range_probe_at_zero {M : Type*} [ORingStructure M] (P : Σ₁.Semisentence 1) : + (rangeOfGraph (probeGraph P)).val.Evalb ![(0 : M), 0] ↔ ∃ p : M, P.val.Evalb ![p] := by + simp [rangeOfGraph_eval] + +/-- Equality of the probe's range with the empty graph at the one input zero +already implies the internally quantified absence sentence. -/ +theorem range_probe_empty_implies_absence (P : Σ₁.Semisentence 1) : + 𝐏𝐀 ⊢ eqAt (rangeOfGraph (probeGraph P)) empty 0 ⇒ₗ absenceSentence P := + by + apply complete.{0} 𝐏𝐀 + intro M _ _ + have : M↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + simp only [models_iff, LogicalConnective.HomClass.map_imply, eqAt_eval, absenceSentence_eval] + intro he p hp + have hzero := (range_probe_at_zero P).mpr ⟨p, hp⟩ + exact (empty_eval _).mp ((he 0).mp hzero) + +theorem range_probeIndex_not_pointwise_empty (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (P : Σ₁.Semisentence 1) (hnot : T ⊬ absenceSentence P) : + ¬PointwiseIndex T (rangeIndex (probeIndex P)) (rangeIndex concreteEmptyIndex) := + by + intro he + have eqv := pointwise_equivalence T + have hprobe : + Pointwise T (eventualGraph (rangeIndex (probeIndex P))) (rangeOfGraph (probeGraph P)) := + eqv.trans (uniform_to_pointwise T (rangeIndex_realizes (probeIndex P))) + (uniform_to_pointwise T (uniform_rangeOfGraph (probeIndex_realizes P))) + have h : Pointwise T (rangeOfGraph (probeGraph P)) empty := + eqv.trans (eqv.symm hprobe) + (eqv.trans ((pointwiseIndex_iff T _ _).mp he) (uniform_to_pointwise T rangeIndex_empty)) + exact hnot (Entailment.mdp (WeakerThan.pbl (range_probe_empty_implies_absence P)) (h 0)) + +/-- A concrete pair of equivalent program indices whose range indices differ. -/ +theorem range_counterexample_of_instance_refutations (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (P : Σ₁.Semisentence 1) (href : ∀ n : ℕ, 𝐏𝐀 ⊢ ∼P.val/[n]) (hnot : T ⊬ absenceSentence P) : + PointwiseIndex T (probeIndex P) concreteEmptyIndex ∧ + ¬PointwiseIndex T (rangeIndex (probeIndex P)) (rangeIndex concreteEmptyIndex) := + ⟨probeIndex_pointwise_empty T P href, range_probeIndex_not_pointwise_empty T P hnot⟩ + +/-- The selected range assignment has no operation on the pointwise quotient. -/ +def NoIndexQuotientRange (T : ArithmeticTheory) [𝐏𝐀 ≼ T] : Prop := + ¬∃ R : Quotient (indexSetoid T) → Quotient (indexSetoid T), + ∀ e, R (Quotient.mk (indexSetoid T) e) = Quotient.mk (indexSetoid T) (rangeIndex e) + +/-- A pair of equivalent indices with distinct range classes prevents descent. -/ +theorem no_index_quotient_range_of_counterexample (T : ArithmeticTheory) [𝐏𝐀 ≼ T] (u z : ℕ) + (huz : PointwiseIndex T u z) (hr : ¬PointwiseIndex T (rangeIndex u) (rangeIndex z)) : + NoIndexQuotientRange T := by + rintro ⟨R, hR⟩ + apply hr + apply Quotient.exact (s := indexSetoid T) + calc + Quotient.mk (indexSetoid T) (rangeIndex u) = R (Quotient.mk (indexSetoid T) u) := + (hR _).symm + _ = R (Quotient.mk (indexSetoid T) z) := by rw [Quotient.sound huz] + _ = Quotient.mk (indexSetoid T) (rangeIndex z) := hR _ + +/-- No operation on the pointwise quotient induces the chosen range assignment. -/ +theorem no_quotient_range_of_instance_refutations (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (P : Σ₁.Semisentence 1) (href : ∀ n : ℕ, 𝐏𝐀 ⊢ ∼P.val/[n]) (hnot : T ⊬ absenceSentence P) : + NoIndexQuotientRange T := + no_index_quotient_range_of_counterexample T (probeIndex P) concreteEmptyIndex + (probeIndex_pointwise_empty T P href) (range_probeIndex_not_pointwise_empty T P hnot) + +/-- Non-descent persists for every choice of PA-correct range indices. -/ +theorem no_quotient_range_of_correct_assignment (T : ArithmeticTheory) [𝐏𝐀 ≼ T] + (h : NoIndexQuotientRange T) (ρ : ℕ → ℕ) + (hρ : ∀ e, Uniform 𝐏𝐀 (eventualGraph (ρ e)) (rangeGraph e)) : + ¬∃ R : Quotient (indexSetoid T) → Quotient (indexSetoid T), + ∀ e, R (Quotient.mk (indexSetoid T) e) = Quotient.mk (indexSetoid T) (ρ e) := + by + rintro ⟨R, hR⟩ + apply h + refine ⟨R, fun e => ?_⟩ + exact (hR e).trans (Quotient.sound (rangeIndex_choice_independent T (hρ e))) + +end ConcreteIndices +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/SigmaOneGraphWitness.lean b/LeanPool/PointwiseComposition/FailureOfComposition/SigmaOneGraphWitness.lean new file mode 100644 index 000000000..90dee1419 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/SigmaOneGraphWitness.lean @@ -0,0 +1,91 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.SigmaOneSemidecisionCore +public import LeanPool.PointwiseComposition.FailureOfComposition.SigmaOneSearch + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +Extracting an output from a semidecision program for a functional arithmetic +graph. The search ranges over candidate outputs together with computation +stages, so divergent rejected candidates do not block later outputs. +-/ + +@[expose] public section + +open Encodable FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +namespace FailureOfComposition +namespace SigmaOneRealization + +open ProgramGraph ArithmeticCodeCompiler + +/-- Convert a candidate/input pair into the graph's input/output vector. -/ +def reorderProgram (c : PCode) : PCode := + .comp c (.pair .right (.pair .left .zero)) + +/-- Search the graph semidecision program and return its successful output. -/ +def graphProgram (c : PCode) : PCode := + SigmaOneSearch.candidateSearch (reorderProgram c) + +variable {M : Type*} [ORingStructure M] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + +theorem computes_reorder (c : PCode) (x y z : M) : + Computes (reorderProgram c) (pair y x) z ↔ Computes c (encodeVector ![x, y]) z := + by + rw [reorderProgram, computes_comp] + simp only [computes_pair, computes_left, computes_right, computes_zero, pi₁_pair, pi₂_pair] + constructor + · rintro ⟨w, ⟨a, b, rfl, ⟨d, e, rfl, rfl, rfl⟩, rfl⟩, h⟩ + simpa only [encodeVector, Matrix.cons_val_zero, Matrix.cons_val_succ] using h + · intro h + refine ⟨pair x (pair y 0), ⟨x, pair y 0, rfl, ⟨y, 0, rfl, rfl, rfl⟩, rfl⟩, ?_⟩ + simpa only [encodeVector, Matrix.cons_val_zero, Matrix.cons_val_succ] using h + +/-- A semidecision program for a PA-functional graph yields an actual program +whose graph PA proves uniformly equivalent to the original graph. -/ +theorem realize_of_semidecides (F : ProofSearch.Graph) (hF : ProofSearch.Functional F) + (c : PCode) (hc : Semidecides F.val c) : + ProofSearch.Uniform 𝐏𝐀 (ConcreteEvaluator.eventualGraph (encode (graphProgram c))) F := + by + apply complete.{0} 𝐏𝐀 + intro V _ _ + have : V↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + have hf : V↓[ℒₒᵣ] ⊧ ProofSearch.functionalSentence F := + consequence_iff.mp (Theory.Proof.sound hF) V inferInstance + rw [models_iff, ProofSearch.functionalSentence_eval] at hf + rw [models_iff, ProofSearch.uniformSentence_eval] + intro x y + change + Computes (SigmaOneSearch.candidateSearch (reorderProgram c)) x y ↔ + Semiformula.Evalb ![x, y] F.val + have hrel (a : V) : + Computes (reorderProgram c) (pair a x) 0 ↔ Semiformula.Evalb ![x, a] F.val := + by + rw [computes_reorder, hc V ![x, a] 0] + simp + have hu : + ∀ a b : V, + Computes (reorderProgram c) (pair a x) 0 → + Computes (reorderProgram c) (pair b x) 0 → a = b := + by + intro a b ha hb + exact hf x a b ((hrel a).mp ha) ((hrel b).mp hb) + exact (SigmaOneSearch.candidateSearch_of_functional (reorderProgram c) x y hu).trans (hrel y) + +end SigmaOneRealization +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/SigmaOneRealization.lean b/LeanPool/PointwiseComposition/FailureOfComposition/SigmaOneRealization.lean new file mode 100644 index 000000000..8e1c67944 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/SigmaOneRealization.lean @@ -0,0 +1,178 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.SigmaOneSemidecisionCore +public import LeanPool.PointwiseComposition.FailureOfComposition.ArithmeticFormulaAtoms +public import LeanPool.PointwiseComposition.FailureOfComposition.BoundedSemidecision +public import LeanPool.PointwiseComposition.FailureOfComposition.SigmaOneSearch +public import LeanPool.PointwiseComposition.FailureOfComposition.SigmaOneGraphWitness + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +Internal semidecision and program realization of Sigma-one arithmetic formulas. +Every program is constructed from concrete Mathlib program descriptions, and +every correctness assertion quantifies over PA models rather than just ℕ. +-/ + +@[expose] public section + +open Encodable FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +namespace FailureOfComposition +namespace SigmaOneRealization + +open ProgramGraph ArithmeticCodeCompiler ArithmeticFormulaAtoms BoundedSemidecision + +/-- Accept the nonzero output of a Boolean program and return zero. -/ +def truthProgram (c : PCode) : PCode := + acceptZeroProgram (.comp ConcreteEvaluator.isZeroProgram c) + +private theorem exists_nonzero_bool {M : Type*} [ORingStructure M] [M↓[ℒₒᵣ] ⊧* 𝐐] (P : Prop) : + (∃ z : M, z ≠ 0 ∧ BoolValue P z) ↔ P := + by + constructor + · rintro ⟨z, hn, ⟨hp, _⟩ | ⟨_, hz⟩⟩ + · exact hp + · exact False.elim (hn hz) + · intro hp + exact ⟨1, Arithmetic.one_ne_zero, Or.inl ⟨hp, rfl⟩⟩ + +section Semantics + +variable {M : Type*} [ORingStructure M] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + +theorem computes_truthProgram (c : PCode) (x y : M) : + Computes (truthProgram c) x y ↔ y = 0 ∧ ∃ z : M, z ≠ 0 ∧ Computes c x z := + by + rw [truthProgram, computes_acceptZero] + simp only [computes_comp, ConcreteEvaluator.computes_isZero_iff] + constructor + · rintro ⟨hy, z, hz, h⟩ + rcases h with ⟨_, hbad⟩ | ⟨hn, _⟩ + · exact False.elim (zero_ne_one hbad) + · exact ⟨hy, z, hn, hz⟩ + · rintro ⟨hy, z, hn, hz⟩ + exact ⟨hy, z, hz, Or.inr ⟨hn, trivial⟩⟩ + +end Semantics + +theorem atom_semidecides {n k : ℕ} (r : Language.ORing.Rel k) + (ts : Fin k → ArithmeticSemiterm Empty n) : + Semidecides (.rel r ts) (truthProgram (compile (atomCode r ts))) := + by + intro M _ _ _ v y + rw [computes_truthProgram] + simp only [computes_compile, atomCode_eval, exists_nonzero_bool] + +theorem negAtom_semidecides {n k : ℕ} (r : Language.ORing.Rel k) + (ts : Fin k → ArithmeticSemiterm Empty n) : + Semidecides (.nrel r ts) (truthProgram (compile (negAtomCode r ts))) := + by + intro M _ _ _ v y + rw [computes_truthProgram] + simp only [computes_compile, negAtomCode_eval, exists_nonzero_bool] + +/-- Evaluate the bound and sequentially check the formula at each smaller +candidate, retaining the encoded environment as the recursion parameter. -/ +def boundedProgram {n : ℕ} (t : ArithmeticSemiterm Empty n) (c : PCode) : PCode := + .comp (boundedAllProgram c) (.pair Nat.Partrec.Code.id (compile (termCode t))) + +theorem bounded_semidecides {n : ℕ} (t : ArithmeticSemiterm Empty n) + {φ : ArithmeticSemisentence (n + 1)} {c : PCode} (hφ : Semidecides φ c) : + Semidecides (∀¹[“#0 < !!(Rew.bShift t)”] φ) (boundedProgram t c) := + by + intro M _ _ _ v y + have hbody (k : M) : Computes c (pair k (encodeVector v)) 0 ↔ φ.Evalb (k :> v) := by + simpa only [encodeVector, Matrix.cons_val_zero, Matrix.cons_val_succ, eq_self_iff_true, + true_and] using hφ M (k :> v) 0 + have hbound : + Computes (.pair Nat.Partrec.Code.id (compile (termCode t))) (encodeVector v) + (pair (encodeVector v) (t.valb v)) := + by + apply (computes_pair _ _ _ _).mpr + refine ⟨encodeVector v, t.valb v, (computes_id _ _).mpr rfl, ?_, rfl⟩ + exact (computes_compile _ _ _).mpr ((termCode_eval t _ v).mpr rfl) + have hcomp : + Computes (boundedProgram t c) (encodeVector v) y ↔ + Computes (boundedAllProgram c) (pair (encodeVector v) (t.valb v)) y := + by + rw [boundedProgram, computes_comp] + constructor + · rintro ⟨u, hu, hc⟩ + rw [computes_unique _ _ _ _ hu hbound] at hc + exact hc + · intro hc + exact ⟨_, hbound, hc⟩ + rw [hcomp, computes_boundedAll] + simp only [hbody] + simp [FFL.FirstOrder.ball, Semiterm.valb] + +theorem or_semidecides {n : ℕ} {φ ψ : ArithmeticSemisentence n} {c d : PCode} + (hφ : Semidecides φ c) (hψ : Semidecides ψ d) : + Semidecides (φ ⋎ ψ) (SigmaOneSearch.unionProgram c d) := + by + intro M _ _ _ v y + rw [SigmaOneSearch.computes_unionProgram] + simp [hφ M v 0, hψ M v 0] + +theorem exists_semidecides {n : ℕ} {φ : ArithmeticSemisentence (n + 1)} {c : PCode} + (hφ : Semidecides φ c) : Semidecides (∃¹ φ) (SigmaOneSearch.existsProgram c) := + by + intro M _ _ _ v y + have hbody (k : M) : Computes c (pair k (encodeVector v)) 0 ↔ φ.Evalb (k :> v) := by + simpa only [encodeVector, Matrix.cons_val_zero, Matrix.cons_val_succ, eq_self_iff_true, + true_and] using hφ M (k :> v) 0 + rw [SigmaOneSearch.computes_existsProgram] + simp [hbody] + +/-- Every Sigma-one arithmetic formula has a concrete zero-valued +semidecision program whose correctness holds in PA models. -/ +theorem semidecision_exists {n : ℕ} (φ : ArithmeticSemisentence n) (hφ : Hierarchy Σ 1 φ) : + ∃ c : PCode, Semidecides φ c := + by + apply sigma₁_induction' hφ (P := fun _ φ => ∃ c : PCode, Semidecides φ c) + · intro n + exact ⟨.zero, verum_semidecides n⟩ + · intro n + exact ⟨.rfind' .succ, falsum_semidecides n⟩ + · intro n t₁ t₂ + exact ⟨_, atom_semidecides Language.ORing.Rel.eq ![t₁, t₂]⟩ + · intro n t₁ t₂ + exact ⟨_, negAtom_semidecides Language.ORing.Rel.eq ![t₁, t₂]⟩ + · intro n t₁ t₂ + exact ⟨_, atom_semidecides Language.ORing.Rel.lt ![t₁, t₂]⟩ + · intro n t₁ t₂ + exact ⟨_, negAtom_semidecides Language.ORing.Rel.lt ![t₁, t₂]⟩ + · rintro n φ ψ _ _ ⟨c, hc⟩ ⟨d, hd⟩ + exact ⟨_, and_semidecides hc hd⟩ + · rintro n φ ψ _ _ ⟨c, hc⟩ ⟨d, hd⟩ + exact ⟨_, or_semidecides hc hd⟩ + · rintro n t φ _ ⟨c, hc⟩ + exact ⟨_, bounded_semidecides t hc⟩ + · rintro n φ _ ⟨c, hc⟩ + exact ⟨_, exists_semidecides hc⟩ + +/-- Every PA-provably functional Sigma-one graph has a program in the fixed +Mathlib numbering whose graph PA proves uniformly equivalent to it. -/ +theorem realize_graph (F : ProofSearch.Graph) (hF : ProofSearch.Functional F) : + ∃ e : ℕ, ProofSearch.Uniform 𝐏𝐀 (ConcreteEvaluator.eventualGraph e) F := + by + obtain ⟨c, hc⟩ := semidecision_exists F.val F.sigma_prop + exact ⟨encode (graphProgram c), realize_of_semidecides F hF c hc⟩ + +end SigmaOneRealization +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/SigmaOneSearch.lean b/LeanPool/PointwiseComposition/FailureOfComposition/SigmaOneSearch.lean new file mode 100644 index 000000000..715281a09 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/SigmaOneSearch.lean @@ -0,0 +1,363 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.ArithmeticCodeCompiler +public import LeanPool.PointwiseComposition.FailureOfComposition.HistoryWitnesses + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +Fair search and disjunction for the concrete program numbering. The searched +arithmetic tests are total history-evaluator computations, so a divergent +candidate does not prevent the search from reaching a different candidate. +All graph laws hold at arbitrary elements of every PA model. +-/ + +@[expose] public section + +open Encodable FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +open scoped FFL.FirstOrder.Arithmetic + +open Nat.ArithPart₁ + +open CategoricalRiceShapiro.ArithmeticCode CategoricalRiceShapiro.Evaluator + +namespace FailureOfComposition +namespace SigmaOneSearch + +open ProgramGraph ArithmeticCodeCompiler ConcreteEvaluator + +/-- The history At construction in `FailureOfComposition.SigmaOneSearch`. -/ +def historyAt {n : ℕ} (c : PCode) (s x : Code n) : Code n := + codeHistoryEvaluator.comp ![s, codeConst (encode c), x] + +/-- The success At construction in `FailureOfComposition.SigmaOneSearch`. -/ +def successAt {n : ℕ} (c : PCode) (s x : Code n) : Code n := + codeEq (historyAt c s x) (Code.one n) + +/-- The exists Test construction in `FailureOfComposition.SigmaOneSearch`. -/ +def existsTest (c : PCode) : Code 2 := + successAt c (codeUnpair₁ (Code.proj 0)) (codePair (codeUnpair₂ (Code.proj 0)) (Code.proj 1)) + +/-- The union Test construction in `FailureOfComposition.SigmaOneSearch`. -/ +def unionTest (c d : PCode) : Code 2 := + codeOr (successAt c (Code.proj 0) (Code.proj 1)) (successAt d (Code.proj 0) (Code.proj 1)) + +/-- Return the candidate from the least successful stage/candidate pair. -/ +def candidateSearch (c : PCode) : PCode := + unaryCompile (codeBind (codeRfindPos (existsTest c)) (codeUnpair₂ (Code.proj 0))) + +/-- Existential projection, with output zero on its domain. -/ +def existsProgram (c : PCode) : PCode := + .comp .zero (candidateSearch c) + +/-- Disjunction, with output zero if either program returns zero. -/ +def unionProgram (c d : PCode) : PCode := + unaryCompile (codeBind (codeRfindPos (unionTest c d)) (Code.zero 2)) + +variable {M : Type*} [ORingStructure M] + +private theorem historyAt_eval [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] {n : ℕ} (c : PCode) (ds dx : Code n) + (s x z : M) (v : Fin n → M) (hs : Semiformula.Evalb (s :> v) (code ds)) + (hx : Semiformula.Evalb (x :> v) (code dx)) : + Semiformula.Evalb (z :> v) (code (historyAt c ds dx)) ↔ + Semiformula.Evalb ![z, s, (encode c : M), x] (code codeHistoryEvaluator) := + by + rw [historyAt, eval_comp_iff] + constructor + · rintro ⟨w, hw, hi⟩ + have h0 := eval_unique (hi 0) hs + have h1 := eval_unique (hi 1) (eval_codeConst (encode c) v) + have h2 := eval_unique (hi 2) hx + have he : w = ![s, (encode c : M), x] := by ext i; fin_cases i <;> simp_all + simpa only [he] using hw + · intro h + refine ⟨![s, (encode c : M), x], h, ?_⟩ + intro i + fin_cases i + · exact hs + · exact eval_codeConst (encode c) v + · exact hx + +private theorem computes_iff_stage [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (c : PCode) (x y : M) : + Computes c x y ↔ + ∃ s : M, + Semiformula.Evalb ![s, (encode c : M), x, y] + (evalnCertificateFormula : ArithmeticSemisentence 4) := + by + simp only [ProgramGraph.Computes, eventualGraph_eval, numeral_eq_natCast_app, + Matrix.cons_val_zero, Matrix.cons_val_one] + +variable [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + +private theorem successAt_eval {n : ℕ} (c : PCode) (ds dx : Code n) (s x z : M) (v : Fin n → M) + (hs : Semiformula.Evalb (s :> v) (code ds)) (hx : Semiformula.Evalb (x :> v) (code dx)) : + Semiformula.Evalb (z :> v) (code (successAt c ds dx)) ↔ + ((Semiformula.Evalb ![s, (encode c : M), x, 0] + (evalnCertificateFormula : ArithmeticSemisentence 4) ∧ + z = 1) ∨ + (¬Semiformula.Evalb ![s, (encode c : M), x, 0] + (evalnCertificateFormula : ArithmeticSemisentence 4) ∧ + z = 0)) := + by + have hh := historyAt_eval c ds dx s x (1 : M) v hs hx + have hc : + Semiformula.Evalb ((1 : M) :> v) (code (historyAt c ds dx)) ↔ + Semiformula.Evalb ![s, (encode c : M), x, 0] + (evalnCertificateFormula : ArithmeticSemisentence 4) := + by + rw [evalnCertificateFormula_eval_history_iff] + simpa only [zero_add] using hh + rw [successAt, eval_codeEq_iff] + constructor + · rintro ⟨a, b, ha, hb, hcase⟩ + have hb1 := (eval_one_iff b v).mp hb + subst b + rcases hcase with ⟨rfl, hz⟩ | ⟨ha1, hz⟩ + · exact Or.inl ⟨hc.mp ha, hz⟩ + · exact Or.inr ⟨fun h => ha1 (eval_unique ha (hc.mpr h)), hz⟩ + · intro hcase + obtain ⟨a, ha⟩ := eval_codeHistoryEvaluator_exists s (encode c : M) x + have ha' := (historyAt_eval c ds dx s x a v hs hx).mpr ha + refine ⟨a, 1, ha', (eval_one_iff 1 v).mpr rfl, ?_⟩ + rcases hcase with ⟨h, hz⟩ | ⟨h, hz⟩ + · exact Or.inl ⟨eval_unique ha' (hc.mpr h), hz⟩ + · exact Or.inr ⟨fun ha1 => h (hc.mp (by simpa only [ha1] using ha')), hz⟩ + +private theorem successAt_total {n : ℕ} (c : PCode) (ds dx : Code n) (s x : M) (v : Fin n → M) + (hs : Semiformula.Evalb (s :> v) (code ds)) (hx : Semiformula.Evalb (x :> v) (code dx)) : + ∃ z : M, Semiformula.Evalb (z :> v) (code (successAt c ds dx)) := by + classical + by_cases h : + Semiformula.Evalb ![s, (encode c : M), x, 0] + (evalnCertificateFormula : ArithmeticSemisentence 4) + · exact ⟨1, (successAt_eval c ds dx s x 1 v hs hx).mpr (Or.inl ⟨h, rfl⟩)⟩ + · exact ⟨0, (successAt_eval c ds dx s x 0 v hs hx).mpr (Or.inr ⟨h, rfl⟩)⟩ + +/-- Minimization of a total arithmetic test has a result exactly when some +candidate has a positive value. Least-number induction is internal to PA. -/ +private theorem positive_search_domain (d : Code 2) (x : M) + (htotal : ∀ a : M, ∃ z : M, Semiformula.Evalb ![z, a, x] (code d)) : + (∃ w : M, Semiformula.Evalb ![w, x] (code (codeRfindPos d))) ↔ + ∃ w z : M, 0 < z ∧ Semiformula.Evalb ![z, w, x] (code d) := + by + have : M↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance + constructor + · rintro ⟨w, hw⟩ + exact ⟨w, ((eval_codeRfindPos_iff d w ![x]).mp hw).1⟩ + · rintro ⟨w, hw⟩ + let P : M → Prop := fun w => ∃ z : M, 0 < z ∧ Semiformula.Evalb ![z, w, x] (code d) + have hP : Σ₁-Predicate P := + by + refine ⟨.mkSigma (“w. ∃ z, 0 < z ∧ !(Rew.emb ▹ code d)z w&x”), ?_⟩ + intro v + simp [P, Semiformula.eval_emb] + obtain ⟨w', hw', hmin⟩ := InductionOnHierarchy.least_number_sigma Σ 1 hP hw + refine ⟨w', (eval_codeRfindPos_iff d w' ![x]).mpr ⟨hw', ?_⟩⟩ + intro r hr + obtain ⟨z, hz⟩ := htotal r + have hz0 : z = 0 := + le_antisymm (not_lt.mp (fun hp => hmin r hr ⟨z, hp, hz⟩)) (Arithmetic.zero_le z) + simpa only [hz0] using hz + +/-- A packed witness records a stage and a candidate accepted by c with output zero. -/ +def packedSuccess (c : PCode) (x w : M) : Prop := + Semiformula.Evalb ![pi₁ w, (encode c : M), pair (pi₂ w) x, 0] + (evalnCertificateFormula : ArithmeticSemisentence 4) + +private theorem existsTest_eval (c : PCode) (w x z : M) : + Semiformula.Evalb ![z, w, x] (code (existsTest c)) ↔ + ((packedSuccess c x w ∧ z = 1) ∨ (¬packedSuccess c x w ∧ z = 0)) := + by + have hw : Semiformula.Evalb (w :> ![w, x]) (code (Code.proj (0 : Fin 2))) := + (eval_proj_iff _ _ _).mpr rfl + exact + successAt_eval c _ _ (pi₁ w) (pair (pi₂ w) x) z ![w, x] (eval_codeUnpair₁ _ _ _ hw) + (eval_codePair _ _ _ _ ![w, x] (eval_codeUnpair₂ _ _ _ hw) + ((eval_proj_iff _ _ _).mpr rfl)) + +private theorem existsTest_total (c : PCode) (w x : M) : + ∃ z : M, Semiformula.Evalb ![z, w, x] (code (existsTest c)) := by + classical + by_cases h : packedSuccess c x w + · exact ⟨1, (existsTest_eval c w x 1).mpr (Or.inl ⟨h, rfl⟩)⟩ + · exact ⟨0, (existsTest_eval c w x 0).mpr (Or.inr ⟨h, rfl⟩)⟩ + +private theorem existsTest_positive (c : PCode) (w x : M) : + (∃ z : M, 0 < z ∧ Semiformula.Evalb ![z, w, x] (code (existsTest c))) ↔ + packedSuccess c x w := + by + simp only [existsTest_eval] + constructor + · rintro ⟨z, hz, (⟨h, _⟩ | ⟨_, rfl⟩)⟩ + · exact h + · exact False.elim ((Arithmetic.lt_irrefl 0) hz) + · intro h + exact ⟨1, Arithmetic.zero_lt_one, Or.inl ⟨h, rfl⟩⟩ + +private theorem existsTest_zero (c : PCode) (w x : M) : + Semiformula.Evalb ![0, w, x] (code (existsTest c)) ↔ ¬packedSuccess c x w := + by + rw [existsTest_eval] + simp + +private theorem existsSearch_domain (c : PCode) (x : M) : + (∃ w : M, Semiformula.Evalb ![w, x] (code (codeRfindPos (existsTest c)))) ↔ + ∃ a : M, Computes c (pair a x) 0 := + by + rw [positive_search_domain _ x (fun w => existsTest_total c w x)] + simp only [existsTest_positive] + constructor + · rintro ⟨w, hw⟩ + exact ⟨pi₂ w, (computes_iff_stage c _ 0).mpr ⟨pi₁ w, hw⟩⟩ + · rintro ⟨a, ha⟩ + obtain ⟨s, hs⟩ := (computes_iff_stage c _ 0).mp ha + refine ⟨pair s a, ?_⟩ + simpa only [packedSuccess, pi₁_pair, pi₂_pair] using hs + +/-- Exact witness-selection graph: select the candidate belonging to the least +successful stage/candidate pair in the arithmetic model. -/ +theorem computes_candidateSearch (c : PCode) (x a : M) : + Computes (candidateSearch c) x a ↔ + ∃ w : M, packedSuccess c x w ∧ (∀ r < w, ¬packedSuccess c x r) ∧ a = pi₂ w := + by + rw [candidateSearch, computes_unaryCompile, eval_codeBind_iff] + have hproj (w : M) : + Semiformula.Evalb ![a, w, x] (code (codeUnpair₂ (Code.proj (0 : Fin 2)))) ↔ a = pi₂ w := + by + have h := eval_codeUnpair₂ (Code.proj (0 : Fin 2)) w ![w, x] ((eval_proj_iff _ _ _).mpr rfl) + constructor + · intro ha + exact eval_unique ha h + · rintro rfl + exact h + simp only [hproj, eval_codeRfindPos_iff, existsTest_positive, existsTest_zero] + exact exists_congr fun w => and_assoc + +/-- Every returned candidate is accepted by the original semidecision program. -/ +theorem candidateSearch_sound (c : PCode) (x a : M) (h : Computes (candidateSearch c) x a) : + Computes c (pair a x) 0 := + by + obtain ⟨w, hw, _, rfl⟩ := (computes_candidateSearch c x a).mp h + exact (computes_iff_stage c _ 0).mpr ⟨pi₁ w, hw⟩ + +/-- Fair search terminates if and only if an accepted candidate exists. -/ +theorem candidateSearch_domain (c : PCode) (x : M) : + (∃ a : M, Computes (candidateSearch c) x a) ↔ ∃ a : M, Computes c (pair a x) 0 := + by + constructor + · rintro ⟨a, ha⟩ + exact ⟨a, candidateSearch_sound c x a ha⟩ + · intro h + obtain ⟨w, hw⟩ := (existsSearch_domain c x).mpr h + refine ⟨pi₂ w, (computes_candidateSearch c x _).mpr ⟨w, ?_, ?_, rfl⟩⟩ + · exact (existsTest_positive c w x).mp ((eval_codeRfindPos_iff _ _ _).mp hw).1 + · intro r hr + exact (existsTest_zero c r x).mp (((eval_codeRfindPos_iff _ _ _).mp hw).2 r hr) + +/-- Existential quantification of a semidecision predicate, with output zero. -/ +theorem computes_existsProgram (c : PCode) (x y : M) : + Computes (existsProgram c) x y ↔ y = 0 ∧ ∃ a : M, Computes c (pair a x) 0 := + by + rw [existsProgram, ProgramGraph.computes_comp] + simp only [ProgramGraph.computes_zero, exists_and_right] + rw [candidateSearch_domain] + exact and_comm + +/-- With at most one accepted candidate, witness selection realizes the full +functional relation, rather than merely choosing some accepted candidate. -/ +theorem candidateSearch_of_functional (c : PCode) (x a : M) + (hunique : ∀ b d : M, Computes c (pair b x) 0 → Computes c (pair d x) 0 → b = d) : + Computes (candidateSearch c) x a ↔ Computes c (pair a x) 0 := + by + constructor + · exact candidateSearch_sound c x a + · intro ha + obtain ⟨b, hb⟩ := (candidateSearch_domain c x).mpr ⟨a, ha⟩ + have hba := hunique b a (candidateSearch_sound c x b hb) ha + simpa only [hba] using hb + +private theorem unionTest_eval (c d : PCode) (s x z : M) : + Semiformula.Evalb ![z, s, x] (code (unionTest c d)) ↔ + (((Semiformula.Evalb ![s, (encode c : M), x, 0] + (evalnCertificateFormula : ArithmeticSemisentence 4) ∨ + Semiformula.Evalb ![s, (encode d : M), x, 0] + (evalnCertificateFormula : ArithmeticSemisentence 4)) ∧ + z = 1) ∨ + (¬(Semiformula.Evalb ![s, (encode c : M), x, 0] + (evalnCertificateFormula : ArithmeticSemisentence 4) ∨ + Semiformula.Evalb ![s, (encode d : M), x, 0] + (evalnCertificateFormula : ArithmeticSemisentence 4)) ∧ + z = 0)) := + by + have ht (e : PCode) (a : M) := + successAt_eval e (Code.proj (0 : Fin 2)) (Code.proj 1) s x a ![s, x] + ((eval_proj_iff _ _ _).mpr rfl) ((eval_proj_iff _ _ _).mpr rfl) + rw [unionTest, eval_codeOr_iff] + simp only [ht] + by_cases hc : + Semiformula.Evalb ![s, (encode c : M), x, 0] + (evalnCertificateFormula : ArithmeticSemisentence 4) <;> + by_cases hd : + Semiformula.Evalb ![s, (encode d : M), x, 0] + (evalnCertificateFormula : ArithmeticSemisentence 4) <;> + simp [hc, hd] + +private theorem unionTest_total (c d : PCode) (s x : M) : + ∃ z : M, Semiformula.Evalb ![z, s, x] (code (unionTest c d)) := by + classical + by_cases h : + Semiformula.Evalb ![s, (encode c : M), x, 0] + (evalnCertificateFormula : ArithmeticSemisentence 4) ∨ + Semiformula.Evalb ![s, (encode d : M), x, 0] + (evalnCertificateFormula : ArithmeticSemisentence 4) + · exact ⟨1, (unionTest_eval c d s x 1).mpr (Or.inl ⟨h, rfl⟩)⟩ + · exact ⟨0, (unionTest_eval c d s x 0).mpr (Or.inr ⟨h, rfl⟩)⟩ + +private theorem unionTest_positive (c d : PCode) (s x : M) : + (∃ z : M, 0 < z ∧ Semiformula.Evalb ![z, s, x] (code (unionTest c d))) ↔ + (Semiformula.Evalb ![s, (encode c : M), x, 0] + (evalnCertificateFormula : ArithmeticSemisentence 4) ∨ + Semiformula.Evalb ![s, (encode d : M), x, 0] + (evalnCertificateFormula : ArithmeticSemisentence 4)) := + by + simp only [unionTest_eval] + constructor + · rintro ⟨z, hz, (⟨h, _⟩ | ⟨_, rfl⟩)⟩ + · exact h + · exact False.elim ((Arithmetic.lt_irrefl 0) hz) + · intro h + exact ⟨1, Arithmetic.zero_lt_one, Or.inl ⟨h, rfl⟩⟩ + +private theorem unionSearch_domain (c d : PCode) (x : M) : + (∃ w : M, Semiformula.Evalb ![w, x] (code (codeRfindPos (unionTest c d)))) ↔ + Computes c x 0 ∨ Computes d x 0 := + by + rw [positive_search_domain _ x (fun s => unionTest_total c d s x)] + simp only [unionTest_positive, exists_or, computes_iff_stage] + +/-- Fair disjunction of semidecision predicates, with output zero. -/ +theorem computes_unionProgram (c d : PCode) (x y : M) : + Computes (unionProgram c d) x y ↔ y = 0 ∧ (Computes c x 0 ∨ Computes d x 0) := + by + rw [unionProgram, computes_unaryCompile, eval_codeBind_iff] + simp only [eval_zero_iff, exists_and_right] + rw [unionSearch_domain] + exact and_comm + +end SigmaOneSearch +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/SigmaOneSemidecisionCore.lean b/LeanPool/PointwiseComposition/FailureOfComposition/SigmaOneSemidecisionCore.lean new file mode 100644 index 000000000..bf4d766af --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/SigmaOneSemidecisionCore.lean @@ -0,0 +1,82 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.ProgramGraph +public import LeanPool.PointwiseComposition.FailureOfComposition.ArithmeticCodeCompiler +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteEmptyGraph + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +Concrete zero-valued semidecision programs. The defining equivalences hold +for every input vector in every model of PA. +-/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +namespace FailureOfComposition +namespace SigmaOneRealization + +open ProgramGraph ArithmeticCodeCompiler + +/-- A program accepts exactly the satisfying input vectors and returns zero. -/ +def Semidecides {n : ℕ} (φ : ArithmeticSemisentence n) (c : Nat.Partrec.Code) : Prop := + ∀ (M : Type) [ORingStructure M] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (v : Fin n → M) (z : M), + Computes c (encodeVector v) z ↔ z = 0 ∧ Semiformula.Evalb v φ + +/-- The zero program accepts every vector. -/ +theorem verum_semidecides (n : ℕ) : Semidecides (⊤ : ArithmeticSemisentence n) .zero := + by + intro M _ _ _ v z + simpa using computes_zero (encodeVector v) z + +/-- Searching for a zero of successor accepts no vector. -/ +theorem falsum_semidecides (n : ℕ) : + Semidecides (⊥ : ArithmeticSemisentence n) (.rfind' .succ) := + by + intro M _ _ _ v z + change Computes (.rfind' .succ) (encodeVector v) z ↔ z = 0 ∧ False + rw [and_false] + unfold Computes + rw [ConcreteEvaluator.eventualGraph_eval] + simpa only [ConcreteEmptyGraph.concreteEmptyIndex, numeral_eq_natCast_app, + Matrix.cons_val_zero, Matrix.cons_val_one] using + ConcreteEmptyGraph.concreteEmpty_unbounded_computation_iff (encodeVector v) z + +/-- Evaluate both children and discard their outputs. -/ +def andProgram (c d : Nat.Partrec.Code) : Nat.Partrec.Code := + .comp .zero (.pair c d) + +/-- Pairing the two computations gives conjunction semidecision. -/ +theorem and_semidecides {n : ℕ} {φ ψ : ArithmeticSemisentence n} {c d : Nat.Partrec.Code} + (hφ : Semidecides φ c) (hψ : Semidecides ψ d) : Semidecides (φ ⋏ ψ) (andProgram c d) := + by + intro M _ _ _ v z + change + Computes (andProgram c d) (encodeVector v) z ↔ + z = 0 ∧ (Semiformula.Evalb v φ ∧ Semiformula.Evalb v ψ) + rw [andProgram, computes_comp] + simp only [computes_pair, computes_zero, hφ M v, hψ M v] + constructor + · rintro ⟨_, ⟨_, _, ⟨_, hp⟩, ⟨_, hq⟩, _⟩, hz⟩ + exact ⟨hz, hp, hq⟩ + · rintro ⟨hz, hp, hq⟩ + exact ⟨pair (0 : M) 0, ⟨0, 0, ⟨rfl, hp⟩, ⟨rfl, hq⟩, rfl⟩, hz⟩ + +end SigmaOneRealization +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/TheoryEnumerability.lean b/LeanPool/PointwiseComposition/FailureOfComposition/TheoryEnumerability.lean new file mode 100644 index 000000000..78bf32ec1 --- /dev/null +++ b/LeanPool/PointwiseComposition/FailureOfComposition/TheoryEnumerability.lean @@ -0,0 +1,226 @@ +/- +Copyright (c) 2026 Florian Lengyel. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Florian Lengyel +-/ +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.FailureOfComposition.ProductiveDivergence +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Syntax.Classical.PrimrecCoding + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +Enumerability of deductive closure from enumerability of the axioms. +The general result uses pure-logic proofs of finite implications and does not +assume a Delta-one presentation of the given theory. -/ + +@[expose] public section + +open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic + +open FFL.FirstOrder.Arithmetic.Bootstrapping FFL.Entailment + +open Encodable + +namespace FailureOfComposition + +noncomputable section + +/-- Numerical codes of axioms, using the same sentence coding as TheoremCodes. -/ +def AxiomCodes (T : ArithmeticTheory) (n : ℕ) : Prop := + ∃ σ : ArithmeticSentence, (⌜σ⌝ : ℕ) = n ∧ σ ∈ T + +/-- Provability in a Delta-one-presented theory is enumerable on sentences. -/ +theorem sentence_provability_re_of_delta1 (T : ArithmeticTheory) [T.Δ₁] : + REPred (fun σ : ArithmeticSentence => T ⊢ σ) := + by + have hp : REPred (fun n : ℕ => Bootstrapping.Provable T n) := + rePred_iff_sigma1.mpr (by definability) + apply REPred.of_eq (hp.comp Computable.encode) + intro σ + simpa only [← Sentence.quote_eq_encode_nat] using + (Bootstrapping.provable_iff_provable (T := T) (φ := σ)) + +private theorem theorem_codes_re_of_sentence_provability (T : ArithmeticTheory) + (hT : REPred (fun σ : ArithmeticSentence => T ⊢ σ)) : REPred (TheoremCodes T) := + by + have he : REPred (fun p : ℕ × ArithmeticSentence => encode p.2 = p.1) := + (Primrec.eq.comp (Primrec.encode.comp Primrec.snd) Primrec.fst).computablePred.to_re + apply + REPred.of_eq + ((PointwiseComposition.REPred.projection + ((PointwiseComposition.REPred.and he) (hT.comp Computable.snd)))) + intro n + simp only [TheoremCodes, Sentence.quote_eq_encode_nat] + +/-- Theorem codes are enumerable for every Foundation Delta-one presentation. -/ +theorem theorem_codes_re_of_delta1 (T : ArithmeticTheory) [T.Δ₁] : REPred (TheoremCodes T) := + theorem_codes_re_of_sentence_provability T (sentence_provability_re_of_delta1 T) + +/-- Finite lists of elements of an enumerable predicate can be enumerated. -/ +private theorem re_forall_mem_list {α : Type*} [Primcodable α] [Inhabited α] {p : α → Prop} + (hp : REPred p) : REPred (fun l : List α => ∀ a ∈ l, p a) := + by + obtain ⟨f, hf, hfp⟩ := REPred.iff'.mp hp + let test (l : List α) (n : ℕ) : Part Unit := + Nat.rec (Part.some ()) (fun i r => r.bind (fun _ => f (l.getD i default))) n + have ht : Partrec (fun l : List α => test l l.length) := by + exact + Partrec.nat_rec Computable.list_length (Partrec.const' (Part.some ())) + ((hf.comp + ((Primrec.list_getD default).to_comp.comp Computable.fst + (Computable.fst.comp Computable.snd))).to₂) + have htest (l : List α) (n : ℕ) : (test l n).Dom ↔ ∀ i < n, p (l.getD i default) := by + induction n with + | zero => simp [test] + | succ n ih => + change (∃ _ : (test l n).Dom, (f (l.getD n default)).Dom) ↔ _ + simp only [exists_prop, ih, ← hfp, Nat.forall_lt_succ_right] + apply REPred.of_eq ht.dom_re + intro l + rw [htest] + constructor + · intro h a ha + obtain ⟨i, hi, rfl⟩ := List.mem_iff_getElem.mp ha + simpa only [List.getD_eq_getElem l default hi] using h i hi + · intro h i hi + rw [List.getD_eq_getElem l default hi] + exact h _ (List.getElem_mem hi) + +private theorem computable_list_foldl {α β : Type*} [Primcodable α] [Primcodable β] + (f : β → α → β) (hf : Computable₂ f) : + Computable₂ (fun l : List α => fun b : β => l.foldl f b) := + by + let G (s : β × List α) : β × List α := s.2.head?.elim s (fun a => (f s.1 a, s.2.tail)) + have hG : Computable G := + by + apply + (Computable.option_casesOn (Primrec.list_head?.to_comp.comp Computable.snd) Computable.id + ((Computable.pair (hf.comp (Computable.fst.comp Computable.fst) Computable.snd) + (Primrec.list_tail.to_comp.comp (Computable.snd.comp Computable.fst))).to₂)).of_eq + intro s + dsimp only [G] + cases s.2.head? <;> rfl + have hiter : Computable (fun p : List α × β => G^[p.1.length] (p.2, p.1)) := + by + have hh := + Computable.nat_rec (Computable.list_length.comp (Computable.fst (α := List α) (β := β))) + (Computable.pair Computable.snd Computable.fst) + ((hG.comp (Computable.snd.comp Computable.snd)).to₂) + apply hh.of_eq + intro p + induction p.1.length with + | zero => rfl + | succ n ih => simp only [Function.iterate_succ_apply', ih] + have hspec : ∀ n (l : List α) (b : β), G^[n] (b, l) = ((l.take n).foldl f b, l.drop n) := + by + intro n + induction n with + | zero => intro l b; rfl + | succ n ih => + intro l b + simp only [Function.iterate_succ, Function.comp_apply] + cases l with + | nil => + simpa only [G, List.head?_nil, Option.elim_none, List.take_nil, List.foldl_nil, + List.drop_nil] using ih [] b + | cons a l => + simpa only [G, List.head?_cons, Option.elim_some, List.tail_cons, List.take_succ_cons, + List.drop_succ_cons, List.foldl_cons] using ih l (f b a) + apply (Computable.fst.comp hiter).of_eq + intro p + rw [hspec, List.take_length] + +private def finiteImplication (l : List ArithmeticSentence) (σ : ArithmeticSentence) : + ArithmeticSentence := + l.foldl (fun ψ φ => φ ⇒ₗ ψ) σ + +private theorem implication_computable : Computable₂ (fun σ τ : ArithmeticSentence => σ ⇒ₗ τ) := + by + have hi : Computable₂ (fun n m : ℕ => Bootstrapping.imp ℒₒᵣ n m) := + computable₂_iff_sigma1.mpr (by definability) + apply Computable.encode_iff.mp + apply + (hi.comp (Computable.encode.comp Computable.fst) + (Computable.encode.comp Computable.snd)).of_eq + intro p + simp [← Sentence.quote_eq_encode_nat, Sentence.quote_def, Semiformula.quote_def] + +private theorem finiteImplication_computable : Computable₂ finiteImplication := + computable_list_foldl _ (implication_computable.comp Computable.snd Computable.fst) + +private theorem finiteImplication_provable_iff (l : List ArithmeticSentence) + (T : ArithmeticTheory) (σ : ArithmeticSentence) : + T ⊢ finiteImplication l σ ↔ (T ∪ {τ | τ ∈ l}) ⊢ σ := by + induction l generalizing T σ with + | nil => simp [finiteImplication] + | cons φ l ih => + change T ⊢ finiteImplication l (φ ⇒ₗ σ) ↔ _ + rw [ih, ← deduction_iff] + have he : adjoin φ (T ∪ {τ | τ ∈ l}) = T ∪ {τ | τ ∈ φ :: l} := + by + ext τ + simp [Set.mem_union, or_assoc, or_comm] + rw [he] + +private theorem provable_iff_finiteImplication (T : ArithmeticTheory) (σ : ArithmeticSentence) : + T ⊢ σ ↔ + ∃ l : List ArithmeticSentence, + (∀ τ ∈ l, τ ∈ T) ∧ (∅ : ArithmeticTheory) ⊢ finiteImplication l σ := + by + constructor + · rintro ⟨b⟩ + refine ⟨b.axioms.toList, ?_, ?_⟩ + · intro τ hτ + exact b.axioms_mem τ (by simpa using hτ) + rw [finiteImplication_provable_iff] + simpa only [Set.empty_union, Multiset.mem_toList] using + (show ({τ | τ ∈ b.axioms} : ArithmeticTheory) ⊢ σ from + ⟨⟨b.axioms, by simp, b.derivation⟩⟩) + · rintro ⟨l, hl, hp⟩ + rw [finiteImplication_provable_iff] at hp + exact + Entailment.wkProof + (by + intro τ hτ + exact hl τ (by simpa only [Set.empty_union, Set.mem_ofPred_eq] using hτ)) + hp + +/-- Recursively enumerable axiom codes yield recursively enumerable theorem +codes. The theory need not have a Delta-one presentation. -/ +theorem theorem_codes_re_of_axiom_codes (T : ArithmeticTheory) (hT : REPred (AxiomCodes T)) : + REPred (TheoremCodes T) := + by + let : Inhabited ArithmeticSentence := ⟨⊤⟩ + have ha : REPred (fun σ : ArithmeticSentence => σ ∈ T) := + by + apply REPred.of_eq (hT.comp Computable.encode) + intro σ + simp only [AxiomCodes, Sentence.quote_eq_encode_nat, Encodable.encode_inj] + simp + have hl : REPred (fun l : List ArithmeticSentence => ∀ σ ∈ l, σ ∈ T) := re_forall_mem_list ha + have hp := sentence_provability_re_of_delta1 (∅ : ArithmeticTheory) + have hh : + REPred + (fun p : ArithmeticSentence × List ArithmeticSentence => + (∀ σ ∈ p.2, σ ∈ T) ∧ (∅ : ArithmeticTheory) ⊢ finiteImplication p.2 p.1) := + (PointwiseComposition.REPred.and (hl.comp Computable.snd)) + (hp.comp (finiteImplication_computable.comp Computable.snd Computable.fst)) + apply theorem_codes_re_of_sentence_provability T + apply REPred.of_eq (PointwiseComposition.REPred.projection hh) + intro σ + exact (provable_iff_finiteImplication T σ).symm + +end + +end FailureOfComposition + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Basic.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Basic.lean new file mode 100644 index 000000000..557d1cf92 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Basic.lean @@ -0,0 +1,22 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Basic.Misc +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Basic.Monotone +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Basic.Hierarchy +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Basic.Model +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Basic.StrictHierarchy + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Basic/Hierarchy.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Basic/Hierarchy.lean new file mode 100644 index 000000000..e4ce942b2 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Basic/Hierarchy.lean @@ -0,0 +1,615 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Syntax.Classical.Padding +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Basic.Model + +/-! Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section +namespace FFL +namespace FirstOrder +namespace Arithmetic + +variable {L : Language} [L.LT] + +/-- The arithmetical hierarchy, starting with bounded formulas at level zero. -/ +inductive Hierarchy : Polarity → ℕ → {n : ℕ} → Semiformula L ξ n → Prop + | verum (Γ s n) : Hierarchy Γ s (⊤ : Semiformula L ξ n) + | falsum (Γ s n) : Hierarchy Γ s (⊥ : Semiformula L ξ n) + | rel (Γ s) {k} (r : L.Rel k) (v) : Hierarchy Γ s (Semiformula.rel r v) + | nrel (Γ s) {k} (r : L.Rel k) (v) : Hierarchy Γ s (Semiformula.nrel r v) + | + and {Γ s n} {φ ψ : Semiformula L ξ n} : + Hierarchy Γ s φ → Hierarchy Γ s ψ → Hierarchy Γ s (φ ⋏ ψ) + | + or {Γ s n} {φ ψ : Semiformula L ξ n} : + Hierarchy Γ s φ → Hierarchy Γ s ψ → Hierarchy Γ s (φ ⋎ ψ) + | + ball {Γ s n} {φ : Semiformula L ξ (n + 1)} {t : Semiterm L ξ (n + 1)} : + t.Positive → Hierarchy Γ s φ → Hierarchy Γ s (∀¹[“x. x < !!t”] φ) + | + bexs {Γ s n} {φ : Semiformula L ξ (n + 1)} {t : Semiterm L ξ (n + 1)} : + t.Positive → Hierarchy Γ s φ → Hierarchy Γ s (∃¹[“x. x < !!t”] φ) + | exs {s n} {φ : Semiformula L ξ (n + 1)} : Hierarchy Σ (s + 1) φ → Hierarchy Σ (s + 1) (∃¹ φ) + | all {s n} {φ : Semiformula L ξ (n + 1)} : Hierarchy Π (s + 1) φ → Hierarchy Π (s + 1) (∀¹ φ) + | sigma {s n} {φ : Semiformula L ξ (n + 1)} : Hierarchy Π s φ → Hierarchy Σ (s + 1) (∃¹ φ) + | pi {s n} {φ : Semiformula L ξ (n + 1)} : Hierarchy Σ s φ → Hierarchy Π (s + 1) (∀¹ φ) + | + dummy_sigma {s n} {φ : Semiformula L ξ (n + 1)} : + Hierarchy Π (s + 1) φ → Hierarchy Σ (s + 1 + 1) (∀¹ φ) + | + dummy_pi {s n} {φ : Semiformula L ξ (n + 1)} : + Hierarchy Σ (s + 1) φ → Hierarchy Π (s + 1 + 1) (∃¹ φ) + +/-- The Delta Zero construction in `FFL.FirstOrder.Arithmetic`. -/ +def DeltaZero (φ : Semiformula L ξ n) : Prop := + Hierarchy Σ 0 φ + +attribute [simp] Hierarchy.verum Hierarchy.falsum Hierarchy.rel Hierarchy.nrel + +namespace Hierarchy + +@[simp] +lemma and_iff {φ ψ : Semiformula L ξ n} : + Hierarchy Γ s (φ ⋏ ψ) ↔ Hierarchy Γ s φ ∧ Hierarchy Γ s ψ := + ⟨by + generalize hr : φ ⋏ ψ = r + intro H + induction H <;> try simp only [reduceCtorEq, Semiformula.and_inj, FirstOrder.ball, + Matrix.vecCons_empty_eq_singleton, FirstOrder.bexs] at hr + case and => + rcases hr with ⟨rfl, rfl⟩ + constructor <;> assumption, + by rintro ⟨hp, hq⟩; exact Hierarchy.and hp hq⟩ + +@[simp] +lemma or_iff {φ ψ : Semiformula L ξ n} : + Hierarchy Γ s (φ ⋎ ψ) ↔ Hierarchy Γ s φ ∧ Hierarchy Γ s ψ := + ⟨by + generalize hr : φ ⋎ ψ = r + intro H + induction H <;> try simp only [reduceCtorEq, Semiformula.or_inj, FirstOrder.ball, + Matrix.vecCons_empty_eq_singleton, FirstOrder.bexs] at hr + case or => + rcases hr with ⟨rfl, rfl⟩ + constructor <;> assumption, + by rintro ⟨hp, hq⟩; exact Hierarchy.or hp hq⟩ + +@[simp] lemma conj_iff {φ : Fin m → Semiformula L ξ n} : + Hierarchy Γ s (Matrix.conj φ) ↔ ∀ i, Hierarchy Γ s (φ i) := by + induction m <;> simp only [Matrix.conj, verum, IsEmpty.forall_iff, Matrix.vecTail, + Nat.succ_eq_add_one, and_iff, Function.comp_apply, *] + · exact ⟨by rintro ⟨hz, hs⟩ i; cases i using Fin.cases <;> simp [*], + by intro h; exact ⟨h 0, fun _ => h _⟩⟩ + +lemma zero_eq_alt {φ : Semiformula L ξ n} : Hierarchy Γ 0 φ → Hierarchy Γ.alt 0 φ := + by + generalize hz : 0 = z + rw [eq_comm] at hz + intro h + induction h <;> try simp only [verum, falsum, rel, nrel, and_iff, or_iff, + Matrix.vecCons_empty_eq_singleton, Nat.add_eq_zero_iff, one_ne_zero, and_false, + and_self] at hz ⊢ + case and _ _ ihp ihq => exact ⟨ihp hz, ihq hz⟩ + case or _ _ ihp ihq => exact ⟨ihp hz, ihq hz⟩ + case ball pos _ ih => exact ball pos (ih hz) + case bexs pos _ ih => exact bexs pos (ih hz) + +lemma pi_zero_iff_sigma_zero {φ : Semiformula L ξ n} : Hierarchy Π 0 φ ↔ Hierarchy Σ 0 φ := + ⟨zero_eq_alt, zero_eq_alt⟩ + +lemma zero_iff {Γ Γ'} {φ : Semiformula L ξ n} : Hierarchy Γ 0 φ ↔ Hierarchy Γ' 0 φ := by + rcases Γ <;> rcases Γ' <;> simp [Polarity.eq_sigma, Polarity.eq_pi, pi_zero_iff_sigma_zero] + +lemma zero_iff_delta_zero {Γ} {φ : Semiformula L ξ n} : Hierarchy Γ 0 φ ↔ DeltaZero φ := by + simpa [DeltaZero, pi_zero_iff_sigma_zero] using zero_iff + +@[simp] +lemma alt_zero_iff_zero {φ : Semiformula L ξ n} : Hierarchy Γ.alt 0 φ ↔ Hierarchy Γ 0 φ := by + rcases Γ <;> simp [Polarity.eq_sigma, Polarity.eq_pi, pi_zero_iff_sigma_zero] + +lemma accum {Γ} {s : ℕ} {φ : Semiformula L ξ n} : Hierarchy Γ s φ → ∀ Γ', Hierarchy Γ' (s + 1) φ + | verum _ _ _, _ => verum _ _ _ + | falsum _ _ _, _ => falsum _ _ _ + | rel _ _ r v, _ => rel _ _ r v + | nrel _ _ r v, _ => nrel _ _ r v + | and hp hq, _ => and (hp.accum _) (hq.accum _) + | or hp hq, _ => or (hp.accum _) (hq.accum _) + | ball pos hp, _ => ball pos (hp.accum _) + | bexs pos hp, _ => bexs pos (hp.accum _) + | all hp, Γ => by + cases Γ + · exact hp.dummy_sigma + · exact (hp.accum Π).all + | exs hp, Γ => by + cases Γ + · exact (hp.accum Σ).exs + · exact hp.dummy_pi + | sigma hp, Γ => by + cases Γ + · exact ((hp.accum Σ).accum Σ).exs + · exact (hp.accum Σ).dummy_pi + | pi hp, Γ => by + cases Γ + · exact (hp.accum Π).dummy_sigma + · exact ((hp.accum Π).accum Π).all + | dummy_sigma hp, Γ => by + cases Γ + · exact (hp.accum Π).dummy_sigma + · exact ((hp.accum Π).accum Π).all + | dummy_pi hp, Γ => by + cases Γ + · exact ((hp.accum Σ).accum Σ).exs + · exact (hp.accum Σ).dummy_pi + +lemma strict_mono {Γ s} {φ : Semiformula L ξ n} (hp : Hierarchy Γ s φ) (Γ') {s'} (h : s < s') : + Hierarchy Γ' s' φ := + by + have : ∀ d, Hierarchy Γ' (s + d + 1) φ := by + intro d + induction d with + | zero => simpa using hp.accum Γ' + | succ s ih => simpa only [Nat.add_succ, add_zero] using ih.accum _ + simpa [show s + (s' - s.succ) + 1 = s' from by + simpa [Nat.succ_add] using Nat.add_sub_of_le h] using + this (s' - s.succ) + +lemma mono {Γ} {s s' : ℕ} {φ : Semiformula L ξ n} (hp : Hierarchy Γ s φ) (h : s ≤ s') : + Hierarchy Γ s' φ := by + rcases Nat.lt_or_eq_of_le h with (lt | rfl) + · exact hp.strict_mono Γ lt + · assumption + +lemma of_zero {b b'} {s : ℕ} {φ : Semiformula L ξ n} (hp : Hierarchy b 0 φ) : + Hierarchy b' s φ := + by + rcases Nat.eq_or_lt_of_le (Nat.zero_le s) with (rfl | pos) + · exact zero_iff.mp hp + · exact strict_mono hp b' pos + +section + +variable {L : Language} + +@[simp] lemma equal [L.Eq] [L.LT] {t u : Semiterm L ξ n} : Hierarchy Γ s “!!t = !!u” := by + simp [Semiformula.Operator.operator, Matrix.fun_eq_vec_two, + Semiformula.Operator.Eq.sentence_eq] + +@[simp] lemma lt [L.LT] {t u : Semiterm L ξ n} : Hierarchy Γ s “!!t < !!u” := by + simp [Semiformula.Operator.operator, Matrix.fun_eq_vec_two, Semiformula.Operator.LT.sentence_eq] + +@[simp] lemma le [L.Eq] [L.LT] {t u : Semiterm L ξ n} : Hierarchy Γ s “!!t ≤ !!u” := by + simp [Semiformula.Operator.operator, Matrix.fun_eq_vec_two, + Semiformula.Operator.Eq.sentence_eq, Semiformula.Operator.LT.sentence_eq, + Semiformula.Operator.LE.sentence_eq] + +end + +lemma neg {φ : Semiformula L ξ n} : Hierarchy Γ s φ → Hierarchy Γ.alt s (∼φ) := + by + intro h; induction h <;> try simp only [LogicalNeutral.DeMorgan.verum, falsum, + LogicalNeutral.DeMorgan.falsum, verum, Semiformula.neg_rel, nrel, Semiformula.neg_nrel, rel, + LogicalConnective.DeMorgan.and, or_iff, and_self, *, LogicalConnective.DeMorgan.or, and_iff, + Matrix.vecCons_empty_eq_singleton, Semiformula.neg_ball, Semiformula.neg_bexs, + Polarity.alt_sigma, Semiformula.neg_ex, Polarity.alt_pi, Semiformula.neg_all] + case bexs pos _ ih => exact ball pos ih + case ball pos _ ih => exact bexs pos ih + case exs ih => exact all ih + case all ih => exact exs ih + case sigma ih => exact pi ih + case pi ih => exact sigma ih + case dummy_pi ih => exact dummy_sigma ih + case dummy_sigma ih => exact dummy_pi ih + +@[simp] +lemma neg_iff {φ : Semiformula L ξ n} : Hierarchy Γ s (∼φ) ↔ Hierarchy Γ.alt s φ := + ⟨fun h => by simpa using neg h, fun h => by simpa using neg h⟩ + +@[simp] +lemma imp_iff {φ ψ : Semiformula L ξ n} : + Hierarchy Γ s (φ ⇒ₗ ψ) ↔ (Hierarchy Γ.alt s φ ∧ Hierarchy Γ s ψ) := by + simp [Semiformula.imp_eq] + +@[simp] +lemma ball_iff {Γ s n} {φ : Semiformula L ξ (n + 1)} {t : Semiterm L ξ (n + 1)} + (ht : t.Positive) : Hierarchy Γ s (∀¹[“x. x < !!t”] φ) ↔ Hierarchy Γ s φ := + ⟨by + generalize hq : (∀¹[“x. x < !!t”] φ) = ψ + intro H + induction H <;> try simp only [FirstOrder.ball, Matrix.vecCons_empty_eq_singleton, + reduceCtorEq, Semiformula.all_inj, Semiformula.imp_inj, + Semiformula.Operator.LT.lt_inj, true_and, FirstOrder.bexs] at hq + case ball φ t pt hp ih => + rcases hq with ⟨rfl, rfl⟩ + assumption + case all hp ih => + rcases hq with rfl + simpa using hp + case pi s _ _ hp ih => + rcases hq with rfl + exact (show Hierarchy Σ s φ from by simpa using hp).accum _ + case dummy_sigma hp _ => + rcases hq with rfl + simp at hp + exact hp.accum _, + by intro hp; exact hp.ball ht⟩ + +@[simp] +lemma bexs_iff {Γ s n} {φ : Semiformula L ξ (n + 1)} {t : Semiterm L ξ (n + 1)} + (ht : t.Positive) : Hierarchy Γ s (∃¹[“x. x < !!t”] φ) ↔ Hierarchy Γ s φ := + ⟨by + generalize hq : (∃¹[“x. x < !!t”] φ) = ψ + intro H + induction H <;> try simp only [FirstOrder.bexs, Matrix.vecCons_empty_eq_singleton, + reduceCtorEq, FirstOrder.ball, Semiformula.exs_inj, Semiformula.and_inj, + Semiformula.Operator.LT.lt_inj, true_and] at hq + case bexs φ t pt hp ih => + rcases hq with ⟨rfl, rfl⟩ + assumption + case exs hp ih => + rcases hq with rfl + simpa using hp + case sigma s _ _ hp ih => + rcases hq with rfl + exact (show Hierarchy Π s φ from by simpa using hp).accum _ + case dummy_pi hp _ => + rcases hq with rfl + simp at hp + exact hp.accum _, + by intro hp; exact hp.bexs ht⟩ + +@[simp] +lemma ballLT_iff {Γ s n} {φ : Semiformula L ξ (n + 1)} {t : Semiterm L ξ n} : + Hierarchy Γ s (φ.ballLT t) ↔ Hierarchy Γ s φ := by simp [Semiformula.ballLT] + +@[simp] +lemma bexsLT_iff {Γ s n} {φ : Semiformula L ξ (n + 1)} {t : Semiterm L ξ n} : + Hierarchy Γ s (φ.bexsLT t) ↔ Hierarchy Γ s φ := by simp [Semiformula.bexsLT] + +@[simp] +lemma ballLTSucc_iff [L.Zero] [L.One] [L.Add] {Γ s n} {φ : Semiformula L ξ (n + 1)} + {t : Semiterm L ξ n} : Hierarchy Γ s (φ.ballLTSucc t) ↔ Hierarchy Γ s φ := by + simp [Semiformula.ballLTSucc] + +@[simp] +lemma bexsLTSucc_iff [L.Zero] [L.One] [L.Add] {Γ s n} {φ : Semiformula L ξ (n + 1)} + {t : Semiterm L ξ n} : Hierarchy Γ s (φ.bexsLTSucc t) ↔ Hierarchy Γ s φ := by + simp [Semiformula.bexsLTSucc] + +lemma pi_of_pi_all {φ : Semiformula L ξ (n + 1)} : Hierarchy Π s (∀¹ φ) → Hierarchy Π s φ := + by + generalize hr : ∀¹ φ = r + generalize hb : (Π : Polarity) = Γ + intro H + cases H <;> try simp only [reduceCtorEq, FirstOrder.ball, + Matrix.vecCons_empty_eq_singleton, Semiformula.all_inj, FirstOrder.bexs] at hr + case ball => rcases hr with rfl; simpa + case all => rcases hr with rfl; simpa + case pi hp => rcases hr with rfl; exact hp.accum _ + case dummy_sigma hp => rcases hr with rfl; exact hp.accum _ + +@[simp] +lemma all_iff {φ : Semiformula L ξ (n + 1)} : + Hierarchy Π (s + 1) (∀¹ φ) ↔ Hierarchy Π (s + 1) φ := + ⟨pi_of_pi_all, all⟩ + +@[simp] +lemma allItr_iff {φ : Semiformula L ξ (n + k)} : + Hierarchy Π (s + 1) (∀¹^[k] φ) ↔ Hierarchy Π (s + 1) φ := by + induction k <;> simp [allItr_succ, *] + +lemma sigma_of_sigma_ex {φ : Semiformula L ξ (n + 1)} : + Hierarchy Σ s (∃¹ φ) → Hierarchy Σ s φ := + by + generalize hr : ∃¹ φ = r + generalize hb : (Σ : Polarity) = Γ + intro H + cases H <;> try simp only [reduceCtorEq, FirstOrder.ball, + Matrix.vecCons_empty_eq_singleton, FirstOrder.bexs, Semiformula.exs_inj] at hr + case bexs => rcases hr with rfl; simpa + case exs => rcases hr with rfl; simpa + case sigma hp => rcases hr with rfl; exact hp.accum _ + case dummy_pi hp => rcases hr with rfl; exact hp.accum _ + +@[simp] +lemma sigma_iff {φ : Semiformula L ξ (n + 1)} : + Hierarchy Σ (s + 1) (∃¹ φ) ↔ Hierarchy Σ (s + 1) φ := + ⟨sigma_of_sigma_ex, exs⟩ + +@[simp] +lemma exsItr_iff {φ : Semiformula L ξ (n + k)} : + Hierarchy Σ (s + 1) (∃¹^[k] φ) ↔ Hierarchy Σ (s + 1) φ := by + induction k <;> simp [exsItr_succ, *] + +lemma rew (ω : Rew L ξ₁ n₁ ξ₂ n₂) {φ : Semiformula L ξ₁ n₁} : + Hierarchy Γ s φ → Hierarchy Γ s (ω ▹ φ) := + by + intro h; induction h generalizing n₂ <;> try simp only [LogicalConnective.HomClass.map_top, + verum, LogicalConnective.HomClass.map_bot, falsum, Semiformula.rew_rel_eq_comp, rel, + Semiformula.rew_nrel_eq_comp, nrel, LogicalConnective.HomClass.map_and, and_iff, and_self, *, + LogicalConnective.HomClass.map_or, or_iff, Matrix.vecCons_empty_eq_singleton, + Rewriting.smul_ball, Rew.hom_finitary2, Rew.q_bvar_zero, Rew.q_positive_iff, ball_iff, + Rewriting.smul_bexs, bexs_iff, Rewriting.app_exs, sigma_iff, Rewriting.app_all, all_iff] + case sigma ih => exact (ih _).accum _ + case pi ih => exact (ih _).accum _ + case dummy_pi ih => exact (ih _).dummy_pi + case dummy_sigma ih => exact (ih _).dummy_sigma + +@[simp] +lemma rew_iff {ω : Rew L ξ₁ n₁ ξ₂ n₂} {φ : Semiformula L ξ₁ n₁} : + Hierarchy Γ s (ω ▹ φ) ↔ Hierarchy Γ s φ := + by + constructor + · generalize eq : ω ▹ φ = ψ + intro hq + induction hq generalizing φ n₁ <;> + try + simp only [Semiformula.eq_top_iff, Semiformula.eq_bot_iff, Semiformula.eq_rel_iff, + Semiformula.eq_nrel_iff, Semiformula.eq_and_iff, exists_and_left, + Semiformula.eq_or_iff, Matrix.vecCons_empty_eq_singleton, Semiformula.eq_ball_iff, + Semiformula.eq_bexs_iff, Semiformula.eq_exs_iff, Semiformula.eq_all_iff] at eq + case verum => rcases eq with rfl; simp + case falsum => rcases eq with rfl; simp + case rel => rcases eq with ⟨v', rfl, rfl⟩; simp + case nrel => rcases eq with ⟨v', rfl, rfl⟩; simp + case and ihp ihq => + rcases eq with ⟨φ₁, rfl, φ₂, rfl, rfl⟩ + simpa using ⟨ihp rfl, ihq rfl⟩ + case or ihp ihq => + rcases eq with ⟨φ₁, rfl, φ₂, rfl, rfl⟩ + simpa using ⟨ihp rfl, ihq rfl⟩ + case ball pos _ + ih => + simp only [Rew.eq_lt_iff, Rew.q_eq_zero_iff, Matrix.vecCons_empty_eq_singleton, + exists_and_left, exists_eq_left] at eq + rcases eq with ⟨hp, ⟨u, rfl, s, hs, rfl⟩, φ, rfl, rfl⟩ + simpa [show u.Positive from by simpa using pos] using ih rfl + case bexs pos _ + ih => + simp only [Rew.eq_lt_iff, Rew.q_eq_zero_iff, Matrix.vecCons_empty_eq_singleton, + exists_and_left, exists_eq_left] at eq + rcases eq with ⟨hp, ⟨u, rfl, s, hs, rfl⟩, φ, rfl, rfl⟩ + simpa [show u.Positive from by simpa using pos] using ih rfl + case all ih => + rcases eq with ⟨φ, rfl, rfl⟩ + exact (ih rfl).all + case exs ih => + rcases eq with ⟨φ, rfl, rfl⟩ + exact (ih rfl).exs + case pi ih => + rcases eq with ⟨φ, rfl, rfl⟩ + exact (ih rfl).pi + case sigma ih => + rcases eq with ⟨φ, rfl, rfl⟩ + exact (ih rfl).sigma + case dummy_sigma ih => + rcases eq with ⟨φ, rfl, rfl⟩ + exact (ih rfl).dummy_sigma + case dummy_pi ih => + rcases eq with ⟨φ, rfl, rfl⟩ + exact (ih rfl).dummy_pi + · exact rew _ + +lemma exsClosure : + {n : ℕ} → + {φ : Semiformula L ξ n} → Hierarchy Σ (s + 1) φ → Hierarchy Σ (s + 1) (exsClosure φ) + | 0, _, hp => hp + | _ + 1, φ, hp => exsClosure (φ := ∃¹ φ) hp.exs + +instance : LogicalConnective.AndOrClosed (Hierarchy Γ s : Semiformula L ξ k → Prop) + where + verum := verum _ _ _ + falsum := falsum _ _ _ + and := and + or := or + +instance : LogicalConnective.Closed (Hierarchy Γ 0 : Semiformula L ξ k → Prop) + where + not := by simp [neg_iff] + imply := by simp [Semiformula.imp_eq, neg_iff]; tauto + +lemma of_open {φ : Semiformula L ξ n} : φ.Open → Hierarchy Γ s φ := + by + induction φ using Semiformula.rec' <;> simp only [verum, implies_true, falsum, rel, nrel, + Semiformula.open_and, and_iff, and_imp, Semiformula.open_or, or_iff, Semiformula.not_open_all, + IsEmpty.forall_iff, Semiformula.not_open_exs] + case hand ihp ihq => intro hp hq; exact ⟨ihp hp, ihq hq⟩ + case hor ihp ihq => intro hp hq; exact ⟨ihp hp, ihq hq⟩ + +variable {L : Language} [L.ORing] + +lemma iff_iff {φ ψ : Semiformula L ξ n} : + Hierarchy b s (φ ⇔ₗ ψ) ↔ + (Hierarchy b s φ ∧ Hierarchy b.alt s φ ∧ Hierarchy b s ψ ∧ Hierarchy b.alt s ψ) := + by simp [Semiformula.iff_eq]; tauto + +@[simp] +lemma iff_iff₀ {φ ψ : Semiformula L ξ n} : + Hierarchy b 0 (φ ⇔ₗ ψ) ↔ (Hierarchy b 0 φ ∧ Hierarchy b 0 ψ) := by + simp [Semiformula.iff_eq]; tauto + +lemma matrix_conj_iff {b s n} {φ : Fin m → Semiformula L ξ n} : + Hierarchy b s (Matrix.conj fun j ↦ φ j) ↔ ∀ j, Hierarchy b s (φ j) := by cases m <;> simp + +lemma remove_forall {φ : Semiformula L ξ (n + 1)} : Hierarchy b s (∀¹ φ) → Hierarchy b s φ := + by + intro h; rcases h + case ball => simpa + case all => assumption + case pi h => exact h.accum _ + case dummy_sigma h => exact h.accum _ + +lemma remove_exists {φ : Semiformula L ξ (n + 1)} : Hierarchy b s (∃¹ φ) → Hierarchy b s φ := + by + intro h; rcases h + case bexs => simpa + case exs => assumption + case sigma h => exact h.accum _ + case dummy_pi h => exact h.accum _ + +@[simp] +lemma padding_iff {Γ s n} {φ : Semiformula L ξ n} : + Hierarchy Γ s (φ.padding k) ↔ Hierarchy Γ s φ := + by + simp only [Semiformula.padding, and_iff, and_iff_left_iff_imp] + intro h + induction k <;> simp [List.replicate_succ, *] + +@[simp] +lemma list_conj₂_iff {Γ s n} {l : List (Semiformula L ξ n)} : + Hierarchy Γ s (⋀l) ↔ ∀ φ ∈ l, Hierarchy Γ s φ := by + match l with + | [] => simp + | [_] => simp + | ψ :: χ :: l => simp [list_conj₂_iff (l := χ :: l)] + +@[simp] +lemma list_disj₂_iff {Γ s n} {l : List (Semiformula L ξ n)} : + Hierarchy Γ s (⋁l) ↔ ∀ φ ∈ l, Hierarchy Γ s φ := by + match l with + | [] => simp + | [_] => simp + | ψ :: χ :: l => simp [list_disj₂_iff (l := χ :: l)] + +@[simp] +lemma list_conj'_iff {Γ s n} {l : List ι} {φ : ι → Semiformula L ξ n} : + Hierarchy Γ s ((PointwiseComposition.List.conj' · l) φ) ↔ ∀ i ∈ l, Hierarchy Γ s (φ i) := by + simp [List.conj'] + +@[simp] +lemma list_disj'_iff {Γ s n} {l : List ι} {φ : ι → Semiformula L ξ n} : + Hierarchy Γ s ((PointwiseComposition.List.disj' · l) φ) ↔ ∀ i ∈ l, Hierarchy Γ s (φ i) := by + simp [List.disj'] + +@[simp] +lemma finset_conj'_iff {Γ s n} {t : Finset ι} {φ : ι → Semiformula L ξ n} : + Hierarchy Γ s ((PointwiseComposition.Finset.conj' t) φ) ↔ ∀ i ∈ t, Hierarchy Γ s (φ i) := by + simp [Finset.conj'] + +@[simp] +lemma finset_disj'_iff {Γ s n} {t : Finset ι} {φ : ι → Semiformula L ξ n} : + Hierarchy Γ s ((PointwiseComposition.Finset.disj' t) φ) ↔ ∀ i ∈ t, Hierarchy Γ s (φ i) := by + simp [Finset.disj'] + +@[simp] +lemma finset_uconj_iff {Γ s n} [Fintype ι] {φ : ι → Semiformula L ξ n} : + Hierarchy Γ s (Finset.uconj φ) ↔ ∀ i, Hierarchy Γ s (φ i) := by simp [Finset.uconj] + +@[simp] +lemma finset_udisj_iff {Γ s n} [Fintype ι] {φ : ι → Semiformula L ξ n} : + Hierarchy Γ s (Finset.udisj φ) ↔ ∀ i, Hierarchy Γ s (φ i) := by simp [Finset.udisj] + +lemma toPrenex {φ : Semiformula L ξ (n + s)} (h : Hierarchy (Γ.altItr s) j φ) : + Hierarchy Γ (j + s) (φ.toPrenex Γ s) := by + induction s generalizing n j with + | zero => simpa using h + | succ s ih => + rw [Polarity.altItr_succ] at h + change Hierarchy Γ (j + (s + 1)) (Polarity.quantItr Γ (s + 1) φ) + rw [Polarity.quantItr_succ', (show j + (s + 1) = (j + 1) + s by omega)] + rcases hΓ : Γ.altItr s with _ | _ + · apply ih + rw [hΓ] at h ⊢ + exact h.sigma + · apply ih + rw [hΓ] at h ⊢ + exact h.pi + +end Hierarchy + +section LOR + +lemma sigma₁_induction {P : (n : ℕ) → ArithmeticSemiformula ξ n → Prop} (hVerum : ∀ n, P n ⊤) + (hFalsum : ∀ n, P n ⊥) (hEQ : ∀ n t₁ t₂, P n (.rel Language.Eq.eq ![t₁, t₂])) + (hNEQ : ∀ n t₁ t₂, P n (.nrel Language.Eq.eq ![t₁, t₂])) + (hLT : ∀ n t₁ t₂, P n (.rel Language.LT.lt ![t₁, t₂])) + (hNLT : ∀ n t₁ t₂, P n (.nrel Language.LT.lt ![t₁, t₂])) + (hAnd : ∀ n φ ψ, Hierarchy Σ 1 φ → Hierarchy Σ 1 ψ → P n φ → P n ψ → P n (φ ⋏ ψ)) + (hOr : ∀ n φ ψ, Hierarchy Σ 1 φ → Hierarchy Σ 1 ψ → P n φ → P n ψ → P n (φ ⋎ ψ)) + (hBall : ∀ n t φ, Hierarchy Σ 1 φ → P (n + 1) φ → P n (∀¹[“#0 < !!(Rew.bShift t)”] φ)) + (hExs : ∀ n φ, Hierarchy Σ 1 φ → P (n + 1) φ → P n (∃¹ φ)) (n φ) : Hierarchy Σ 1 φ → P n φ + | Hierarchy.verum _ _ _ => hVerum _ + | Hierarchy.falsum _ _ _ => hFalsum _ + | Hierarchy.rel _ _ Language.Eq.eq v => by + simpa [← Matrix.fun_eq_vec_two] using hEQ _ (v 0) (v 1) + | Hierarchy.nrel _ _ Language.Eq.eq v => by + simpa [← Matrix.fun_eq_vec_two] using hNEQ _ (v 0) (v 1) + | Hierarchy.rel _ _ Language.LT.lt v => by + simpa [← Matrix.fun_eq_vec_two] using hLT _ (v 0) (v 1) + | Hierarchy.nrel _ _ Language.LT.lt v => by + simpa [← Matrix.fun_eq_vec_two] using hNLT _ (v 0) (v 1) + | Hierarchy.and hp hq => + hAnd _ _ _ hp hq + (sigma₁_induction hVerum hFalsum hEQ hNEQ hLT hNLT hAnd hOr hBall hExs _ _ hp) + (sigma₁_induction hVerum hFalsum hEQ hNEQ hLT hNLT hAnd hOr hBall hExs _ _ hq) + | Hierarchy.or hp hq => + hOr _ _ _ hp hq + (sigma₁_induction hVerum hFalsum hEQ hNEQ hLT hNLT hAnd hOr hBall hExs _ _ hp) + (sigma₁_induction hVerum hFalsum hEQ hNEQ hLT hNLT hAnd hOr hBall hExs _ _ hq) + | Hierarchy.ball pt hp => + by + rcases Rew.positive_iff.mp pt with ⟨t, rfl⟩ + exact + hBall _ t _ hp + (sigma₁_induction hVerum hFalsum hEQ hNEQ hLT hNLT hAnd hOr hBall hExs _ _ hp) + | Hierarchy.bexs pt hp => by + apply hExs + · simp [hp] + · rcases Rew.positive_iff.mp pt with ⟨t, rfl⟩ + apply + hAnd _ _ _ (by simp) hp (by simpa [Semiformula.Operator.lt_def] using hLT _ _ _) + (sigma₁_induction hVerum hFalsum hEQ hNEQ hLT hNLT hAnd hOr hBall hExs _ _ hp) + | Hierarchy.sigma (φ := φ) hp => + have : Hierarchy Σ 1 φ := hp.accum _ + hExs _ _ this + (sigma₁_induction hVerum hFalsum hEQ hNEQ hLT hNLT hAnd hOr hBall hExs _ _ this) + | Hierarchy.exs hp => + hExs _ _ hp (sigma₁_induction hVerum hFalsum hEQ hNEQ hLT hNLT hAnd hOr hBall hExs _ _ hp) + +lemma sigma₁_induction' {n φ} (hp : Hierarchy Σ 1 φ) + {P : (n : ℕ) → ArithmeticSemiformula ξ n → Prop} (hVerum : ∀ n, P n ⊤) + (hFalsum : ∀ n, P n ⊥) (hEQ : ∀ n t₁ t₂, P n (.rel Language.Eq.eq ![t₁, t₂])) + (hNEQ : ∀ n t₁ t₂, P n (.nrel Language.Eq.eq ![t₁, t₂])) + (hLT : ∀ n t₁ t₂, P n (.rel Language.LT.lt ![t₁, t₂])) + (hNLT : ∀ n t₁ t₂, P n (.nrel Language.LT.lt ![t₁, t₂])) + (hAnd : ∀ n φ ψ, Hierarchy Σ 1 φ → Hierarchy Σ 1 ψ → P n φ → P n ψ → P n (φ ⋏ ψ)) + (hOr : ∀ n φ ψ, Hierarchy Σ 1 φ → Hierarchy Σ 1 ψ → P n φ → P n ψ → P n (φ ⋎ ψ)) + (hBall : ∀ n t φ, Hierarchy Σ 1 φ → P (n + 1) φ → P n (∀¹[“#0 < !!(Rew.bShift t)”] φ)) + (hExs : ∀ n φ, Hierarchy Σ 1 φ → P (n + 1) φ → P n (∃¹ φ)) : P n φ := + sigma₁_induction hVerum hFalsum hEQ hNEQ hLT hNLT hAnd hOr hBall hExs n φ hp + +end LOR + +end Arithmetic + +/-- The Sound On Hierarchy construction in `FFL.FirstOrder.ArithmeticTheory`. -/ +abbrev ArithmeticTheory.SoundOnHierarchy (T : ArithmeticTheory) (Γ : Polarity) (k : ℕ) := + T.SoundOn (Arithmetic.Hierarchy Γ k) + +lemma ArithmeticTheory.soundOnHierarchy (T : ArithmeticTheory) (Γ : Polarity) (k : ℕ) + [T.SoundOnHierarchy Γ k] : T ⊢ σ → Arithmetic.Hierarchy Γ k σ → ℕ↓[ℒₒᵣ] ⊧ σ := + SoundOn.sound + +instance (T : ArithmeticTheory) [T.SoundOnHierarchy Σ 1] : Entailment.Consistent T := + T.consistent_of_sound (Arithmetic.Hierarchy Σ 1) (by simp) + +instance (T : ArithmeticTheory) [T.SoundOnHierarchy Π 2] : Entailment.Consistent T := + T.consistent_of_sound (Arithmetic.Hierarchy Π 2) (by simp) + +end FirstOrder + +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Basic/Misc.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Basic/Misc.lean new file mode 100644 index 000000000..2f2883ffe --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Basic/Misc.lean @@ -0,0 +1,275 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.LE + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +/-! +# Preperations for arithmetic + +- *NOTE*: + To avoid the duplicate definitions of `Tarski.Structure ℒₒᵣ` for models, + we basically use `ORingStructure`, and generated `standardStructure` instead of + `Tarski.Structure ℒₒᵣ` itself. +-/ + +namespace FFL + +/-- An interpretation of zero, one, addition, multiplication and strict order. -/ +class ORingStructure (α : Type*) extends Zero α, One α, Add α, Mul α, LT α + +instance [Zero α] [One α] [Add α] [Mul α] [LT α] : ORingStructure α where + +namespace ORingStructure + +variable {α : Type*} [ORingStructure α] + +/-- The numeral construction in `FFL.ORingStructure`. -/ +def numeral : ℕ → α + | 0 => 0 + | 1 => 1 + | n + 2 => numeral (n + 1) + 1 + +@[simp] +lemma zero_eq_zero : (numeral 0 : α) = 0 := + rfl + +@[simp] +lemma one_eq_one : (numeral 1 : α) = 1 := + rfl + +end ORingStructure + +@[simp] +lemma Nat.numeral_eq : (n : ℕ) → ORingStructure.numeral n = n + | 0 => rfl + | 1 => rfl + | n + 2 => by simp [ORingStructure.numeral, Nat.numeral_eq (n + 1)] + +namespace FirstOrder + +/-- The Arithmetic Theory construction in `FFL.FirstOrder`. -/ +abbrev ArithmeticTheory := + Theory ℒₒᵣ + +/-- The Arithmetic Semiterm construction in `FFL.FirstOrder`. -/ +abbrev ArithmeticSemiterm (ξ : Type*) (n : ℕ) := + Semiterm ℒₒᵣ ξ n + +/-- The Arithmetic Term construction in `FFL.FirstOrder`. -/ +abbrev ArithmeticTerm (ξ : Type*) := + Term ℒₒᵣ ξ + +/-- The Arithmetic Semiformula construction in `FFL.FirstOrder`. -/ +abbrev ArithmeticSemiformula (ξ : Type*) (n : ℕ) := + Semiformula ℒₒᵣ ξ n + +/-- The Arithmetic Formula construction in `FFL.FirstOrder`. -/ +abbrev ArithmeticFormula (ξ : Type*) := + Formula ℒₒᵣ ξ + +/-- The Arithmetic Semisentence construction in `FFL.FirstOrder`. -/ +abbrev ArithmeticSemisentence (n : ℕ) := + Semisentence ℒₒᵣ n + +/-- The Arithmetic Sentence construction in `FFL.FirstOrder`. -/ +abbrev ArithmeticSentence := + Sentence ℒₒᵣ + +/-- The Arithmetic Semiproposition construction in `FFL.FirstOrder`. -/ +abbrev ArithmeticSemiproposition (n : ℕ) := + Semiproposition ℒₒᵣ n + +/-- The Arithmetic Proposition construction in `FFL.FirstOrder`. -/ +abbrev ArithmeticProposition := + Proposition ℒₒᵣ + +section ToString + +variable {L : Language} [L.ORing] + +variable [ToString ξ] + +/-- The to String ORing construction in `FFL.FirstOrder.Semiterm`. -/ +def Semiterm.toStringORing : ArithmeticSemiterm ξ n → String + | #x => "x_{" ++ toString (n - 1 - (x : ℕ)) ++ "}" + | &x => "a_{" ++ toString x ++ "}" + | func Language.Zero.zero _ => "0" + | func Language.One.one _ => "1" + | func Language.Add.add v => "(" ++ toStringORing (v 0) ++ " + " ++ toStringORing (v 1) ++ ")" + | func Language.Mul.mul v => + "(" ++ toStringORing (v 0) ++ " \\cdot " ++ toStringORing (v 1) ++ ")" + +instance : Repr (ArithmeticSemiterm ξ n) := + ⟨fun t _ ↦ t.toStringORing⟩ + +instance : ToString (ArithmeticSemiterm ξ n) := + ⟨Semiterm.toStringORing⟩ + +/-- The to String ORing construction in `FFL.FirstOrder.Semiformula`. -/ +def Semiformula.toStringORing : ∀ {n}, ArithmeticSemiformula ξ n → String + | _, ⊤ => "\\top" + | _, ⊥ => "\\bot" + | _, rel Language.Eq.eq v => (v 0).toStringORing ++ " = " ++ (v 1).toStringORing + | _, rel Language.LT.lt v => (v 0).toStringORing ++ " < " ++ (v 1).toStringORing + | _, nrel Language.Eq.eq v => (v 0).toStringORing ++ " \\not = " ++ (v 1).toStringORing + | _, nrel Language.LT.lt v => (v 0).toStringORing ++ " \\not < " ++ (v 1).toStringORing + | _, φ ⋏ ψ => "[" ++ φ.toStringORing ++ "]" ++ " \\land " ++ "[" ++ ψ.toStringORing ++ "]" + | _, φ ⋎ ψ => "[" ++ φ.toStringORing ++ "]" ++ " \\lor " ++ "[" ++ ψ.toStringORing ++ "]" + | n, ∀¹ (rel Language.LT.lt v ⇒ₗ φ) => + "(\\forall x_{" ++ toString n ++ "} < " ++ (v 1).toStringORing ++ ") " ++ "[" ++ + φ.toStringORing ++ + "]" + | n, ∃¹ (rel Language.LT.lt v ⋏ φ) => + "(\\exists x_{" ++ toString n ++ "} < " ++ (v 1).toStringORing ++ ") " ++ "[" ++ + φ.toStringORing ++ + "]" + | n, ∀¹ φ => "(\\forall x_{" ++ toString n ++ "}) " ++ "[" ++ φ.toStringORing ++ "]" + | n, ∃¹ φ => "(\\exists x_{" ++ toString n ++ "}) " ++ "[" ++ φ.toStringORing ++ "]" + +instance : Repr (ArithmeticSemiformula ξ n) := + ⟨fun φ _ ↦ φ.toStringORing⟩ + +instance : ToString (ArithmeticSemiformula ξ n) := + ⟨Semiformula.toStringORing⟩ + +end ToString + +namespace Arithmetic + +open Encodable Semiterm.Operator.GödelNumber + +variable {α} [Encodable α] + +instance : Semiterm.Operator.GödelNumber ℒₒᵣ α := + Semiterm.Operator.GödelNumber.ofEncodable + +lemma gödelNumber_def (a : α) : gödelNumber a = Semiterm.Operator.encode ℒₒᵣ a := + rfl + +lemma gödelNumber'_def (a : α) : + (⌜a⌝ : ArithmeticSemiterm ξ n) = Semiterm.Operator.encode ℒₒᵣ a := + rfl + +lemma gödelNumber'_eq_coe_encode (a : α) : + (⌜a⌝ : ArithmeticSemiterm ξ n) = ↑(Encodable.encode a) := + rfl + +@[simp] +lemma encode_encode_eq (a : α) : + (gödelNumber (encode a) : Semiterm.Const ℒₒᵣ) = gödelNumber a := by + simp [Semiterm.Operator.encode, gödelNumber_def] + +@[simp] +lemma rew_gödelNumber' (ω : Rew ℒₒᵣ ξ₁ n₁ ξ₂ n₂) (a : α) : ω ⌜a⌝ = ⌜a⌝ := by + simp [gödelNumber'_def] + +end Arithmetic + +/-! +### Semantics of arithmetic -/ + +/-- Data and laws for ORing in `FFL.FirstOrder.Tarski.Structure`. -/ +class Tarski.Structure.ORing (L : Language) [L.ORing] (M : Type w) [ORingStructure M] + [Tarski.Structure L M] extends Tarski.Structure.Zero L M, Tarski.Structure.One L M, + Tarski.Structure.Add L M, Tarski.Structure.Mul L M, Tarski.Structure.Eq L M, + Tarski.Structure.LT L M + +attribute [instance] Tarski.Structure.ORing.mk + +namespace Tarski +namespace Structure + +open Semiterm Semiformula + +variable [Operator.Zero L] [Operator.One L] [Operator.Add L] {M : Type u} [ORingStructure M] + [Tarski.Structure L M] [Tarski.Structure.Zero L M] [Tarski.Structure.One L M] + [Tarski.Structure.Add L M] + +@[simp] +lemma numeral_eq_numeral : + (z : ℕ) → (Semiterm.Operator.numeral L z).val ![] = (ORingStructure.numeral z : M) + | 0 => by simp [ORingStructure.numeral, Semiterm.Operator.numeral_zero] + | 1 => by simp [ORingStructure.numeral, Semiterm.Operator.numeral_one] + | z + 2 => by + simp [ORingStructure.numeral, Semiterm.Operator.numeral_add_two, Semiterm.Operator.val_comp, + Matrix.fun_eq_vec_two, numeral_eq_numeral (z + 1)] + +end Structure +end Tarski + +namespace Semiformula + +variable {L : Language} [L.LT] [L.Zero] [L.One] [L.Add] + +/-- The ball LTSucc construction in `FFL.FirstOrder.Semiformula`. -/ +def ballLTSucc (t : Semiterm L ξ n) (φ : Semiformula L ξ (n + 1)) : Semiformula L ξ n := + φ.ballLT (‘!!t + 1’) + +/-- The bexs LTSucc construction in `FFL.FirstOrder.Semiformula`. -/ +def bexsLTSucc (t : Semiterm L ξ n) (φ : Semiformula L ξ (n + 1)) : Semiformula L ξ n := + φ.bexsLT (‘!!t + 1’) + +variable {M : Type*} {s : Tarski.Structure L M} [LT M] [One M] [Add M] [Tarski.Structure.LT L M] + [Tarski.Structure.One L M] [Tarski.Structure.Add L M] + +lemma eval_ballLTSucc {φ : Semiformula L ξ (n + 1)} {t : Semiterm L ξ n} {fv bv} : + (φ.ballLTSucc t).Eval (M := M) fv bv ↔ + ∀ x < t.val (M := M) fv bv + 1, φ.Eval (M := M) (x :> fv) bv := + by simp [ballLTSucc, Semiterm.Operator.numeral] + +lemma eval_bexsLTSucc {φ : Semiformula L ξ (n + 1)} {t : Semiterm L ξ n} {fv bv} : + (φ.bexsLTSucc t).Eval (M := M) fv bv ↔ + ∃ x < t.val (M := M) fv bv + 1, φ.Eval (M := M) (x :> fv) bv := + by simp [bexsLTSucc, Semiterm.Operator.numeral] + +end Semiformula + +namespace BinderNotation + +open _root_.Lean Lean PrettyPrinter Delaborator SubExpr + +/-- The «first order formula∀ <⁺ , » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :max "∀ " ident " <⁺ " firstOrderTerm ", " firstOrderFormula:0 : firstOrderFormula + +/-- The «first order formula∃ <⁺ , » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :max "∃ " ident " <⁺ " firstOrderTerm ", " firstOrderFormula:0 : firstOrderFormula + +macro_rules + | `(quoteformula(lit)[$binders* | $fbinders* | ∀ $x <⁺ $t, $φ]) => do + if binders.elem x then + Macro.throwErrorAt x "error: variable is duplicated." + else + let binders' := binders.insertIdx 0 x + `(Semiformula.ballLTSucc quoteterm(lit)[$binders* | $fbinders* | $t] + quoteformula(lit)[$binders'* | $fbinders* | $φ]) + | `(quoteformula(lit)[$binders* | $fbinders* | ∃ $x <⁺ $t, $φ]) => do + if binders.elem x then + Macro.throwErrorAt x "error: variable is duplicated." + else + let binders' := binders.insertIdx 0 x + `(Semiformula.bexsLTSucc quoteterm(lit)[$binders* | $fbinders* | $t] + quoteformula(lit)[$binders'* | $fbinders* | $φ]) + +end BinderNotation + +end FirstOrder + +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Basic/Model.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Basic/Model.lean new file mode 100644 index 000000000..e6e266afc --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Basic/Model.lean @@ -0,0 +1,165 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Basic.Misc + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace FFL +namespace FirstOrder +namespace Arithmetic + +private lemma complete_aux (T : ArithmeticTheory) [𝐄𝐐 ℒₒᵣ ≼ T] (φ : ArithmeticSentence) + (H : + ∀ (M : Type w) [ORingStructure M] [Tarski.Structure ℒₒᵣ M] [Tarski.Structure.ORing ℒₒᵣ M] + [M↓[ℒₒᵣ] ⊧* T], M↓[ℒₒᵣ] ⊧ φ) : + T ⊢ φ := + Theory.Proof.complete <| + consequence_iff_eq.mpr fun M _ _ _ hT ↦ + letI : (Tarski.Structure.Model ℒₒᵣ M)↓[ℒₒᵣ] ⊧* T := + Tarski.Structure.ElementaryEquiv.modelsTheory.mp hT + Tarski.Structure.ElementaryEquiv.models.mpr (H (Tarski.Structure.Model ℒₒᵣ M)) + +open Language + +section semantics + +variable (M : Type*) [ORingStructure M] + +instance standardModel : Tarski.Structure ℒₒᵣ M + where + func := fun _ f ↦ + match f with + | ORing.Func.zero => fun _ ↦ 0 + | ORing.Func.one => fun _ ↦ 1 + | ORing.Func.add => fun v ↦ v 0 + v 1 + | ORing.Func.mul => fun v ↦ v 0 * v 1 + rel := fun _ r ↦ + match r with + | ORing.Rel.eq => fun v ↦ v 0 = v 1 + | ORing.Rel.lt => fun v ↦ v 0 < v 1 + +instance : Tarski.Structure.Eq ℒₒᵣ M where + eq a + b := by + unfold standardModel + simp [Semiformula.Operator.val, Semiformula.Operator.Eq.sentence_eq] + +instance : Tarski.Structure.Zero ℒₒᵣ M := + ⟨rfl⟩ + +instance : Tarski.Structure.One ℒₒᵣ M := + ⟨rfl⟩ + +instance : Tarski.Structure.Add ℒₒᵣ M := + ⟨fun _ _ ↦ rfl⟩ + +instance : Tarski.Structure.Mul ℒₒᵣ M := + ⟨fun _ _ ↦ rfl⟩ + +instance : Tarski.Structure.Eq ℒₒᵣ M := + ⟨fun _ _ ↦ iff_of_eq rfl⟩ + +instance : Tarski.Structure.LT ℒₒᵣ M := + ⟨fun _ _ ↦ iff_of_eq rfl⟩ + +instance : ORing ℒₒᵣ := + ORing.mk + +lemma standardModel_unique' (s : Tarski.Structure ℒₒᵣ M) (hZero : Tarski.Structure.Zero ℒₒᵣ M) + (hOne : Tarski.Structure.One ℒₒᵣ M) (hAdd : Tarski.Structure.Add ℒₒᵣ M) + (hMul : Tarski.Structure.Mul ℒₒᵣ M) (hEq : Tarski.Structure.Eq ℒₒᵣ M) + (hLT : Tarski.Structure.LT ℒₒᵣ M) : s = standardModel M := + Tarski.Structure.ext + (funext₃ fun k f _ ↦ + match k, f with + | _, Language.Zero.zero => by simp [Matrix.empty_eq] + | _, Language.One.one => by simp [Matrix.empty_eq] + | _, Language.Add.add => by simp + | _, Language.Mul.mul => by simp) + (funext₃ fun k r _ => + match k, r with + | _, Language.Eq.eq => by simp + | _, Language.LT.lt => by simp) + +lemma standardModel_unique (s : Tarski.Structure ℒₒᵣ M) [hZero : Tarski.Structure.Zero ℒₒᵣ M] + [hOne : Tarski.Structure.One ℒₒᵣ M] [hAdd : Tarski.Structure.Add ℒₒᵣ M] + [hMul : Tarski.Structure.Mul ℒₒᵣ M] [hEq : Tarski.Structure.Eq ℒₒᵣ M] + [hLT : Tarski.Structure.LT ℒₒᵣ M] : s = standardModel M := + standardModel_unique' M s hZero hOne hAdd hMul hEq hLT + +end semantics + +/-- provable_of_models -/ +lemma complete (T : ArithmeticTheory) [𝐄𝐐 ℒₒᵣ ≼ T] (φ : ArithmeticSentence) + (H : ∀ (M : Type*) [ORingStructure M] [M↓[ℒₒᵣ] ⊧* T], M↓[ℒₒᵣ] ⊧ φ) : T ⊢ φ := + complete_aux T φ fun M _ s _ _ ↦ + by + rcases standardModel_unique M s + exact H M + +lemma provable_iff_of_models_iff {T : ArithmeticTheory} [𝐄𝐐 ℒₒᵣ ≼ T] {n} + {φ ψ : ArithmeticSemisentence n} + (h : ∀ (V : Type) [ORingStructure V] [V↓[ℒₒᵣ] ⊧* T] (e : Fin n → V), V ⊧/e φ ↔ V ⊧/e ψ) : + T ⊢ ∀¹* (φ ⇔ₗ ψ) := by + apply Arithmetic.complete T _ + intro V _ _ + simpa [models_iff] using h V + +lemma models_iff_of_provable_iff {T : ArithmeticTheory} {n} {φ ψ : ArithmeticSemisentence n} + (h : T ⊢ ∀¹* (φ ⇔ₗ ψ)) (V : Type*) [ORingStructure V] [V↓[ℒₒᵣ] ⊧* T] (e : Fin n → V) : + V ⊧/e φ ↔ V ⊧/e ψ := + by + have h' := consequence_iff.mp (Theory.Proof.sound h) V inferInstance + simp only [models_iff, Semiformula.eval_allClosure] at h' + simpa using h' e + +lemma weakerThan_of_models (T S : ArithmeticTheory) [𝐄𝐐 ℒₒᵣ ≼ S] + (H : ∀ (M : Type*) [ORingStructure M] [M↓[ℒₒᵣ] ⊧* S], M↓[ℒₒᵣ] ⊧* T) : T ≼ S := + Entailment.weakerThan_iff.mpr fun h ↦ complete _ _ fun M _ _ ↦ Theory.Proof.sound h (H M) + +lemma equiv_of_models {T S : ArithmeticTheory} [𝐄𝐐 ℒₒᵣ ≼ S] [𝐄𝐐 ℒₒᵣ ≼ T] + (hTS : ∀ (M : Type*) [ORingStructure M] [M↓[ℒₒᵣ] ⊧* S], M↓[ℒₒᵣ] ⊧* T) + (hST : ∀ (M : Type*) [ORingStructure M] [M↓[ℒₒᵣ] ⊧* T], M↓[ℒₒᵣ] ⊧* S) : T ≊ S := + Entailment.Equiv.antisymm ⟨weakerThan_of_models T S hTS, weakerThan_of_models S T hST⟩ + +end Arithmetic + +/-- Data and laws for Sound On in `FFL.FirstOrder.ArithmeticTheory`. -/ +class ArithmeticTheory.SoundOn (T : ArithmeticTheory) (F : ArithmeticSentence → Prop) where + sound : ∀ {σ}, T ⊢ σ → F σ → ℕ↓[ℒₒᵣ] ⊧ σ + +namespace ArithmeticTheory + +variable (T : ArithmeticTheory) (F : ArithmeticSentence → Prop) + +instance [ℕ↓[ℒₒᵣ] ⊧* T] : T.SoundOn F := + ⟨fun b _ ↦ consequence_iff.mp (Theory.Proof.sound b) ℕ inferInstance⟩ + +lemma SoundOn.of_weakerThan (F : ArithmeticSentence → Prop) (T U : ArithmeticTheory) [U ≼ T] + [T.SoundOn F] : U.SoundOn F := + ⟨fun h ↦ SoundOn.sound (Entailment.WeakerThan.pbl (𝓢 := U) (𝓣 := T) h)⟩ + +lemma consistent_of_sound [SoundOn T F] (hF : F ⊥) : Entailment.Consistent T := + Entailment.consistent_iff_unprovable_bot.mpr fun b ↦ SoundOn.sound b hF + +end ArithmeticTheory + +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Basic/Monotone.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Basic/Monotone.lean new file mode 100644 index 000000000..dcd5087a1 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Basic/Monotone.lean @@ -0,0 +1,51 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Basic.Misc + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace FFL +namespace FirstOrder + +namespace Tarski +namespace Structure + +/-- Data and laws for Monotone in `FFL.FirstOrder.Tarski.Structure`. -/ +class Monotone (L : Language) (M : Type*) [LE M] [Tarski.Structure L M] where + monotone : + ∀ {k} (f : L.Func k) (v₁ v₂ : Fin k → M), + (∀ i, v₁ i ≤ v₂ i) → Tarski.Structure.func f v₁ ≤ Tarski.Structure.func f v₂ + +namespace Monotone + +variable {L : Language} {M : Type*} [LE M] [Tarski.Structure L M] [Monotone L M] + +lemma term_monotone (t : Semiterm L ξ n) {fv₁ fv₂ : Fin n → M} {bv₁ bv₂ : ξ → M} + (he : ∀ i, fv₁ i ≤ fv₂ i) (hε : ∀ i, bv₁ i ≤ bv₂ i) : t.val fv₁ bv₁ ≤ t.val fv₂ bv₂ := by + induction t <;> simp [*, Semiterm.val_func, Monotone.monotone] + +end Monotone + +end Structure +end Tarski + +end FirstOrder + +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Basic/StrictHierarchy.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Basic/StrictHierarchy.lean new file mode 100644 index 000000000..ce84c9687 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Basic/StrictHierarchy.lean @@ -0,0 +1,160 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Basic.Hierarchy + +/-! Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# Strict arithmetical hierarchy + +`StrictHierarchy Γ s φ` singles out the prenex `Γ`-formulas of level `s` with a `Δ₀` matrix +beneath alternating quantifier blocks. + +## References + +- [HP98] +-/ + +@[expose] public section + +namespace FFL +namespace FirstOrder +namespace Arithmetic + +variable {L : Language} [L.LT] {ξ : Type*} + +/-- The strict arithmetical hierarchy with explicit quantifier alternations. -/ +inductive StrictHierarchy : Polarity → ℕ → {n : ℕ} → Semiformula L ξ n → Prop + | zero {Γ n} {φ : Semiformula L ξ n} : Hierarchy Σ 0 φ → StrictHierarchy Γ 0 φ + | + ofAlt {Γ s n} {φ : Semiformula L ξ n} : + StrictHierarchy Γ.alt s φ → StrictHierarchy Γ (s + 1) φ + | + exs {s n} {φ : Semiformula L ξ (n + 1)} : + StrictHierarchy Σ (s + 1) φ → StrictHierarchy Σ (s + 1) (∃¹ φ) + | + all {s n} {φ : Semiformula L ξ (n + 1)} : + StrictHierarchy Π (s + 1) φ → StrictHierarchy Π (s + 1) (∀¹ φ) + +namespace StrictHierarchy + +-- Recursive lemmas over `StrictHierarchy` bind `Γ s n φ` in their own signature rather than +-- via `variable`: otherwise the equation compiler cannot generalize them. + +lemma hierarchy {Γ s n} {φ : Semiformula L ξ n} : StrictHierarchy Γ s φ → Hierarchy Γ s φ + | zero h => h.of_zero + | ofAlt h => (hierarchy h).accum _ + | exs h => (hierarchy h).exs + | all h => (hierarchy h).all + +lemma neg {Γ s n} {φ : Semiformula L ξ n} : StrictHierarchy Γ s φ → StrictHierarchy Γ.alt s (∼φ) + | zero h => zero (by exact (Hierarchy.neg h).of_zero) + | ofAlt h => ofAlt (by simpa using neg h) + | exs h => by simpa using (neg h).all + | all h => by simpa using (neg h).exs + +@[simp, grind =] +lemma neg_iff {Γ s n} {φ : Semiformula L ξ n} : + StrictHierarchy Γ s (∼φ) ↔ StrictHierarchy Γ.alt s φ := + ⟨fun h ↦ by simpa using neg h, fun h ↦ by simpa using neg h⟩ + +lemma rew {Γ s n₁ n₂} {ξ₁ ξ₂ : Type*} {φ : Semiformula L ξ₁ n₁} (ω : Rew L ξ₁ n₁ ξ₂ n₂) : + StrictHierarchy Γ s φ → StrictHierarchy Γ s (ω ▹ φ) + | zero h => zero (Hierarchy.rew ω h) + | ofAlt h => ofAlt (rew ω h) + | exs h => by simpa using (rew ω.q h).exs + | all h => by simpa using (rew ω.q h).all + +lemma of_rew {Γ s n₂} {ξ₂ : Type*} {ψ : Semiformula L ξ₂ n₂} : + StrictHierarchy Γ s ψ → + ∀ {ξ₁ : Type*} {n₁ : ℕ} {ω : Rew L ξ₁ n₁ ξ₂ n₂} {φ : Semiformula L ξ₁ n₁}, + ω ▹ φ = ψ → StrictHierarchy Γ s φ + | zero h => + fun e ↦ zero (by rw [← e] at h; simpa using h) + | ofAlt h => fun e ↦ ofAlt (of_rew h e) + | exs h => fun e ↦ by + rcases (Semiformula.eq_exs_iff _).mp e with ⟨φ', hφ', rfl⟩; + exact exs (of_rew h hφ'); + | all h => fun e ↦ by + rcases (Semiformula.eq_all_iff _).mp e with ⟨φ', hφ', rfl⟩; + exact all (of_rew h hφ'); + +section +variable {Γ : Polarity} {s n₁ n₂ : ℕ} {ξ₁ ξ₂ : Type*} +variable {ω : Rew L ξ₁ n₁ ξ₂ n₂} {φ : Semiformula L ξ₁ n₁} + +@[simp] +lemma rew_iff : StrictHierarchy Γ s (ω ▹ φ) ↔ StrictHierarchy Γ s φ := + ⟨fun h ↦ of_rew h rfl, rew ω⟩ + +end + +section +variable {Γ : Polarity} {s n : ℕ} + +lemma toPrenex {j} {φ : Semiformula L ξ (n + s)} (h : StrictHierarchy (Γ.altItr s) j φ) : + StrictHierarchy Γ (j + s) (φ.toPrenex Γ s) := by + induction s generalizing n j with + | zero => simpa using h; + | succ s ih => + rw [Polarity.altItr_succ] at h; + change StrictHierarchy Γ (j + (s + 1)) (Polarity.quantItr Γ (s + 1) φ); + rw [Polarity.quantItr_succ', show j + (s + 1) = j + 1 + s by omega]; + rcases hΓ : Γ.altItr s with _ | _; · apply ih; rw [hΓ] at h ⊢; exact (ofAlt h).exs; + · apply ih; rw [hΓ] at h ⊢; exact (ofAlt h).all; + +lemma toPrenex_of_deltaZero {φ : Semiformula L ξ (n + s)} (h : Hierarchy Σ 0 φ) : + StrictHierarchy Γ s (φ.toPrenex Γ s) := by simpa using toPrenex (Γ := Γ) (zero h) + +lemma mono {φ : Semiformula L ξ n} (h : StrictHierarchy Γ s φ) (hs : s ≤ s') : + StrictHierarchy Γ s' φ := by + induction h generalizing s' with + | @zero Γ₀ n₀ φ₀ h => + have key : ∀ t Γ', StrictHierarchy Γ' t φ₀ := by + intro t; + induction t with + | zero => + intro Γ'; exact zero h; + | succ t ih => + intro Γ'; exact ofAlt (ih Γ'.alt); + exact key s' Γ₀; + | @ofAlt Γ₀ s₀ n₀ φ₀ h ih => + obtain ⟨t, rfl⟩ := Nat.exists_eq_succ_of_ne_zero (show s' ≠ 0 by omega); + exact ofAlt (ih (s' := t) (by omega)); + | @exs s₀ n₀ φ₀ h ih => + obtain ⟨t, rfl⟩ := Nat.exists_eq_succ_of_ne_zero (show s' ≠ 0 by omega); + exact exs (ih (s' := t + 1) (by omega)); + | @all s₀ n₀ φ₀ h ih => + obtain ⟨t, rfl⟩ := Nat.exists_eq_succ_of_ne_zero (show s' ≠ 0 by omega); + exact all (ih (s' := t + 1) (by omega)); + +lemma strict_mono {φ : Semiformula L ξ n} (h : StrictHierarchy Γ s φ) (Γ') {s'} (hs : s < s') : + StrictHierarchy Γ' s' φ := + by + obtain ⟨t, rfl⟩ : ∃ t, s' = t + 1 := ⟨s' - 1, by omega⟩; + rcases Γ' with _ | _ <;> rcases Γ with _ | _; · exact h.mono (by omega); + · exact ofAlt (h.mono (by omega)); + · exact ofAlt (h.mono (by omega)); + · exact h.mono (by omega); + +end + +end StrictHierarchy + +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/DerivabilityCondition/D1.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/DerivabilityCondition/D1.lean new file mode 100644 index 000000000..307c3a5f3 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/DerivabilityCondition/D1.lean @@ -0,0 +1,71 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +/-! +# Hilbert-Bernays-Löb derivability condition $\mathbf{D1}$ and soundness of internal provability. +-/ + +namespace FFL +namespace FirstOrder +namespace Arithmetic +namespace Bootstrapping + +open FirstOrder + +variable {V : Type*} [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +variable {L : Language} [L.Encodable] [L.LORDefinable] + +variable {T : Theory L} [T.Δ₁] + +open _root_.Classical in +lemma derivable_quote {Γ : Finset (Proposition L)} (d : T ⟹₂Γ) : Derivable T (⌜Γ⌝ : V) := + ⟨⌜d⌝, by + simpa [Semiformula.quote_def] using! (⌜d⌝ : Theory.internalize V T ⊢!ᵈᵉʳ ⌜Γ⌝).derivationOf⟩ + +/-- Hilbert–Bernays provability condition D1 -/ +theorem internalize_provability {φ} : T ⊢ φ → Provable T (⌜φ⌝ : V) := fun h ↦ by + classical + simpa using! derivable_quote (V := V) (provable_iff_derivable2.mp h).some + +theorem internal_provable_of_outer_provable {φ} : T ⊢ φ → T.internalize V ⊢ ⌜φ⌝ := fun h ↦ by + classical + simpa [TProvable.iff_provable] using! internalize_provability (V := V) h + +@[simp] +lemma Provable.complete {φ : Sentence L} : T.internalize ℕ ⊢ ⌜φ⌝ ↔ T ⊢ φ := + by + classical + exact ⟨by simpa [TProvable.iff_provable] using! Provable.sound, + internal_provable_of_outer_provable⟩ + +@[simp] +lemma provable_iff_provable {T : Theory L} [T.Δ₁] {φ : Sentence L} : + Provable T (⌜φ⌝ : ℕ) ↔ T ⊢ φ := by + classical + simpa [TProvable.iff_provable] using! Provable.complete + +end Bootstrapping +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/DerivabilityCondition/D2.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/DerivabilityCondition/D2.lean new file mode 100644 index 000000000..1e27a8601 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/DerivabilityCondition/D2.lean @@ -0,0 +1,65 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +/-! +# Hilbert-Bernays-Löb derivability condition $\mathbf{D2}$ +-/ + +namespace FFL +namespace FirstOrder +namespace Arithmetic +namespace Bootstrapping + +open FirstOrder + +variable {V : Type*} [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +variable {L : Language} [L.Encodable] [L.LORDefinable] + +variable (T : Theory L) [T.Δ₁] + +/-- Hilbert–Bernays provability condition D2 -/ +theorem modus_ponens {φ ψ : Proposition L} (hφψ : Provable T (⌜φ ⇒ₗ ψ⌝ : V)) + (hφ : Provable T (⌜φ⌝ : V)) : Provable T (⌜ψ⌝ : V) := + by + apply (tprovable_tquote_iff_provable_quote (L := L)).mp + have hφψ : Theory.internalize V T ⊢ ⌜φ⌝ ⇒ₗ ⌜ψ⌝ := by + simpa using (tprovable_tquote_iff_provable_quote (L := L)).mpr hφψ + have hφ : Theory.internalize V T ⊢ ⌜φ⌝ := + (tprovable_tquote_iff_provable_quote (L := L)).mpr hφ + exact hφψ⨀hφ + +theorem modus_ponens_sentence {σ τ : Sentence L} (hστ : Provable T (⌜σ ⇒ₗ τ⌝ : V)) + (hσ : Provable T (⌜σ⌝ : V)) : Provable T (⌜τ⌝ : V) := + by + apply (tprovable_tquote_iff_provable_quote (L := L)).mp + have hστ : Theory.internalize V T ⊢ ⌜σ⌝ ⇒ₗ ⌜τ⌝ := by + simpa using! (tprovable_tquote_iff_provable_quote (L := L)).mpr hστ + have hσ : Theory.internalize V T ⊢ ⌜σ⌝ := + (tprovable_tquote_iff_provable_quote (L := L)).mpr hσ + exact hστ⨀hσ + +end Bootstrapping +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/DerivabilityCondition/D3.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/DerivabilityCondition/D3.lean new file mode 100644 index 000000000..b856bd486 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/DerivabilityCondition/D3.lean @@ -0,0 +1,207 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.DerivabilityCondition.PeanoMinus + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +/-! +# Hilbert-Bernays-Löb derivability condition $\mathbf{D3}$ and formalized $\Sigma_1$-completeness +-/ + +namespace FFL +namespace FirstOrder +namespace Arithmetic +namespace Bootstrapping +namespace ObjectArithmetic + + + +open FFL.Entailment FFL.Entailment.FiniteContext + +variable {V : Type*} [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +local prefix:max "#'" => Semiterm.bvar (V := V) (L := ℒₒᵣ) + +local prefix:max "&'" => Semiterm.fvar (V := V) (L := ℒₒᵣ) + +local postfix:max "↑ᵗ" => Semiterm.shift + +local postfix:max "↑ᶠ" => Semiformula.shift + +local infix:40 " ↤ᵗ " => Semiterm.subst + +local infix:40 " ↤ᶠ " => Semiformula.subst + +variable (T : ArithmeticTheory) [Theory.Δ₁ T] [𝐏𝐀⁻ ≼ T] + +variable {T} + +lemma eq_comm {t₁ t₂ : Term V ℒₒᵣ} : T.internalize V ⊢ t₁ ≐ t₂ → T.internalize V ⊢ t₂ ≐ t₁ := + fun h ↦ eq_symm T _ _⨀h + +/-- +The to Num Vec construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic`. -/ +noncomputable abbrev toNumVec (w : Fin n → V) : SemitermVec V ℒₒᵣ n k := + ((ℕᵗ·)↗ w) + +variable (T) + +theorem term_complete {n : ℕ} (t : FirstOrder.ClosedSemiterm ℒₒᵣ n) (w : Fin n → V) : + T.internalize V ⊢ (toNumVec w ↤ᵗ ⌜t⌝) ≐ ℕᵗ(t.valb w) := + match t with + | #z => by simp + | &x => Empty.elim x + | .func Language.Zero.zero v => by simp + | .func Language.One.one v => by simp + | .func Language.Add.add v => + by + suffices + T.internalize V ⊢ + (toNumVec w ↤ᵗ ⌜v 0⌝) + (toNumVec w ↤ᵗ ⌜v 1⌝) ≐ ℕᵗ((v 0).valb w + (v 1).valb w) + by simpa [Rew.func, Semiterm.val_func] + have ih : + T.internalize V ⊢ + (toNumVec w ↤ᵗ ⌜v 0⌝) + (toNumVec w ↤ᵗ ⌜v 1⌝) ≐ ℕᵗ((v 0).valb w) + ℕᵗ((v 1).valb w) := + subst_add_eq_add T _ _ _ _⨀term_complete (v 0) w⨀term_complete (v 1) w + have : + T.internalize V ⊢ ℕᵗ((v 0).valb w) + ℕᵗ((v 1).valb w) ≐ ℕᵗ((v 0).valb w + (v 1).valb w) := + numeral_add T _ _ + exact eq_trans ih this + | .func Language.Mul.mul v => + by + suffices + T.internalize V ⊢ + (toNumVec w ↤ᵗ ⌜v 0⌝) * (toNumVec w ↤ᵗ ⌜v 1⌝) ≐ ℕᵗ((v 0).valb w * (v 1).valb w) + by simpa [Rew.func, Semiterm.val_func] + have ih : + T.internalize V ⊢ + (toNumVec w ↤ᵗ ⌜v 0⌝) * (toNumVec w ↤ᵗ ⌜v 1⌝) ≐ ℕᵗ((v 0).valb w) * ℕᵗ((v 1).valb w) := + subst_mul_eq_mul T _ _ _ _⨀term_complete (v 0) w⨀term_complete (v 1) w + have : + T.internalize V ⊢ ℕᵗ((v 0).valb w) * ℕᵗ((v 1).valb w) ≐ ℕᵗ((v 0).valb w * (v 1).valb w) := + numeral_mul T _ _ + exact eq_trans ih this + +open FirstOrder.Arithmetic + +theorem bold_sigma_one_complete {n} {φ : ArithmeticSemisentence n} (hp : Hierarchy Σ 1 φ) {w} : + V ⊧/w φ → T.internalize V ⊢ (toNumVec w ↤ᶠ ⌜φ⌝) := + by + revert w + apply sigma₁_induction' hp + case hVerum => intro n; simp + case hFalsum => intro n; simp + case hEQ => + intro n t₁ t₂ w h + suffices T.internalize V ⊢ (toNumVec w ↤ᵗ ⌜t₁⌝) ≐ (toNumVec w ↤ᵗ ⌜t₂⌝) by + simpa [Sentence.typed_quote_def] + have : t₁.valb w = t₂.valb w := by simpa using h + have h₀ : T.internalize V ⊢ ℕᵗ(t₁.valb w) ≐ ℕᵗ(t₂.valb w) := by simp [this] + have h₁ : T.internalize V ⊢ (toNumVec w ↤ᵗ ⌜t₁⌝) ≐ ℕᵗ(t₁.valb w) := term_complete T t₁ w + have h₂ : T.internalize V ⊢ (toNumVec w ↤ᵗ ⌜t₂⌝) ≐ ℕᵗ(t₂.valb w) := term_complete T t₂ w + exact eq_trans (eq_trans h₁ h₀) (eq_comm h₂) + case hNEQ => + intro n t₁ t₂ w h + suffices T.internalize V ⊢ (toNumVec w ↤ᵗ ⌜t₁⌝) ≉ (toNumVec w ↤ᵗ ⌜t₂⌝) by + simpa [Sentence.typed_quote_def] + have : t₁.valb w ≠ t₂.valb w := by simpa using h + have h₀ : T.internalize V ⊢ ℕᵗ(t₁.valb w) ≉ ℕᵗ(t₂.valb w) := by + simpa using numeral_ne T this + have h₁ : T.internalize V ⊢ (toNumVec w ↤ᵗ ⌜t₁⌝) ≐ ℕᵗ(t₁.valb w) := term_complete T t₁ w + have h₂ : T.internalize V ⊢ (toNumVec w ↤ᵗ ⌜t₂⌝) ≐ ℕᵗ(t₂.valb w) := term_complete T t₂ w + exact subst_ne T _ _ _ _⨀eq_comm h₁⨀eq_comm h₂⨀h₀ + case hLT => + intro n t₁ t₂ w h + suffices T.internalize V ⊢ (toNumVec w ↤ᵗ ⌜t₁⌝) <' (toNumVec w ↤ᵗ ⌜t₂⌝) by + simpa [Sentence.typed_quote_def] + have : t₁.valb w < t₂.valb w := by simpa using h + have h₀ : T.internalize V ⊢ ℕᵗ(t₁.valb w) <' ℕᵗ(t₂.valb w) := by + simpa using numeral_lt T this + have h₁ : T.internalize V ⊢ (toNumVec w ↤ᵗ ⌜t₁⌝) ≐ ℕᵗ(t₁.valb w) := term_complete T t₁ w + have h₂ : T.internalize V ⊢ (toNumVec w ↤ᵗ ⌜t₂⌝) ≐ ℕᵗ(t₂.valb w) := term_complete T t₂ w + exact subst_lt T _ _ _ _⨀eq_comm h₁⨀eq_comm h₂⨀h₀ + case hNLT => + intro n t₁ t₂ w h + suffices T.internalize V ⊢ ((toNumVec w ↤ᵗ ⌜t₁⌝) ≮' (toNumVec w ↤ᵗ ⌜t₂⌝)) by + simpa [Sentence.typed_quote_def] + have : t₁.valb w ≥ t₂.valb w := by simpa using h + have h₀ : T.internalize V ⊢ ℕᵗ(t₁.valb w) ≮' ℕᵗ(t₂.valb w) := by + simpa using numeral_nlt T this + have h₁ : T.internalize V ⊢ (toNumVec w ↤ᵗ ⌜t₁⌝) ≐ ℕᵗ(t₁.valb w) := term_complete T t₁ w + have h₂ : T.internalize V ⊢ (toNumVec w ↤ᵗ ⌜t₂⌝) ≐ ℕᵗ(t₂.valb w) := term_complete T t₂ w + exact subst_nlt T _ _ _ _⨀eq_comm h₁⨀eq_comm h₂⨀h₀ + case hAnd => + intro n φ ψ _ _ ihφ ihψ w h + have H : V ⊧/w φ ∧ V ⊧/w ψ := by simpa using h + simpa using K_intro (ihφ H.1) (ihψ H.2) + case hOr => + intro n φ ψ _ _ ihφ ihψ w h + suffices T.internalize V ⊢ (toNumVec w ↤ᶠ ⌜φ⌝) ⋎ (toNumVec w ↤ᶠ ⌜ψ⌝) by simpa + have : V ⊧/w φ ∨ V ⊧/w ψ := by simpa using h + rcases this with (h | h) + · apply A_intro_left (ihφ h) + · apply A_intro_right (ihψ h) + case hBall => + intro n t φ _ ih w h + have h : ∀ i < t.valb w, V ⊧/(i :> w) φ := by simpa using h + suffices T.internalize V ⊢ ((toNumVec w).q ↤ᶠ ⌜φ⌝).ball (toNumVec w ↤ᵗ ⌜t⌝) by + simpa [Semiterm.empty_typed_quote_def, ← Rew.emb_bShift_term, Semiformula.ball, ball, + Semiformula.imp_def] + have : T.internalize V ⊢ ((toNumVec w).q ↤ᶠ ⌜φ⌝).ball ℕᵗ(t.valb w) := + by + apply ball_intro + intro i hi + suffices T.internalize V ⊢ (toNumVec (i :> w) ↤ᶠ ⌜φ⌝) by + simpa [Semiformula.substs_substs, Matrix.vecMap_vecMap_comp'] + exact ih (h i hi) + exact ball_replace T ((toNumVec w).q ↤ᶠ ⌜φ⌝) _ _⨀(eq_comm <| term_complete T t w)⨀this + case hExs => + intro n φ hφ ih w hφ + have : ∃ a, V ⊧/(a :> w) φ := by simpa using hφ + rcases this with ⟨i, hφ⟩ + suffices T.internalize V ⊢ ∃¹ ((toNumVec w).q ↤ᶠ ⌜φ⌝) by simpa + apply TProof.exsProof (ℕᵗi) + suffices T.internalize V ⊢ (toNumVec (i :> w) ↤ᶠ ⌜φ⌝) by + simpa [Semiformula.substs_substs, Matrix.vecMap_vecMap_comp'] + exact ih hφ + +theorem sigma_one_provable_of_models {σ : ArithmeticSentence} (hσ : Hierarchy Σ 1 σ) : + V↓[ℒₒᵣ] ⊧ σ → T.internalize V ⊢ ⌜σ⌝ := by + intro h + have : T.internalize V ⊢ (toNumVec ![] ↤ᶠ ⌜σ⌝) := + bold_sigma_one_complete T hσ (by simpa [models_iff] using h) + simpa using this + +/-- Hilbert–Bernays provability condition D3 -/ +theorem sigma_one_complete {σ : ArithmeticSentence} (hσ : Hierarchy Σ 1 σ) : + V↓[ℒₒᵣ] ⊧ σ → Provable T (⌜σ⌝ : V) := fun h ↦ by + simpa [tprovable_iff_provable] using! + Bootstrapping.ObjectArithmetic.sigma_one_provable_of_models T hσ h + +theorem provable_internalize {σ : ArithmeticSentence} : + Provable T (⌜σ⌝ : V) → Provable T (⌜provabilityPred T σ⌝ : V) := by + simpa [models_iff] using + sigma_one_complete (V := V) (T := T) (σ := provabilityPred T σ) (by simp) + +end ObjectArithmetic +end Bootstrapping +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/DerivabilityCondition/EquationalTheory.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/DerivabilityCondition/EquationalTheory.lean new file mode 100644 index 000000000..2510d0d56 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/DerivabilityCondition/EquationalTheory.lean @@ -0,0 +1,583 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.Meta.ClProver +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Basic.Model +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.DerivabilityCondition.D1 + +/-! Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section +/-! +# Bootstrapping theory of equality +-/ + +namespace FFL +namespace FirstOrder +namespace Arithmetic +namespace Bootstrapping + +open _root_.PointwiseComposition.FFL.FirstOrder.Entailment + +variable {V : Type*} [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +namespace ObjectArithmetic + +-- `Arithmetic` is intentionally re-opened here even though the ambient namespace +-- already contains it; renaming would break the widely-used public API +-- (`Bootstrapping.ObjectArithmetic.*`). Suppress the new dupNamespace linter for the +-- declarations in this namespace (the option is scoped by `namespace`/`end` and +-- reverts automatically at `end Bootstrapping.ObjectArithmetic`). + +local prefix:max "#'" => Semiterm.bvar (V := V) (L := ℒₒᵣ) + +local prefix:max "&'" => Semiterm.fvar (V := V) (L := ℒₒᵣ) + +local postfix:max "↑ᵗ" => Semiterm.shift + +local postfix:max "↑ᶠ" => Semiformula.shift + +variable (T : ArithmeticTheory) [Theory.Δ₁ T] [𝐄𝐐 _ ≼ T] + +open _root_.PointwiseComposition.FFL.FirstOrder.Entailment Entailment.FiniteContext + _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.Bootstrapping.Semiformula + +@[simp] lemma eq_refl (t : Term V ℒₒᵣ) : T.internalize V ⊢ t ≐ t := by + have : T ⊢ “∀ x, x = x” := complete.{0} T _ fun (M : Type) _ _ ↦ by simp [models_iff] + have : T.internalize V ⊢ ∀¹ (#'0 ≐ #'0) := by + simpa using! internal_provable_of_outer_provable this + simpa using TProof.specializeProof this t + +@[simp] lemma eq_symm (t u : Term V ℒₒᵣ) : T.internalize V ⊢ (t ≐ u) ⇒ₗ (u ≐ t) := by + have : T ⊢ “∀ x y, x = y → y = x” := complete.{0} T _ fun (M : Type) _ _ ↦ by simp [models_iff] + have : T.internalize V ⊢ ∀¹ ∀¹ ((#'1 ≐ #'0) ⇒ₗ (#'0 ≐ #'1)) := by + simpa using! internal_provable_of_outer_provable this + simpa using TProof.specialize₂Proof this u t + +@[simp] lemma ne_symm (t u : Term V ℒₒᵣ) : T.internalize V ⊢ (t ≉ u) ⇒ₗ (u ≉ t) := by + have : T ⊢ “∀ x y, x ≠ y → y ≠ x” := complete.{0} T _ fun (M : Type) _ _ ↦ by + simp [models_iff, ne_comm] + have : T.internalize V ⊢ ∀¹ ∀¹ ((#'1 ≉ #'0) ⇒ₗ (#'0 ≉ #'1)) := by + simpa using internal_provable_of_outer_provable (V := V) this + simpa using TProof.specialize₂Proof this u t + +@[simp] lemma eq_uniform_trans (t₁ t₂ t₃ : Term V ℒₒᵣ) : T.internalize V ⊢ (t₁ ≐ t₂) ⇒ₗ (t₂ ≐ + t₃) ⇒ₗ (t₁ ≐ t₃) := by + have : T ⊢ “∀ x y z, x = y → y = z → x = z” := complete.{0} T _ fun (M : Type) _ _ ↦ by simp + [models_iff] + have : T.internalize V ⊢ ∀¹ ∀¹ ∀¹ ((#'2 ≐ #'1) ⇒ₗ (#'1 ≐ #'0) ⇒ₗ (#'2 ≐ #'0)) := by + simpa using! internal_provable_of_outer_provable this + simpa using TProof.specialize₃Proof this t₃ t₂ t₁ + + + +variable {T} + +lemma eq_comm_ctx {t u : Term V ℒₒᵣ} : + Γ ⊢[T.internalize V] t ≐ u → Γ ⊢[T.internalize V] u ≐ t := fun b ↦ of' (eq_symm T t u)⨀b + +lemma eq_trans {t₁ t₂ t₃ : Term V ℒₒᵣ} : + T.internalize V ⊢ t₁ ≐ t₂ → T.internalize V ⊢ t₂ ≐ t₃ → T.internalize V ⊢ t₁ ≐ t₃ := + fun h₁ h₂ ↦ eq_uniform_trans T t₁ t₂ t₃⨀h₁⨀h₂ + +variable (T) + +section replace + +open FFL.Entailment + +lemma subst_eq (t₁ t₂ u₁ u₂ : Term V ℒₒᵣ) : T.internalize V ⊢ (t₁ ≐ t₂) ⇒ₗ (u₁ ≐ u₂) ⇒ₗ (t₁ ≐ + u₁) ⇒ₗ (t₂ ≐ u₂) := by + have : T ⊢ “∀ x₁ x₂ y₁ y₂, x₁ = x₂ → y₁ = y₂ → x₁ = y₁ → x₂ = y₂” := complete.{0} T _ fun (M : + Type) _ _ ↦ by simp [models_iff] + have := by simpa using internal_provable_of_outer_provable this (V := V) + simpa using TProof.specialize₄Proof this u₂ u₁ t₂ t₁ + + + +lemma subst_lt (t₁ t₂ u₁ u₂ : Term V ℒₒᵣ) : T.internalize V ⊢ (t₁ ≐ t₂) ⇒ₗ (u₁ ≐ u₂) ⇒ₗ (t₁ <' + u₁) ⇒ₗ (t₂ <' u₂) := by + have : T ⊢ “∀ x₁ x₂ y₁ y₂, x₁ = x₂ → y₁ = y₂ → x₁ < y₁ → x₂ < y₂” := complete.{0} T _ fun (M : + Type) _ _ ↦ by + simpa [models_iff] using fun a b c e h ↦ e ▸ h + have := by simpa using internal_provable_of_outer_provable this (V := V) + simpa using TProof.specialize₄Proof this u₂ u₁ t₂ t₁ + + + +lemma subst_ne (t₁ t₂ u₁ u₂ : Term V ℒₒᵣ) : T.internalize V ⊢ (t₁ ≐ t₂) ⇒ₗ (u₁ ≐ u₂) ⇒ₗ (t₁ ≉ + u₁) ⇒ₗ (t₂ ≉ u₂) := by + have : T ⊢ “∀ x₁ x₂ y₁ y₂, x₁ = x₂ → y₁ = y₂ → x₁ ≠ y₁ → x₂ ≠ y₂” := complete.{0} T _ fun (M : + Type) _ _ ↦ by + simpa [models_iff] using fun a b c e h ↦ e ▸ h + have := by simpa using internal_provable_of_outer_provable this (V := V) + simpa using TProof.specialize₄Proof this u₂ u₁ t₂ t₁ + + + +lemma subst_nlt (t₁ t₂ u₁ u₂ : Term V ℒₒᵣ) : T.internalize V ⊢ (t₁ ≐ t₂) ⇒ₗ (u₁ ≐ u₂) ⇒ₗ (t₁ ≮' + u₁) ⇒ₗ (t₂ ≮' u₂) := by + have : T ⊢ “∀ x₁ x₂ y₁ y₂, x₁ = x₂ → y₁ = y₂ → x₁ ≮ y₁ → x₂ ≮ y₂” := complete.{0} T _ fun (M : + Type) _ _ ↦ by + simpa [models_iff] using fun a b c e h ↦ e ▸ h + have := by simpa using internal_provable_of_outer_provable this (V := V) + simpa using TProof.specialize₄Proof this u₂ u₁ t₂ t₁ + + + +lemma subst_add_eq_add (t₁ t₂ u₁ u₂ : Term V ℒₒᵣ) : T.internalize V ⊢ (t₁ ≐ t₂) ⇒ₗ (u₁ ≐ u₂) ⇒ₗ + (t₁ + u₁ ≐ t₂ + u₂) := by + have : T ⊢ “∀ x₁ x₂ y₁ y₂, x₁ = x₂ → y₁ = y₂ → x₁ + y₁ = x₂ + y₂” := complete.{0} T _ fun (M : + Type) _ _ ↦ by + simpa [models_iff] using fun a b c e ↦ by simp [e] + have := by simpa using internal_provable_of_outer_provable this (V := V) + simpa using TProof.specialize₄Proof this u₂ u₁ t₂ t₁ + + + +lemma subst_mul_eq_mul (t₁ t₂ u₁ u₂ : Term V ℒₒᵣ) : T.internalize V ⊢ (t₁ ≐ t₂) ⇒ₗ (u₁ ≐ u₂) ⇒ₗ + (t₁ * u₁ ≐ t₂ * u₂) := by + have : T ⊢ “∀ x₁ x₂ y₁ y₂, x₁ = x₂ → y₁ = y₂ → x₁ * y₁ = x₂ * y₂” := complete.{0} T _ fun (M : + Type) _ _ ↦ by + simpa [models_iff] using fun a b c e ↦ by simp [e] + have := by simpa using internal_provable_of_outer_provable this (V := V) + simpa using TProof.specialize₄Proof this u₂ u₁ t₂ t₁ + + + +lemma vec2_eq {v : V} (h : len v = 2) : ?[v.[0], v.[1]] = v := + nth_ext' 2 (by simp [one_add_one_eq_two]) h + (by + intro i hi + have : i = 0 ∨ i = 1 := le_one_iff_eq_zero_or_one.mp (lt_two_iff_le_one.mp hi) + rcases this with (rfl | rfl) <;> simp) + +lemma term_replace_aux (t : V) : + IsSemiterm ℒₒᵣ 1 t → + Provable T (^∀ ^∀ imp ℒₒᵣ (^#1 ^= ^#0) (termSubst ℒₒᵣ (^#1 ∷ 0) t ^= termSubst ℒₒᵣ (^#0 ∷ 0) + t)) := by + apply IsSemiterm.sigma1_induction + · definability + case hfunc => + intro k F v hF hv ih + rcases isFunc_iff_LOR.mp hF with (⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩) + · rcases show v = 0 by simpa using hv + suffices + T.internalize V ⊢ ∀¹ ∀¹ ((#'1 ≐ #'0) ⇒ₗ ((typedNumeral 0).subst ![#'1] ≐ (typedNumeral + 0).subst ![#'0])) by + have := (tprovable_iff_provable (T := T)).mp this + simpa [-subst_numeral, val_all, Bootstrapping.ObjectArithmetic.coe_zero_eq] using this + suffices + T.internalize V ⊢ ∀¹ ∀¹ ((#'1 ≐ #'0) ⇒ₗ (typedNumeral 0 ≐ typedNumeral 0)) by simpa + suffices T.internalize V ⊢ (&'1 ≐ &'0) ⇒ₗ (typedNumeral 0 ≐ typedNumeral 0) by + apply TProof.all₂Proof; simpa [Semiformula.free] + apply Entailment.dhyp (eq_refl _ _) + · rcases show v = 0 by simpa using hv + suffices + T.internalize V ⊢ ∀¹ ∀¹ ((#'1 ≐ #'0) ⇒ₗ ((typedNumeral 1).subst ![#'1] ≐ (typedNumeral + 1).subst ![#'0])) by + have := (tprovable_iff_provable (T := T)).mp this + simpa [-subst_numeral, val_all, Bootstrapping.ObjectArithmetic.coe_one_eq] using this + suffices + T.internalize V ⊢ ∀¹ ∀¹ ((#'1 ≐ #'0) ⇒ₗ (typedNumeral 1 ≐ typedNumeral 1)) by simpa + suffices T.internalize V ⊢ (&'1 ≐ &'0) ⇒ₗ (typedNumeral 1 ≐ typedNumeral 1) by + apply TProof.all₂Proof; simpa [Semiformula.free] + apply Entailment.dhyp (eq_refl _ _) + · let t : Semiterm V ℒₒᵣ 1 := ⟨v.[0], by simpa using hv.nth (by simp)⟩ + let u : Semiterm V ℒₒᵣ 1 := ⟨v.[1], by simpa using hv.nth (by simp)⟩ + have veq : v = ?[t.val, u.val] := by simp [t, u, vec2_eq hv.lh] + suffices + T.internalize V ⊢ ∀¹ ∀¹ ((#'1 ≐ #'0) ⇒ₗ ((t + u).subst ![#'1] ≐ (t + u).subst ![#'0])) by + have := (tprovable_iff_provable (T := T)).mp this + rw [veq] + simpa [-subst_add, val_all] using! this + let Γ : List (Formula V ℒₒᵣ) := [&'1 ≐ &'0] + suffices + Γ ⊢[T.internalize V] t↑ᵗ↑ᵗ.subst ![&'1] + u↑ᵗ↑ᵗ.subst ![&'1] ≐ t↑ᵗ↑ᵗ.subst ![&'0] + + u↑ᵗ↑ᵗ.subst ![&'0] by + apply TProof.all₂Proof; simpa [Semiformula.free, SemitermVec.q, Semiterm.shift_substs, + Semiterm.substs_substs] + have iht : T.internalize V ⊢ ∀¹ ∀¹ ((#'1 ≐ #'0) ⇒ₗ (t.subst ![#'1] ≐ t.subst ![#'0])) := by + apply (tprovable_iff_provable (T := T)).mpr + simpa [t] using ih 0 (by simp) + have ihu : T.internalize V ⊢ ∀¹ ∀¹ ((#'1 ≐ #'0) ⇒ₗ (u.subst ![#'1] ≐ u.subst ![#'0])) := by + apply (tprovable_iff_provable (T := T)).mpr + simpa [u] using ih 1 (by simp) + have iht : Γ ⊢[T.internalize V] (t↑ᵗ↑ᵗ.subst ![&'1] ≐ t↑ᵗ↑ᵗ.subst ![&'0]) := by + have := TProof.specialize₂ShiftProof iht &'0 &'1 + simpa [Semiterm.shift_substs, Semiterm.substs_substs] using! this + have ihu : Γ ⊢[T.internalize V] (u↑ᵗ↑ᵗ.subst ![&'1] ≐ u↑ᵗ↑ᵗ.subst ![&'0]) := by + have := TProof.specialize₂ShiftProof ihu &'0 &'1 + simpa [Semiterm.shift_substs, Semiterm.substs_substs] using! this + have := subst_add_eq_add T (t↑ᵗ↑ᵗ.subst ![&'1]) (t↑ᵗ↑ᵗ.subst ![&'0]) + (u↑ᵗ↑ᵗ.subst ![&'1]) (u↑ᵗ↑ᵗ.subst ![&'0]) + exact of' this ⨀ iht ⨀ ihu + · let t : Semiterm V ℒₒᵣ 1 := ⟨v.[0], by simpa using hv.nth (by simp)⟩ + let u : Semiterm V ℒₒᵣ 1 := ⟨v.[1], by simpa using hv.nth (by simp)⟩ + have veq : v = ?[t.val, u.val] := by simp [t, u, vec2_eq hv.lh] + suffices + T.internalize V ⊢ ∀¹ ∀¹ ((#'1 ≐ #'0) ⇒ₗ ((t * u).subst ![#'1] ≐ (t * u).subst ![#'0])) by + have := (tprovable_iff_provable (T := T)).mp this + rw [veq] + simpa [-subst_mul, val_all] using! this + let Γ : List (Formula V ℒₒᵣ) := [&'1 ≐ &'0] + suffices + Γ ⊢[T.internalize V] t↑ᵗ↑ᵗ.subst ![&'1] * u↑ᵗ↑ᵗ.subst ![&'1] ≐ t↑ᵗ↑ᵗ.subst ![&'0] * + u↑ᵗ↑ᵗ.subst ![&'0] by + apply TProof.all₂Proof; simpa [Semiformula.free, SemitermVec.q, Semiterm.shift_substs, + Semiterm.substs_substs] + have iht : T.internalize V ⊢ ∀¹ ∀¹ ((#'1 ≐ #'0) ⇒ₗ (t.subst ![#'1] ≐ t.subst ![#'0])) := by + apply (tprovable_iff_provable (T := T)).mpr + simpa [t] using ih 0 (by simp) + have ihu : T.internalize V ⊢ ∀¹ ∀¹ ((#'1 ≐ #'0) ⇒ₗ (u.subst ![#'1] ≐ u.subst ![#'0])) := by + apply (tprovable_iff_provable (T := T)).mpr + simpa [u] using ih 1 (by simp) + have iht : Γ ⊢[T.internalize V] (t↑ᵗ↑ᵗ.subst ![&'1] ≐ t↑ᵗ↑ᵗ.subst ![&'0]) := by + have := TProof.specialize₂ShiftProof iht &'0 &'1 + simpa [Semiterm.shift_substs, Semiterm.substs_substs] using! this + have ihu : Γ ⊢[T.internalize V] (u↑ᵗ↑ᵗ.subst ![&'1] ≐ u↑ᵗ↑ᵗ.subst ![&'0]) := by + have := TProof.specialize₂ShiftProof ihu &'0 &'1 + simpa [Semiterm.shift_substs, Semiterm.substs_substs] using! this + have := subst_mul_eq_mul T (t↑ᵗ↑ᵗ.subst ![&'1]) (t↑ᵗ↑ᵗ.subst ![&'0]) + (u↑ᵗ↑ᵗ.subst ![&'1]) (u↑ᵗ↑ᵗ.subst ![&'0]) + exact of' this ⨀ iht ⨀ ihu + case hbvar => + intro z hz + have : z = 0 := lt_one_iff_eq_zero.mp hz + rcases this with rfl + suffices T.internalize V ⊢ ∀¹ ∀¹ ((#'1 ≐ #'0) ⇒ₗ (#'1 ≐ #'0)) by + have := (tprovable_iff_provable (T := T)).mp this + simpa [-substs_equals, val_all] using this + have : T ⊢ “∀ x y, (x = y → x = y)” := complete.{0} T _ fun (M : Type) _ _ ↦ by simp + [models_iff] + simpa using internal_provable_of_outer_provable this (V := V) + case hfvar => + intro x + suffices T.internalize V ⊢ ∀¹ ∀¹ ((#'1 ≐ #'0) ⇒ₗ (&'x ≐ &'x)) by + have := (tprovable_iff_provable (T := T)).mp this + simpa [-substs_equals, val_all] using this + suffices T.internalize V ⊢ (&'1 ≐ &'0) ⇒ₗ (&'(x + 1 + 1) ≐ &'(x + 1 + 1)) by + apply TProof.all₂Proof; simpa [Semiformula.free] + apply Entailment.dhyp (eq_refl T _) + + + +lemma term_replace (t : Semiterm V ℒₒᵣ 1) : + T.internalize V ⊢ ∀¹ ∀¹ ((#'1 ≐ #'0) ⇒ₗ (t.subst ![#'1] ≐ t.subst ![#'0])) := + by + apply (tprovable_iff_provable (T := T)).mpr + simpa using term_replace_aux T t.val + +lemma term_replace' (t : Semiterm V ℒₒᵣ 1) (u₁ u₂ : Term V ℒₒᵣ) : + T.internalize V ⊢ (u₁ ≐ u₂) ⇒ₗ (t.subst ![u₁] ≐ t.subst ![u₂]) := + by + have := TProof.specialize₂Proof (term_replace T t) u₂ u₁ + simpa [Semiterm.substs_substs] using this + +lemma replace_eq (t u : Semiterm V ℒₒᵣ 1) : + T.internalize V ⊢ ∀¹ ∀¹ ((#'1 ≐ #'0) ⇒ₗ (t ≐ u).subst ![#'1] ⇒ₗ (t ≐ u).subst ![#'0]) := + by + suffices + T.internalize V ⊢ + (&'1 ≐ &'0) ⇒ₗ + (t↑ᵗ↑ᵗ.subst ![&'1] ≐ u↑ᵗ↑ᵗ.subst ![&'1]) ⇒ₗ (t↑ᵗ↑ᵗ.subst ![&'0] ≐ u↑ᵗ↑ᵗ.subst ![&'0]) + by + apply TProof.all₂Proof + simpa [Semiformula.free, SemitermVec.q, Semiterm.shift_substs, Semiterm.substs_substs] + let Γ : List (Formula V ℒₒᵣ) := [t↑ᵗ↑ᵗ.subst ![&'1] ≐ u↑ᵗ↑ᵗ.subst ![&'1], &'1 ≐ &'0] + suffices Γ ⊢[T.internalize V] t↑ᵗ↑ᵗ.subst ![&'0] ≐ u↑ᵗ↑ᵗ.subst ![&'0] + by + apply deduct' + apply deduct + exact this + have hh : Γ ⊢[T.internalize V] t↑ᵗ↑ᵗ.subst ![&'1] ≐ u↑ᵗ↑ᵗ.subst ![&'1] := by_axm₀ + have ht : Γ ⊢[T.internalize V] t↑ᵗ↑ᵗ.subst ![&'1] ≐ t↑ᵗ↑ᵗ.subst ![&'0] := + of' (term_replace' T t↑ᵗ↑ᵗ &'1 &'0)⨀by_axm₁ + have hu : Γ ⊢[T.internalize V] u↑ᵗ↑ᵗ.subst ![&'1] ≐ u↑ᵗ↑ᵗ.subst ![&'0] := + of' (term_replace' T u↑ᵗ↑ᵗ &'1 &'0)⨀by_axm₁ + exact + of' + (subst_eq T (t↑ᵗ↑ᵗ.subst ![&'1]) (t↑ᵗ↑ᵗ.subst ![&'0]) (u↑ᵗ↑ᵗ.subst ![&'1]) + (u↑ᵗ↑ᵗ.subst ![&'0]))⨀ht⨀hu⨀hh + +lemma replace_lt (t u : Semiterm V ℒₒᵣ 1) : + T.internalize V ⊢ ∀¹ ∀¹ ((#'1 ≐ #'0) ⇒ₗ (t <' u).subst ![#'1] ⇒ₗ (t <' u).subst ![#'0]) := + by + suffices + T.internalize V ⊢ + (&'1 ≐ &'0) ⇒ₗ + (t↑ᵗ↑ᵗ.subst ![&'1] <' u↑ᵗ↑ᵗ.subst ![&'1]) ⇒ₗ (t↑ᵗ↑ᵗ.subst ![&'0] <' u↑ᵗ↑ᵗ.subst ![&'0]) + by + apply TProof.all₂Proof + simpa [Semiformula.free, SemitermVec.q, Semiterm.shift_substs, Semiterm.substs_substs] + let Γ : List (Formula V ℒₒᵣ) := [t↑ᵗ↑ᵗ.subst ![&'1] <' u↑ᵗ↑ᵗ.subst ![&'1], &'1 ≐ &'0] + suffices Γ ⊢[T.internalize V] t↑ᵗ↑ᵗ.subst ![&'0] <' u↑ᵗ↑ᵗ.subst ![&'0] + by + apply deduct' + apply deduct + exact this + have hh : Γ ⊢[T.internalize V] t↑ᵗ↑ᵗ.subst ![&'1] <' u↑ᵗ↑ᵗ.subst ![&'1] := by_axm₀ + have ht : Γ ⊢[T.internalize V] t↑ᵗ↑ᵗ.subst ![&'1] ≐ t↑ᵗ↑ᵗ.subst ![&'0] := + of' (term_replace' T t↑ᵗ↑ᵗ &'1 &'0)⨀by_axm₁ + have hu : Γ ⊢[T.internalize V] u↑ᵗ↑ᵗ.subst ![&'1] ≐ u↑ᵗ↑ᵗ.subst ![&'0] := + of' (term_replace' T u↑ᵗ↑ᵗ &'1 &'0)⨀by_axm₁ + exact + of' + (subst_lt T (t↑ᵗ↑ᵗ.subst ![&'1]) (t↑ᵗ↑ᵗ.subst ![&'0]) (u↑ᵗ↑ᵗ.subst ![&'1]) + (u↑ᵗ↑ᵗ.subst ![&'0]))⨀ht⨀hu⨀hh + +lemma replace_ne (t u : Semiterm V ℒₒᵣ 1) : + T.internalize V ⊢ ∀¹ ∀¹ ((#'1 ≐ #'0) ⇒ₗ (t ≉ u).subst ![#'1] ⇒ₗ (t ≉ u).subst ![#'0]) := + by + suffices + T.internalize V ⊢ + (&'1 ≐ &'0) ⇒ₗ + (t↑ᵗ↑ᵗ.subst ![&'1] ≉ u↑ᵗ↑ᵗ.subst ![&'1]) ⇒ₗ (t↑ᵗ↑ᵗ.subst ![&'0] ≉ u↑ᵗ↑ᵗ.subst ![&'0]) + by + apply TProof.all₂Proof + simpa [Semiformula.free, SemitermVec.q, Semiterm.shift_substs, Semiterm.substs_substs] + let Γ : List (Formula V ℒₒᵣ) := [t↑ᵗ↑ᵗ.subst ![&'1] ≉ u↑ᵗ↑ᵗ.subst ![&'1], &'1 ≐ &'0] + suffices Γ ⊢[T.internalize V] t↑ᵗ↑ᵗ.subst ![&'0] ≉ u↑ᵗ↑ᵗ.subst ![&'0] + by + apply deduct' + apply deduct + exact this + have hh : Γ ⊢[T.internalize V] t↑ᵗ↑ᵗ.subst ![&'1] ≉ u↑ᵗ↑ᵗ.subst ![&'1] := by_axm₀ + have ht : Γ ⊢[T.internalize V] t↑ᵗ↑ᵗ.subst ![&'1] ≐ t↑ᵗ↑ᵗ.subst ![&'0] := + of' (term_replace' T t↑ᵗ↑ᵗ &'1 &'0)⨀by_axm₁ + have hu : Γ ⊢[T.internalize V] u↑ᵗ↑ᵗ.subst ![&'1] ≐ u↑ᵗ↑ᵗ.subst ![&'0] := + of' (term_replace' T u↑ᵗ↑ᵗ &'1 &'0)⨀by_axm₁ + exact + of' + (subst_ne T (t↑ᵗ↑ᵗ.subst ![&'1]) (t↑ᵗ↑ᵗ.subst ![&'0]) (u↑ᵗ↑ᵗ.subst ![&'1]) + (u↑ᵗ↑ᵗ.subst ![&'0]))⨀ht⨀hu⨀hh + +lemma replace_nlt (t u : Semiterm V ℒₒᵣ 1) : + T.internalize V ⊢ ∀¹ ∀¹ ((#'1 ≐ #'0) ⇒ₗ (t ≮' u).subst ![#'1] ⇒ₗ (t ≮' u).subst ![#'0]) := + by + suffices + T.internalize V ⊢ + (&'1 ≐ &'0) ⇒ₗ + (t↑ᵗ↑ᵗ.subst ![&'1] ≮' u↑ᵗ↑ᵗ.subst ![&'1]) ⇒ₗ (t↑ᵗ↑ᵗ.subst ![&'0] ≮' u↑ᵗ↑ᵗ.subst ![&'0]) + by + apply TProof.all₂Proof + simpa [Semiformula.free, SemitermVec.q, Semiterm.shift_substs, Semiterm.substs_substs] + let Γ : List (Formula V ℒₒᵣ) := [t↑ᵗ↑ᵗ.subst ![&'1] ≮' u↑ᵗ↑ᵗ.subst ![&'1], &'1 ≐ &'0] + suffices Γ ⊢[T.internalize V] t↑ᵗ↑ᵗ.subst ![&'0] ≮' u↑ᵗ↑ᵗ.subst ![&'0] + by + apply deduct' + apply deduct + exact this + have hh : Γ ⊢[T.internalize V] t↑ᵗ↑ᵗ.subst ![&'1] ≮' u↑ᵗ↑ᵗ.subst ![&'1] := by_axm₀ + have ht : Γ ⊢[T.internalize V] t↑ᵗ↑ᵗ.subst ![&'1] ≐ t↑ᵗ↑ᵗ.subst ![&'0] := + of' (term_replace' T t↑ᵗ↑ᵗ &'1 &'0)⨀by_axm₁ + have hu : Γ ⊢[T.internalize V] u↑ᵗ↑ᵗ.subst ![&'1] ≐ u↑ᵗ↑ᵗ.subst ![&'0] := + of' (term_replace' T u↑ᵗ↑ᵗ &'1 &'0)⨀by_axm₁ + exact + of' + (subst_nlt T (t↑ᵗ↑ᵗ.subst ![&'1]) (t↑ᵗ↑ᵗ.subst ![&'0]) (u↑ᵗ↑ᵗ.subst ![&'1]) + (u↑ᵗ↑ᵗ.subst ![&'0]))⨀ht⨀hu⨀hh + +lemma replace_aux (φ : V) : + IsSemiformula ℒₒᵣ 1 φ → + Provable T (^∀ ^∀ imp ℒₒᵣ (^#1 ^= ^#0) (imp ℒₒᵣ (subst ℒₒᵣ (^#1 ∷ 0) φ) (subst ℒₒᵣ (^#0 ∷ 0) + φ))) := by + apply IsFormula.sigma1_structural_induction₂_ss + · definability + case hand => + intro p q hp hq ihp ihq + let φ : Semiformula V ℒₒᵣ 1 := ⟨p, by simpa using hp⟩ + let ψ : Semiformula V ℒₒᵣ 1 := ⟨q, by simpa using hq⟩ + suffices T.internalize V ⊢ ∀¹ ∀¹ ((#'1 ≐ #'0) ⇒ₗ (φ ⋏ ψ).subst ![#'1] ⇒ₗ (φ ⋏ ψ).subst + ![#'0]) by + have := (tprovable_iff_provable (T := T)).mp this + simpa [-Semiformula.substs_and, -substs_and, φ, ψ] using this + suffices + T.internalize V ⊢ + (&'1 ≐ &'0) ⇒ₗ φ↑ᶠ↑ᶠ.subst ![&'1] ⋏ ψ↑ᶠ↑ᶠ.subst ![&'1] ⇒ₗ φ↑ᶠ↑ᶠ.subst ![&'0] ⋏ + ψ↑ᶠ↑ᶠ.subst ![&'0] by + apply TProof.all₂Proof + simpa [Semiformula.free, SemitermVec.q, Semiformula.shift_substs, Semiformula.substs_substs] + have ihφ : T.internalize V ⊢ ∀¹ ∀¹ ((#'1 ≐ #'0) ⇒ₗ φ.subst ![#'1] ⇒ₗ φ.subst ![#'0]) := by + apply (tprovable_iff_provable (T := T)).mpr + simpa using ihp + have ihψ : T.internalize V ⊢ ∀¹ ∀¹ ((#'1 ≐ #'0) ⇒ₗ ψ.subst ![#'1] ⇒ₗ ψ.subst ![#'0]) := by + apply (tprovable_iff_provable (T := T)).mpr + simpa using ihq + have ihφ : + T.internalize V ⊢ (&'1 ≐ &'0) ⇒ₗ φ↑ᶠ↑ᶠ.subst ![&'1] ⇒ₗ φ↑ᶠ↑ᶠ.subst ![&'0] := by + have := TProof.specialize₂ShiftProof ihφ &'0 &'1 + simpa [Semiformula.free, SemitermVec.q, Semiformula.shift_substs, + Semiformula.substs_substs] using this + have ihψ : + T.internalize V ⊢ (&'1 ≐ &'0) ⇒ₗ ψ↑ᶠ↑ᶠ.subst ![&'1] ⇒ₗ ψ↑ᶠ↑ᶠ.subst ![&'0] := by + have := TProof.specialize₂ShiftProof ihψ &'0 &'1 + simpa [Semiformula.free, SemitermVec.q, Semiformula.shift_substs, + Semiformula.substs_substs] using this + cl_prover [ihφ, ihψ] + case hor => + intro p q hp hq ihp ihq + let φ : Semiformula V ℒₒᵣ 1 := ⟨p, by simpa using hp⟩ + let ψ : Semiformula V ℒₒᵣ 1 := ⟨q, by simpa using hq⟩ + suffices T.internalize V ⊢ ∀¹ ∀¹ ((#'1 ≐ #'0) ⇒ₗ (φ ⋎ ψ).subst ![#'1] ⇒ₗ (φ ⋎ ψ).subst + ![#'0]) by + have := (tprovable_iff_provable (T := T)).mp this + simpa [-Semiformula.substs_or, -substs_or, φ, ψ] using this + suffices + T.internalize V ⊢ + (&'1 ≐ &'0) ⇒ₗ φ↑ᶠ↑ᶠ.subst ![&'1] ⋎ ψ↑ᶠ↑ᶠ.subst ![&'1] ⇒ₗ φ↑ᶠ↑ᶠ.subst ![&'0] ⋎ + ψ↑ᶠ↑ᶠ.subst ![&'0] by + apply TProof.all₂Proof + simpa [Semiformula.free, SemitermVec.q, Semiformula.shift_substs, Semiformula.substs_substs] + have ihφ : T.internalize V ⊢ ∀¹ ∀¹ ((#'1 ≐ #'0) ⇒ₗ φ.subst ![#'1] ⇒ₗ φ.subst ![#'0]) := by + apply (tprovable_iff_provable (T := T)).mpr + simpa using ihp + have ihψ : T.internalize V ⊢ ∀¹ ∀¹ ((#'1 ≐ #'0) ⇒ₗ ψ.subst ![#'1] ⇒ₗ ψ.subst ![#'0]) := by + apply (tprovable_iff_provable (T := T)).mpr + simpa using ihq + have ihφ : + T.internalize V ⊢ (&'1 ≐ &'0) ⇒ₗ φ↑ᶠ↑ᶠ.subst ![&'1] ⇒ₗ φ↑ᶠ↑ᶠ.subst ![&'0] := by + have := TProof.specialize₂ShiftProof ihφ &'0 &'1 + simpa [Semiformula.free, SemitermVec.q, Semiformula.shift_substs, + Semiformula.substs_substs] using this + have ihψ : + T.internalize V ⊢ (&'1 ≐ &'0) ⇒ₗ ψ↑ᶠ↑ᶠ.subst ![&'1] ⇒ₗ ψ↑ᶠ↑ᶠ.subst ![&'0] := by + have := TProof.specialize₂ShiftProof ihψ &'0 &'1 + simpa [Semiformula.free, SemitermVec.q, Semiformula.shift_substs, + Semiformula.substs_substs] using this + cl_prover [ihφ, ihψ] + case hverum => + suffices T.internalize V ⊢ ∀¹ ∀¹ ((#'1 ≐ #'0) ⇒ₗ ⊤ ⇒ₗ ⊤) by + have := (tprovable_iff_provable (T := T)).mp this + simpa [-substs_equals] using this + suffices Theory.internalize V T ⊢ (&'1 ≐ &'0) ⇒ₗ ⊤ ⇒ₗ ⊤ by + apply TProof.all₂Proof + simpa + apply dhyp; exact CV + case hfalsum => + suffices T.internalize V ⊢ ∀¹ ∀¹ ((#'1 ≐ #'0) ⇒ₗ ⊥ ⇒ₗ ⊥) by + have := (tprovable_iff_provable (T := T)).mp this + simpa [-substs_equals] using this + suffices Theory.internalize V T ⊢ (&'1 ≐ &'0) ⇒ₗ ⊥ ⇒ₗ ⊥ by + apply TProof.all₂Proof + simpa + apply dhyp; exact C_id + case hrel => + intro k R v hR hv + rcases isRel_iff_LOR.mp hR with (⟨rfl, rfl⟩ | ⟨rfl, rfl⟩) + · let t : Semiterm V ℒₒᵣ 1 := ⟨v.[0], by simpa using hv.nth (by simp)⟩ + let u : Semiterm V ℒₒᵣ 1 := ⟨v.[1], by simpa using hv.nth (by simp)⟩ + have veq : v = ?[t.val, u.val] := by simp [t, u, vec2_eq hv.lh] + suffices T.internalize V ⊢ ∀¹ ∀¹ ((#'1 ≐ #'0) ⇒ₗ (t ≐ u).subst ![#'1] ⇒ₗ (t ≐ u).subst + ![#'0]) by + have := (tprovable_iff_provable (T := T)).mp this + simpa [-substs_equals, veq, val_all] using! this + simpa using replace_eq T t u + · let t : Semiterm V ℒₒᵣ 1 := ⟨v.[0], by simpa using hv.nth (by simp)⟩ + let u : Semiterm V ℒₒᵣ 1 := ⟨v.[1], by simpa using hv.nth (by simp)⟩ + have veq : v = ?[t.val, u.val] := by simp [t, u, vec2_eq hv.lh] + suffices T.internalize V ⊢ ∀¹ ∀¹ ((#'1 ≐ #'0) ⇒ₗ (t <' u).subst ![#'1] ⇒ₗ (t <' u).subst + ![#'0]) by + have := (tprovable_iff_provable (T := T)).mp this + simpa [-substs_lessThan, veq, val_all] using! this + simpa using replace_lt T t u + case hnrel => + intro k R v hR hv + rcases isRel_iff_LOR.mp hR with (⟨rfl, rfl⟩ | ⟨rfl, rfl⟩) + · let t : Semiterm V ℒₒᵣ 1 := ⟨v.[0], by simpa using hv.nth (by simp)⟩ + let u : Semiterm V ℒₒᵣ 1 := ⟨v.[1], by simpa using hv.nth (by simp)⟩ + have veq : v = ?[t.val, u.val] := by simp [t, u, vec2_eq hv.lh] + suffices T.internalize V ⊢ ∀¹ ∀¹ ((#'1 ≐ #'0) ⇒ₗ (t ≉ u).subst ![#'1] ⇒ₗ (t ≉ u).subst + ![#'0]) by + have := (tprovable_iff_provable (T := T)).mp this + simpa [-substs_notEquals, veq, val_all] using! this + simpa using replace_ne T t u + · let t : Semiterm V ℒₒᵣ 1 := ⟨v.[0], by simpa using hv.nth (by simp)⟩ + let u : Semiterm V ℒₒᵣ 1 := ⟨v.[1], by simpa using hv.nth (by simp)⟩ + have veq : v = ?[t.val, u.val] := by simp [t, u, vec2_eq hv.lh] + suffices T.internalize V ⊢ ∀¹ ∀¹ ((#'1 ≐ #'0) ⇒ₗ (t ≮' u).subst ![#'1] ⇒ₗ (t ≮' u).subst + ![#'0]) by + have := (tprovable_iff_provable (T := T)).mp this + simpa [-substs_notLessThan, veq, val_all] using! this + simpa using replace_nlt T t u + case hall => + intro p hp ih + let φ : Semiformula V ℒₒᵣ 2 := ⟨p, hp⟩ + suffices T.internalize V ⊢ ∀¹ ∀¹ ((#'1 ≐ #'0) ⇒ₗ (∀¹ φ).subst ![#'1] ⇒ₗ (∀¹ φ).subst ![#'0]) by + have := (tprovable_iff_provable (T := T)).mp this + simpa only [Nat.reduceAdd, Fin.isValue, Nat.succ_eq_add_one, val_all, + val_imp, val_equals, Semiterm.bvar_val, Fin.coe_ofNat_eq_mod, Nat.mod_succ, Nat.cast_one, + Nat.zero_mod, Nat.cast_zero, val_substs, SemitermVec.val_succ, Matrix.head_cons, + Matrix.tail_cons, SemitermVec.val_nil] using this + have ih : T.internalize V ⊢ ∀¹ ∀¹ ((#'1 ≐ #'0) ⇒ₗ φ↑ᶠ↑ᶠ.free1.subst ![#'1] ⇒ₗ + φ↑ᶠ↑ᶠ.free1.subst ![#'0]) := by + apply (tprovable_iff_provable (T := T)).mpr + simpa using ih + suffices + T.internalize V ⊢ (&'1 ≐ &'0) ⇒ₗ ∀¹ φ↑ᶠ↑ᶠ.subst ![#'0, &'1] ⇒ₗ ∀¹ φ↑ᶠ↑ᶠ.subst ![#'0, &'0] by + apply TProof.all₂Proof; simpa [Semiformula.free, SemitermVec.q, Semiformula.shift_substs, + Semiformula.substs_substs] + apply deduct' + apply TProof.all_imp_allProof + apply deductInv' + simpa [Semiformula.free1, Semiformula.free, SemitermVec.q, + Semiformula.shift_substs, Semiformula.substs_substs, one_add_one_eq_two] + using TProof.specialize₂Proof ih (&'1) (&'2) + case hexs => + intro p hp ih + let φ : Semiformula V ℒₒᵣ 2 := ⟨p, hp⟩ + suffices T.internalize V ⊢ ∀¹ ∀¹ ((#'1 ≐ #'0) ⇒ₗ (∃¹ φ).subst ![#'1] ⇒ₗ (∃¹ φ).subst ![#'0]) by + have := (tprovable_iff_provable (T := T)).mp this + simpa only [Nat.reduceAdd, Fin.isValue, Nat.succ_eq_add_one, val_all, + val_imp, val_equals, Semiterm.bvar_val, Fin.coe_ofNat_eq_mod, Nat.mod_succ, Nat.cast_one, + Nat.zero_mod, Nat.cast_zero, val_substs, SemitermVec.val_succ, Matrix.head_cons, + Matrix.tail_cons, SemitermVec.val_nil] using! this + have ih : T.internalize V ⊢ ∀¹ ∀¹ ((#'1 ≐ #'0) ⇒ₗ φ↑ᶠ↑ᶠ.free1.subst ![#'1] ⇒ₗ + φ↑ᶠ↑ᶠ.free1.subst ![#'0]) := by + apply (tprovable_iff_provable (T := T)).mpr + simpa using ih + suffices + T.internalize V ⊢ (&'1 ≐ &'0) ⇒ₗ ∃¹ φ↑ᶠ↑ᶠ.subst ![#'0, &'1] ⇒ₗ ∃¹ φ↑ᶠ↑ᶠ.subst ![#'0, &'0] by + apply TProof.all₂Proof; simpa [Semiformula.free, SemitermVec.q, Semiformula.shift_substs, + Semiformula.substs_substs] + apply deduct' + apply TProof.exs_imp_exsProof + apply deductInv' + simpa [Semiformula.free1, Semiformula.free, SemitermVec.q, + Semiformula.shift_substs, Semiformula.substs_substs, one_add_one_eq_two] + using TProof.specialize₂Proof ih (&'1) (&'2) + + + +lemma replace' (φ : Semiformula V ℒₒᵣ 1) : + T.internalize V ⊢ ∀¹ ∀¹ ((#'1 ≐ #'0) ⇒ₗ φ.subst ![#'1] ⇒ₗ φ.subst ![#'0]) := + by + apply (tprovable_iff_provable (T := T)).mpr + simpa using replace_aux T φ.val + +lemma replace (φ : Semiformula V ℒₒᵣ 1) (u₁ u₂ : Term V ℒₒᵣ) : + T.internalize V ⊢ (u₁ ≐ u₂) ⇒ₗ φ.subst ![u₁] ⇒ₗ φ.subst ![u₂] := + by + have := TProof.specialize₂Proof (replace' T φ) u₂ u₁ + simpa [Semiformula.substs_substs] using this + +end replace + +end ObjectArithmetic +end Bootstrapping + +end Arithmetic +end FirstOrder +end FFL +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/DerivabilityCondition/PeanoMinus.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/DerivabilityCondition/PeanoMinus.lean new file mode 100644 index 000000000..3fae1b83e --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/DerivabilityCondition/PeanoMinus.lean @@ -0,0 +1,327 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.DerivabilityCondition.EquationalTheory + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +/-! +# Bootstrapping theory $\mathsf{PA}^-$, $\mathsf{R_0}$ in $\mathsf{I}\Sigma_1$ +-/ + +namespace FFL +namespace FirstOrder +namespace Arithmetic + +variable {V : Type*} [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] + +lemma lt_add_self_add_one (a b : V) : a < b + a + 1 := + lt_succ_iff_le.mpr <| le_add_self + +lemma lt_succ_iff_eq_or_succ {a b : V} : a < b + 1 ↔ a = b ∨ a < b := by + simp [lt_succ_iff_le, le_iff_eq_or_lt] + +end Arithmetic +end FirstOrder +end FFL + +namespace FFL +namespace FirstOrder +namespace Arithmetic +namespace Bootstrapping +namespace ObjectArithmetic + +open FFL.Entailment + +variable {V : Type*} [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +local prefix:max "#'" => Semiterm.bvar (V := V) (L := ℒₒᵣ) + +local prefix:max "&'" => Semiterm.fvar (V := V) (L := ℒₒᵣ) + +local postfix:max "↑ᵗ" => Semiterm.shift + +local postfix:max "↑ᶠ" => Semiformula.shift + +variable (T : ArithmeticTheory) [Theory.Δ₁ T] [𝐏𝐀⁻ ≼ T] + +open Entailment Entailment.FiniteContext + _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.Bootstrapping.Semiformula + +instance : 𝐄𝐐 _ ≼ T := + have : 𝐏𝐀⁻ ≼ T := inferInstance + WeakerThan.trans inferInstance this + +lemma term_add_assoc (t₁ t₂ t₃ : Term V ℒₒᵣ) : + T.internalize V ⊢ t₁ + (t₂ + t₃) ≐ (t₁ + t₂) + t₃ := + by + have : T ⊢ (“∀ x y z, x + (y + z) = (x + y) + z”) := + complete.{0} T _ fun (M : Type) _ (hM : M↓[ℒₒᵣ] ⊧* T) ↦ + by + have : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory hM + simp [models_iff, add_assoc] + have : T.internalize V ⊢ ∀¹ ∀¹ ∀¹ (#'2 + (#'1 + #'0) ≐ #'2 + #'1 + #'0) := by + simpa using internal_provable_of_outer_provable (V := V) this + simpa using TProof.specialize₃Proof this t₃ t₂ t₁ + +lemma numeral_add (n m : V) : T.internalize V ⊢ (ℕᵗn + ℕᵗm) ≐ ℕᵗ(n + m) := + by + induction m using sigma1_pos_succ_induction + · simp only [tprovable_iff_provable, val_equals, val_add, val_numeral] + definability + case + zero => + have : T.internalize V ⊢ ∀¹ ((#'0 + ℕᵗ0) ≐ #'0) := + by + have : T ⊢ (“∀ x, x + 0 = x”) := + complete.{0} T _ fun (M : Type) _ (hM : M↓[ℒₒᵣ] ⊧* T) ↦ + by + have : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory hM + simp [models_iff] + have := internal_provable_of_outer_provable (V := V) this + simpa using this + simpa using TProof.specializeProof this <| ℕᵗn + case one => + rcases eq_zero_or_pos n with (rfl | pos) + · have : T.internalize V ⊢ (ℕᵗ0 + ℕᵗ1) ≐ ℕᵗ1 := + by + have : T ⊢ (“0 + 1 = 1”) := + complete.{0} T _ fun (M : Type) _ (hM : M↓[ℒₒᵣ] ⊧* T) ↦ + by + have : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory hM + simp [models_iff] + simpa using internal_provable_of_outer_provable (V := V) this + simpa using this + · simp [numeral_succ_pos' pos] + case succ m + ih => + suffices T.internalize V ⊢ ℕᵗn + (ℕᵗ(m + 1) + ℕᵗ1) ≐ ℕᵗ(n + m + 1) + ℕᵗ1 by + simpa [← one_add_one_eq_two, ← add_assoc] + have e1 : T.internalize V ⊢ ℕᵗn + (ℕᵗ(m + 1) + ℕᵗ1) ≐ (ℕᵗn + ℕᵗ(m + 1)) + ℕᵗ1 := + term_add_assoc T _ _ _ + have e2 : T.internalize V ⊢ (ℕᵗn + ℕᵗ(m + 1)) + ℕᵗ1 ≐ ℕᵗ(n + (m + 1)) + ℕᵗ1 := + subst_add_eq_add T _ _ _ _⨀ih⨀(eq_refl T (ℕᵗ1)) + simpa [add_assoc] using eq_trans e1 e2 + +lemma numeral_mul (n m : V) : T.internalize V ⊢ ℕᵗn * ℕᵗm ≐ ℕᵗ(n * m) := + by + induction m using sigma1_pos_succ_induction + · simp only [tprovable_iff_provable, val_equals, val_mul, val_numeral] + definability + case + zero => + have : T.internalize V ⊢ ∀¹ ((#'0 * ℕᵗ0) ≐ ℕᵗ0) := + by + have : T ⊢ (“∀ x, x * 0 = 0”) := + complete.{0} T _ fun (M : Type) _ (hM : M↓[ℒₒᵣ] ⊧* T) ↦ + by + have : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory hM + simp [models_iff] + have := internal_provable_of_outer_provable (V := V) this + simpa using this + simpa using TProof.specializeProof this (ℕᵗn) + case + one => + have : T.internalize V ⊢ ∀¹ ((#'0 * ℕᵗ1) ≐ #'0) := + by + have : T ⊢ (“∀ x, x * 1 = x”) := + complete.{0} T _ fun (M : Type) _ (hM : M↓[ℒₒᵣ] ⊧* T) ↦ + by + have : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory hM + simp [models_iff] + have := internal_provable_of_outer_provable (V := V) this + simpa using this + simpa using TProof.specializeProof this (ℕᵗn) + case succ m + ih => + suffices T.internalize V ⊢ ℕᵗn * (ℕᵗ(m + 1) + ℕᵗ1) ≐ ℕᵗ(n * (m + 1) + n) by + simpa [← one_add_one_eq_two, ← add_assoc, mul_add] + have e1 : T.internalize V ⊢ ℕᵗn * (ℕᵗ(m + 1) + ℕᵗ1) ≐ ℕᵗn * ℕᵗ(m + 1) + ℕᵗn := + by + have : T ⊢ (“∀ x y, x * (y + 1) = x * y + x”) := + complete.{0} T _ fun (M : Type) _ (hM : M↓[ℒₒᵣ] ⊧* T) ↦ + by + have : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory hM + simp [models_iff, mul_add] + have := by simpa using internal_provable_of_outer_provable (V := V) this + simpa using TProof.specialize₂Proof this ℕᵗ(m + 1) (ℕᵗn) + have e2 : T.internalize V ⊢ ℕᵗn * ℕᵗ(m + 1) + ℕᵗn ≐ ℕᵗ(n * (m + 1)) + ℕᵗn := + subst_add_eq_add T _ _ _ _⨀ih⨀(eq_refl T (ℕᵗn)) + have e3 : T.internalize V ⊢ ℕᵗ(n * (m + 1)) + ℕᵗn ≐ ℕᵗ(n * (m + 1) + n) := numeral_add T _ _ + exact eq_trans (eq_trans e1 e2) e3 + +lemma numeral_eq {n m : V} : n = m → T.internalize V ⊢ ℕᵗ n ≐ ℕᵗ m := by + rintro rfl; + exact eq_refl T (ℕᵗ n) + +lemma numeral_lt {n m : V} : n < m → T.internalize V ⊢ ℕᵗn <' ℕᵗm := fun h ↦ + by + let d := m - (n + 1) + have hm : m = d + n + 1 := by + simpa [d, add_assoc] using Eq.symm <| sub_add_self_of_le <| succ_le_iff_lt.mpr h + suffices T.internalize V ⊢ ℕᵗn <' ℕᵗ(d + n + 1) by simpa [hm] + have l₁ : T.internalize V ⊢ ℕᵗn <' ℕᵗd + ℕᵗn + ℕᵗ1 := + by + have : T ⊢ (“∀ x y, x < y + x + 1”) := + complete.{0} T _ fun (M : Type) _ (hM : M↓[ℒₒᵣ] ⊧* T) ↦ + by + have : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory hM + simp [models_iff, Arithmetic.lt_add_self_add_one] + have := by simpa using internal_provable_of_outer_provable (V := V) this + simpa using TProof.specialize₂Proof this (ℕᵗd) (ℕᵗn) + have l₂ : T.internalize V ⊢ ℕᵗd + ℕᵗn + ℕᵗ1 ≐ ℕᵗ(d + n + 1) := + by + have e₁ : T.internalize V ⊢ ℕᵗd + ℕᵗn + ℕᵗ1 ≐ ℕᵗ(d + n) + ℕᵗ1 := + subst_add_eq_add T _ _ _ _⨀numeral_add T d n⨀eq_refl T (ℕᵗ1) + have e₂ : T.internalize V ⊢ ℕᵗ(d + n) + ℕᵗ1 ≐ ℕᵗ(d + n + 1) := numeral_add T (d + n) 1 + exact eq_trans e₁ e₂ + exact subst_lt T (ℕᵗn) (ℕᵗn) (ℕᵗd + ℕᵗn + ℕᵗ1) (ℕᵗ(d + n + 1))⨀eq_refl T (ℕᵗn)⨀l₂⨀l₁ + +lemma numeral_ne {n m : V} : n ≠ m → T.internalize V ⊢ ℕᵗn ≉ ℕᵗm := fun h ↦ + by + wlog hnm : n < m + · have hmn : m < n := by exact lt_of_le_of_ne (by simpa using hnm) (Ne.symm h) + exact ne_symm T _ _⨀(this T (Ne.symm h) hmn) + have l₁ : T.internalize V ⊢ ℕᵗn <' ℕᵗm := numeral_lt T hnm + have l₂ : T.internalize V ⊢ (ℕᵗn <' ℕᵗm) ⇒ₗ (ℕᵗn ≉ ℕᵗm) := + by + have : T ⊢ (“∀ x y, x < y → x ≠ y”) := + complete.{0} T _ fun (M : Type) _ (hM : M↓[ℒₒᵣ] ⊧* T) ↦ + by + have : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory hM + simpa [models_iff] using fun _ _ ↦ ne_of_lt + have := by simpa using internal_provable_of_outer_provable (V := V) this + simpa using TProof.specialize₂Proof this (ℕᵗm) (ℕᵗn) + exact l₂⨀l₁ + +lemma numeral_nlt {n m : V} : n ≥ m → T.internalize V ⊢ ℕᵗn ≮' ℕᵗm := fun h ↦ + by + rcases eq_or_lt_of_le h with (rfl | lt) + · have : T ⊢ (“∀ x, x ≮ x”) := + complete.{0} T _ fun (M : Type) _ (hM : M↓[ℒₒᵣ] ⊧* T) ↦ + by + have : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory hM + simp [models_iff] + have := by simpa using internal_provable_of_outer_provable (V := V) this + simpa using TProof.specializeProof this (ℕᵗm) + · have l₁ : T.internalize V ⊢ ℕᵗm <' ℕᵗn := numeral_lt T lt + have l₂ : T.internalize V ⊢ (ℕᵗm <' ℕᵗn) ⇒ₗ (ℕᵗn ≮' ℕᵗm) := + by + have : T ⊢ (“∀ x y, x < y → y ≮ x”) := + complete.{0} T _ fun (M : Type) _ (hM : M↓[ℒₒᵣ] ⊧* T) ↦ + by + have : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory hM + simpa [models_iff] using fun _ _ ↦ le_of_lt + have := by simpa using internal_provable_of_outer_provable (V := V) this + simpa using TProof.specialize₂Proof this (ℕᵗn) (ℕᵗm) + exact l₂⨀l₁ + +lemma lt_iff_substItrDisj (t : Term V ℒₒᵣ) (m : V) : + T.internalize V ⊢ (t <' ℕᵗm) ⇔ₗ substItrDisj ![t] (#'1 ≐ #'0) m := + by + induction m using sigma1_pos_succ_induction + · simp only [Nat.succ_eq_add_one, Nat.reduceAdd, Fin.isValue, tprovable_iff_provable, val_iff, + val_lessThan, val_numeral, substItrDisj_val, SemitermVec.val_succ, Matrix.head_cons, + Matrix.tail_cons, SemitermVec.val_nil, val_equals, Semiterm.bvar_val, + Fin.coe_ofNat_eq_mod, Nat.mod_succ, Nat.cast_one, Nat.zero_mod, Nat.cast_zero] + definability + case zero => + suffices T.internalize V ⊢ (t <' ℕᵗ0) ⇔ₗ ⊥ by simpa + have : T.internalize V ⊢ ∀¹ ((#'0 <' ℕᵗ0) ⇔ₗ ⊥) := + by + have : T ⊢ (“∀ x, x < 0 ↔ ⊥”) := + complete.{0} T _ fun (M : Type) _ (hM : M↓[ℒₒᵣ] ⊧* T) ↦ + by + have : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory hM + simp [models_iff] + simpa using internal_provable_of_outer_provable (V := V) this + simpa using TProof.specializeProof this t + case one => + suffices T.internalize V ⊢ (t <' ℕᵗ1) ⇔ₗ (t ≐ ℕᵗ0) ⋎ ⊥ by simpa + have : T.internalize V ⊢ ∀¹ ((#'0 <' ℕᵗ1) ⇔ₗ (#'0 ≐ ℕᵗ0) ⋎ ⊥) := + by + have : T ⊢ (“∀ x, x < 1 ↔ x = 0 ∨ ⊥”) := + complete.{0} T _ fun (M : Type) _ (hM : M↓[ℒₒᵣ] ⊧* T) ↦ + by + have : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory hM + simp [models_iff] + simpa using internal_provable_of_outer_provable (V := V) this + simpa using TProof.specializeProof this t + case succ m + ih => + suffices + T.internalize V ⊢ + (t <' ℕᵗ(m + 1) + ℕᵗ1) ⇔ₗ (t ≐ ℕᵗ(m + 1)) ⋎ substItrDisj ![t] (#'1 ≐ #'0) (m + 1) + by simpa [← one_add_one_eq_two, ← add_assoc] + have : T.internalize V ⊢ (t <' ℕᵗ(m + 1) + ℕᵗ1) ⇔ₗ (t ≐ ℕᵗ(m + 1)) ⋎ (t <' ℕᵗ(m + 1)) := + by + have : T.internalize V ⊢ ∀¹ ∀¹ ((#'0 <' #'1 + ℕᵗ1) ⇔ₗ (#'0 ≐ #'1) ⋎ (#'0 <' #'1)) := + by + have : T ⊢ (“∀ m x, x < m + 1 ↔ x = m ∨ x < m”) := + complete.{0} T _ fun (M : Type) _ (hM : M↓[ℒₒᵣ] ⊧* T) ↦ + by + have : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory hM + simp [models_iff, Arithmetic.lt_succ_iff_eq_or_succ] + simpa using internal_provable_of_outer_provable (V := V) this + simpa using TProof.specialize₂Proof this t ℕᵗ(m + 1) + cl_prover[ih, this] + +lemma ball_intro (φ : Semiformula V ℒₒᵣ 1) (n : V) + (bs : ∀ i < n, T.internalize V ⊢ φ.subst ![ℕᵗi]) : T.internalize V ⊢ φ.ball (ℕᵗn) := + by + apply TProof.allProof + suffices T.internalize V ⊢ (&'0 <' ℕᵗn) ⇒ₗ φ↑ᶠ.subst ![&'0] by + simpa [imp_def, Semiformula.free, SemitermVec.q, Semiterm.shift_substs, + Semiterm.substs_substs] + suffices T.internalize V ⊢ substItrDisj ![&'0] (#'1 ≐ #'0) n ⇒ₗ φ↑ᶠ.subst ![&'0] from + C_trans (K_left (lt_iff_substItrDisj T (&'0) n)) this + apply TProof.substItrDisj_left_intro + · intro i hi + suffices T.internalize V ⊢ (&'0 ≐ ℕᵗi) ⇒ₗ φ↑ᶠ.subst ![&'0] by simpa + have hi : T.internalize V ⊢ φ↑ᶠ.subst ![ℕᵗi] := by + simpa [Semiformula.shift_substs] using TProof.shiftProof (bs i hi) + have rl : T.internalize V ⊢ (ℕᵗi ≐ &'0) ⇒ₗ φ↑ᶠ.subst ![ℕᵗi] ⇒ₗ φ↑ᶠ.subst ![&'0] := + replace T φ.shift (ℕᵗi) (&'0) + have ec : T.internalize V ⊢ (&'0 ≐ ℕᵗi) ⇒ₗ (ℕᵗi ≐ &'0) := eq_symm T (Semiterm.fvar 0) (ℕᵗi) + cl_prover[hi, rl, ec] + +lemma bexs_intro (φ : Semiformula V ℒₒᵣ 1) (n : V) {i} (hi : i < n) + (b : T.internalize V ⊢ φ.subst ![ℕᵗi]) : T.internalize V ⊢ φ.bexs (ℕᵗn) := + by + apply TProof.exsProof (ℕᵗi) + suffices T.internalize V ⊢ (ℕᵗi <' ℕᵗn) ⋏ φ.subst ![ℕᵗi] by simpa + apply K_intro + · exact numeral_lt T hi + · exact b + +lemma ball_replace (φ : Semiformula V ℒₒᵣ 1) (t u : Term V ℒₒᵣ) : + T.internalize V ⊢ (t ≐ u) ⇒ₗ φ.ball t ⇒ₗ φ.ball u := by + simpa [SemitermVec.q, Semiformula.substs_substs] using + replace T ((φ.subst ![#'0]).ball #'0) t u + +lemma bexs_replace (φ : Semiformula V ℒₒᵣ 1) (t u : Term V ℒₒᵣ) : + T.internalize V ⊢ (t ≐ u) ⇒ₗ φ.bexs t ⇒ₗ φ.bexs u := by + simpa [SemitermVec.q, Semiformula.substs_substs] using + replace T ((φ.subst ![#'0]).bexs #'0) t u + +end ObjectArithmetic +end Bootstrapping +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/FixedPoint.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/FixedPoint.lean new file mode 100644 index 000000000..7ddbf9541 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/FixedPoint.lean @@ -0,0 +1,316 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Basic.Model +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax + +/-! Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace FFL +namespace FirstOrder +namespace Arithmetic + +variable {V : Type*} [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +namespace Bootstrapping +namespace ObjectArithmetic + +-- `Arithmetic` is intentionally re-opened here even though the ambient namespace +-- already contains it; renaming would break the widely-used public API +-- (`Bootstrapping.ObjectArithmetic.*`). Suppress the new dupNamespace linter for the +-- declarations in this namespace (the option is scoped by `namespace`/`end` and +-- reverts automatically at `end Bootstrapping.ObjectArithmetic`). + +/-- +The subst Numeral construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic`. -/ +noncomputable def substNumeral (φ x : V) : V := + subst ℒₒᵣ ?[numeral x] φ + +lemma substNumeral_app_quote (σ π : ArithmeticSemisentence 1) : + substNumeral ⌜σ⌝ (⌜π⌝ : V) = ⌜(σ/[⌜π⌝] : ArithmeticSentence)⌝ := by + simp [substNumeral, Sentence.quote_def, Semiformula.quote_def, + Rewriting.emb_subst_eq_subst_coe₁] + +/-- +The subst Numerals construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic`. -/ +noncomputable def substNumerals (φ : V) (v : Fin k → V) : V := + subst ℒₒᵣ (matrixToVec (fun i ↦ numeral (v i))) φ + +lemma substNumerals_app_quote (σ : ArithmeticSemisentence k) (v : Fin k → ℕ) : + (substNumerals ⌜σ⌝ (v ·) : V) = ⌜((Rew.subst (fun i ↦ ↑(v i))) ▹ σ : ArithmeticSentence)⌝ := + by + simp [substNumerals, Sentence.quote_def, Semiformula.quote_def, + Rewriting.emb_subst_eq_subst_emb] + rfl + +lemma substNumerals_app_quote_quote (σ : ArithmeticSemisentence k) + (π : Fin k → ArithmeticSemisentence k) : + substNumerals (⌜σ⌝ : V) (fun i ↦ ⌜π i⌝) = + ⌜((Rew.subst (fun i ↦ ⌜π i⌝)) ▹ σ : ArithmeticSentence)⌝ := + by + simpa [Sentence.coe_quote_eq_quote] using substNumerals_app_quote (V := V) σ (fun i ↦ ⌜π i⌝) + +/-- The subst Numeral Params construction in +`FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic`. -/ +noncomputable def substNumeralParams (k : ℕ) (φ x : V) : V := + subst ℒₒᵣ (matrixToVec (numeral x :> fun i : Fin k ↦ qqBvar i)) φ + +lemma substNumeralParams_app_quote (σ τ : ArithmeticSemisentence (k + 1)) : + (substNumeralParams k ⌜σ⌝ ⌜τ⌝ : V) = + ⌜((Rew.subst (⌜τ⌝ :> fun i : Fin k ↦ #i)) ▹ σ : ArithmeticSemisentence k)⌝ := + by + simp [substNumeralParams, Sentence.quote_def, Semiformula.quote_def, + Rewriting.emb_subst_eq_subst_emb, Matrix.vecHead] + rfl + +section + +/-- The ssnum construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic`. -/ +noncomputable def ssnum : Σ₁.Semisentence 3 := .mkSigma + “y φ x. ∃ n, !numeralGraph n x ∧ ∃ v, !adjoinDef v n 0 ∧ !(substsGraph ℒₒᵣ) y v φ” + +instance substNumeral.defined : Σ₁-Function₂ (substNumeral : V → V → V) via ssnum := + .mk fun v ↦ by simp [ssnum, substNumeral] + +instance substNumeral.definable : Σ₁-Function₂ (substNumeral : V → V → V) := + substNumeral.defined.to_definable + +attribute [irreducible] ssnum + +/-- The ssnums construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic`. -/ +noncomputable def ssnums : Σ₁.Semisentence (k + 2) := .mkSigma + “y φ. ∃ n, !lenDef ↑k n ∧ + (⋀ i, ∃ z, !nthDef z n ↑(i : Fin k).val ∧ !numeralGraph z #i.succ.succ.succ.succ) ∧ + !(substsGraph ℒₒᵣ) y n φ” + +instance substNumerals.defined : + Arithmetic.HierarchySymbol.DefinedFunction + (fun v ↦ substNumerals (v 0) (v ·.succ) : (Fin (k + 1) → V) → V) ssnums := + .mk fun v ↦ by + unfold ssnums + symm + suffices + v 0 = subst ℒₒᵣ (matrixToVec fun i ↦ numeral (v i.succ.succ)) (v 1) ↔ + ∃ x, + ↑k = len x ∧ + (∀ i : Fin k, x.[↑↑i] = numeral (v i.succ.succ)) ∧ v 0 = subst ℒₒᵣ x (v 1) + by simpa [ssnums, substNumerals, numeral_eq_natCast] + constructor + · intro h + refine ⟨matrixToVec fun i ↦ numeral (v i.succ.succ), ?_⟩ + simpa + · rintro ⟨x, hx, h, e⟩ + suffices (matrixToVec fun i ↦ numeral (v i.succ.succ)) = x by simpa [this] + apply nth_ext' (k : V) + · simp + · simp [hx] + · intro i hi + rcases eq_fin_of_lt_nat hi with ⟨i, rfl⟩ + simp [h] + +attribute [irreducible] ssnums + +/-- The ssnum Params construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic`. -/ +noncomputable def ssnumParams (k : ℕ) : Σ₁.Semisentence 3 := .mkSigma + “y φ x. ∃ v, !lenDef ↑(k + 1) v ∧ + (∃ z, !nthDef z v 0 ∧ !numeralGraph z x) ∧ + (⋀ i, ∃ z, !nthDef z v ↑(i : Fin k).val.succ ∧ !qqBvarDef z ↑i) ∧ + !(substsGraph ℒₒᵣ) y v φ” + +instance ssnumParams.defined : Σ₁-Function₂[V] substNumeralParams k via ssnumParams k := + .mk fun v ↦ by + symm + unfold ssnumParams + suffices + v 0 = subst ℒₒᵣ (numeral (v 2) ∷ matrixToVec fun i ↦ ^#↑i) (v 1) ↔ + ∃ x, + ↑(k + 1) = len x ∧ + x.[0] = numeral (v 2) ∧ (∀ (i : Fin k), x.[↑i + 1] = ^#↑i) ∧ v 0 = subst ℒₒᵣ x (v 1) + by simpa [ssnumParams, substNumeralParams, numeral_eq_natCast] + constructor + · intro h + use numeral (v 2) ∷ matrixToVec fun i : Fin k ↦ ^#↑i + simpa + · rintro ⟨w, wlen, h0, hsucc, he⟩ + suffices (numeral (v 2) ∷ matrixToVec fun i : Fin k ↦ ^#↑i) = w by simp [this, he] + apply nth_ext' ((k + 1 : ℕ) : V) (by simp) wlen.symm + intro i hi + rcases zero_or_succ i with (rfl | ⟨i, rfl⟩) + · simp [h0] + · have hi : i < ↑k := by simpa using hi + rcases eq_fin_of_lt_nat hi with ⟨i, rfl⟩ + simp [hsucc] + +end + +end ObjectArithmetic +end Bootstrapping + +open Bootstrapping Bootstrapping.ObjectArithmetic + +variable {T : ArithmeticTheory} [𝐈Σ₁ ≼ T] + +section Diagonalization + +/-- The diag construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def diag (θ : ArithmeticSemisentence 1) : ArithmeticSemisentence 1 := + “x. ∀ y, !ssnum y x x → !θ y” + +/-- The fixedpoint construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def fixedpoint (θ : ArithmeticSemisentence 1) : ArithmeticSentence := + (diag θ)/[⌜diag θ⌝] + +theorem diagonal (θ : ArithmeticSemisentence 1) : T ⊢ fixedpoint θ ⇔ₗ θ/[⌜fixedpoint θ⌝] := + haveI : 𝐄𝐐 _ ≼ T := Entailment.WeakerThan.trans (𝓣 := 𝐈Σ₁) inferInstance inferInstance + complete.{0} T _ fun (V : Type) _ _ ↦ + by + have : V↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := ModelsTheory.of_provably_subtheory V 𝐈Σ₁ T inferInstance + suffices V ⊧/![] (fixedpoint θ) ↔ V ⊧/![⌜fixedpoint θ⌝] θ by + simpa [models_iff, Matrix.constant_eq_singleton] + let t : V := ⌜diag θ⌝ + have ht : substNumeral t t = ⌜fixedpoint θ⌝ := by + simp [t, fixedpoint, substNumeral_app_quote] + calc + V ⊧/![] (fixedpoint θ) + _ ↔ V ⊧/![t] (diag θ) := by simp [fixedpoint, t] + _ ↔ V ⊧/![substNumeral t t] θ := by simp [diag] + _ ↔ V ⊧/![⌜fixedpoint θ⌝] θ := by simp [ht] + +end Diagonalization + +section Multidiagonalization + +/-- +$\mathrm{diag}_i(\vec{x}) := (\forall \vec{y})\left[ \left(\bigwedge_j \mathrm{ssnums}(y_j, x_j, +\vec{x})\right) \to \theta_i(\vec{y}) \right]$ -/ +noncomputable def multidiag (θ : ArithmeticSemisentence k) : ArithmeticSemisentence k := + ∀¹^[k] + ((Matrix.conj fun j : Fin k ↦ + (Rew.subst <| #((Fin.addCast k j)) :> #(j.addNat k) :> fun l ↦ #(l.addNat k)) ▹ + ssnums.val) ⇒ₗ + (Rew.subst fun j ↦ #((Fin.addCast k j))) ▹ θ) + +/-- The multifixedpoint construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def multifixedpoint (θ : Fin k → ArithmeticSemisentence k) (i : Fin k) : + ArithmeticSentence := + (Rew.subst fun j ↦ ⌜multidiag (θ j)⌝) ▹ (multidiag (θ i)) + +theorem multidiagonal (θ : Fin k → ArithmeticSemisentence k) : + T ⊢ multifixedpoint θ i ⇔ₗ (Rew.subst fun j ↦ ⌜multifixedpoint θ j⌝) ▹ (θ i) := + haveI : 𝐄𝐐 _ ≼ T := Entailment.WeakerThan.trans (𝓣 := 𝐈Σ₁) inferInstance inferInstance + complete.{0} T _ fun (V : Type) _ _ ↦ by + have : V↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := ModelsTheory.of_provably_subtheory V 𝐈Σ₁ T inferInstance + suffices V ⊧/![] (multifixedpoint θ i) ↔ V ⊧/(fun i ↦ ⌜multifixedpoint θ i⌝) (θ i) by + simpa [models_iff, Function.comp_def, Matrix.empty_eq] + let t : Fin k → V := fun i ↦ ⌜multidiag (θ i)⌝ + have ht : ∀ i, substNumerals (t i) t = ⌜multifixedpoint θ i⌝ := by + intro i; simp [t, multifixedpoint, substNumerals_app_quote_quote] + calc + V ⊧/![] (multifixedpoint θ i) + ↔ V ⊧/t (multidiag (θ i)) := by simp [t, multifixedpoint, + Function.comp_def] + _ ↔ V ⊧/(fun i ↦ substNumerals (t i) t) (θ i) := by simp [multidiag, ← funext_iff, + Function.comp_def] + _ ↔ V ⊧/(fun i ↦ ⌜multifixedpoint θ i⌝) (θ i) := by simp [ht] + +/-- The exclusive Multifixedpoint construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def exclusiveMultifixedpoint (θ : Fin k → ArithmeticSemisentence k) (i : Fin k) : + ArithmeticSentence := + multifixedpoint (fun j ↦ (θ j).padding j) i + +@[simp] +lemma exclusiveMultifixedpoint_inj_iff (θ : Fin k → ArithmeticSemisentence k) : + exclusiveMultifixedpoint θ i = exclusiveMultifixedpoint θ j ↔ i = j := + by + constructor + · unfold exclusiveMultifixedpoint multifixedpoint + suffices + ∀ ω : Rew ℒₒᵣ Empty k Empty 0, + ω ▹ multidiag ((θ i).padding i) = ω ▹ multidiag ((θ j).padding j) → i = j + by exact this _ + intro + simp [multidiag, Fin.val_inj] + · rintro rfl; rfl + +theorem exclusiveMultidiagonal (θ : Fin k → ArithmeticSemisentence k) : + T ⊢ + exclusiveMultifixedpoint θ i ⇔ₗ + (Rew.subst fun j ↦ ⌜exclusiveMultifixedpoint θ j⌝) ▹ θ i := + by + have : + T ⊢ + exclusiveMultifixedpoint θ i ⇔ₗ + ((Rew.subst fun j ↦ ⌜exclusiveMultifixedpoint θ j⌝) ▹ θ i).padding ↑i := + by simpa using! multidiagonal (T := T) (fun j ↦ (θ j).padding j) (i := i) + exact Entailment.E_trans this (Entailment.padding_iff _ _) + +lemma multifixedpoint_pi {θ : Fin k → ArithmeticSemisentence k} + (h : ∀ i, Hierarchy Π (m + 1) (θ i)) : Hierarchy Π (m + 1) (multifixedpoint θ i) := by + simpa [multifixedpoint, multidiag, h] using fun _ ↦ + Hierarchy.mono (s := 1) (by simp) (by simp) + +lemma exclusiveMultifixedpoint_pi {θ : Fin k → ArithmeticSemisentence k} + (h : ∀ i, Hierarchy Π (m + 1) (θ i)) : Hierarchy Π (m + 1) (exclusiveMultifixedpoint θ i) := + by apply multifixedpoint_pi; simp [h] + +end Multidiagonalization + +section ParameterizedDiagonalization + +/-- The parameterized Diag construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def parameterizedDiag (θ : ArithmeticSemisentence (k + 1)) : + ArithmeticSemisentence (k + 1) := + “x. ∀ y, !(ssnumParams k)y x x → !θ y⋯” + +/-- The parameterized Fixedpoint construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def parameterizedFixedpoint (θ : ArithmeticSemisentence (k + 1)) : + ArithmeticSemisentence k := + (Rew.subst (⌜parameterizedDiag θ⌝ :> fun j ↦ #j)) ▹ parameterizedDiag θ + +theorem parameterized_diagonal (θ : ArithmeticSemisentence (k + 1)) : + T ⊢ ∀¹* (parameterizedFixedpoint θ ⇔ₗ “!θ !!(⌜parameterizedFixedpoint θ⌝) ⋯”) := + haveI : 𝐄𝐐 _ ≼ T := Entailment.WeakerThan.trans (𝓣 := 𝐈Σ₁) inferInstance inferInstance + complete.{0} T _ fun (V : Type) _ _ ↦ by + have : V↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := ModelsTheory.of_provably_subtheory V 𝐈Σ₁ T inferInstance + suffices + ∀ params : Fin k → V, + V ⊧/params (parameterizedFixedpoint θ) ↔ V ⊧/(⌜parameterizedFixedpoint θ⌝ :> params) θ by + simpa [models_iff, Matrix.comp_vecCons', BinderNotation.finSuccItr, Function.comp_def, + Matrix.empty_eq] + intro params + let t : V := ⌜parameterizedDiag θ⌝ + have ht : substNumeralParams k t t = ⌜parameterizedFixedpoint θ⌝ := by + simp [t, substNumeralParams_app_quote, parameterizedFixedpoint] + calc + V ⊧/params (parameterizedFixedpoint θ) + ↔ V ⊧/(t :> params) (parameterizedDiag θ) := by simp [parameterizedFixedpoint, + Matrix.comp_vecCons', t, Function.comp_def] + _ ↔ V ⊧/(substNumeralParams k t t :> params) θ := by simp [parameterizedDiag, + Matrix.comp_vecCons', BinderNotation.finSuccItr, Function.comp_def] + _ ↔ V ⊧/(⌜parameterizedFixedpoint θ⌝ :> params) θ := by simp [ht] + +theorem parameterized_diagonal₁ (θ : ArithmeticSemisentence 2) : + T ⊢ ∀¹ (parameterizedFixedpoint θ ⇔ₗ θ/[⌜parameterizedFixedpoint θ⌝, #0]) := by + simpa [allClosure, BinderNotation.finSuccItr, Matrix.fun_eq_vec_one] using + parameterized_diagonal (T := T) θ + +end ParameterizedDiagonalization + +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax.lean new file mode 100644 index 000000000..7ff9f11a7 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax.lean @@ -0,0 +1,31 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Language +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Term.Basic +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Term.Functions +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Term.Typed +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Term.Coding +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Formula.Basic +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Formula.Functions +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Formula.Iteration +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Formula.Typed +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Formula.Coding +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Theory +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Proof.Basic +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Proof.Typed +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Proof.Coding + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/CraigTrick.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/CraigTrick.lean new file mode 100644 index 000000000..2a4bb11a8 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/CraigTrick.lean @@ -0,0 +1,433 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.ISigma1.Prenex +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.R0.Representation +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Theory +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Formula.Iteration +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Syntax.Classical.Padding +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Syntax.Classical.PrimrecCoding + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# Craig's trick + +The Craig companion of a recursively enumerable theory is moreover primitive recursive. +-/ + +@[expose] public section + +namespace FFL +namespace FirstOrder +namespace Semiformula + +open Encodable + +variable {L : Language} {ξ : Type*} {n : ℕ} + +lemma weight_succ (k : ℕ) : (weight (k + 1) : Semiformula L ξ n) = ⊤ ⋏ weight k := by + simp [weight, List.replicate_succ]; + +variable [L.Encodable] [Encodable ξ] + +lemma encode_weight_succ (k : ℕ) : + encode (weight (k + 1) : Semiformula L ξ n) = + Nat.pair 4 + (Nat.pair (encode (⊤ : Semiformula L ξ n)) (encode (weight k : Semiformula L ξ n))) + + 1 := + by rw [weight_succ]; rfl; + +private lemma left_lt_pair4 (a b : ℕ) : a < Nat.pair 4 (Nat.pair a b) + 1 := by + have := Nat.left_le_pair a b; have := Nat.right_le_pair 4 (Nat.pair a b); omega; + +private lemma right_lt_pair4 (a b : ℕ) : b < Nat.pair 4 (Nat.pair a b) + 1 := by + have := Nat.right_le_pair a b; have := Nat.right_le_pair 4 (Nat.pair a b); omega; + +lemma le_encode_weight (k : ℕ) : k ≤ encode (weight k : Semiformula L ξ n) := by + induction k with + | zero => + simp + | succ k ih => + simp only [encode_weight_succ]; + exact Nat.succ_le_of_lt (lt_of_le_of_lt ih (right_lt_pair4 _ _)); + +lemma encode_padding (φ : Semiformula L ξ n) (k : ℕ) : + encode (φ.padding k) = + Nat.pair 4 (Nat.pair (encode φ) (encode (weight k : Semiformula L ξ n))) + 1 := + rfl + +lemma encode_lt_encode_padding (φ : Semiformula L ξ n) (k : ℕ) : + encode φ < encode (φ.padding k) := by simp only [encode_padding]; exact left_lt_pair4 _ _; + +lemma lt_encode_padding (φ : Semiformula L ξ n) (k : ℕ) : k < encode (φ.padding k) := by + simp only [encode_padding]; + exact lt_of_le_of_lt (le_encode_weight (L := L) (ξ := ξ) (n := n) k) (right_lt_pair4 _ _); + +lemma primrec_encode_weight : Primrec fun k : ℕ ↦ encode (weight k : Semiformula L ξ n) := by + have step : + Primrec₂ fun _ r : ℕ ↦ Nat.pair 4 (Nat.pair (encode (⊤ : Semiformula L ξ n)) r) + 1 := + Primrec.nat_add.comp + (Primrec₂.natPair.comp (Primrec.const 4) + (Primrec₂.natPair.comp (Primrec.const (encode (⊤ : Semiformula L ξ n))) Primrec.snd)) + (Primrec.const 1); + refine (Primrec.nat_rec₁ (encode (⊤ : Semiformula L ξ n)) step).of_eq ?_; intro k; + induction k with + | zero => simp [weight] + | succ k ih => simp [encode_weight_succ, ih] + +end Semiformula +end FirstOrder +end FFL + +namespace FFL +namespace FirstOrder +namespace Theory + +open FFL.FirstOrder.Arithmetic + +variable {L : Language} [L.Encodable] + +section + +variable + [L.Primcodable] + -- `[T.RE]` is spelled out instead of taken from a `variable`: the body does not use it, so Lean + -- would drop it from the signature and allow an arbitrary theory as the Craig companion. + +/-- The re Ch construction in `FFL.FirstOrder.Theory`. -/ +noncomputable def reCh (T : Theory L) : Σ₁.Semisentence 1 := + .mkSigma (codeOfREPred (Encodable.encode '' T)) <| by simp [codeOfREPred, codeOfPartrec'] + +variable (T : Theory L) [T.RE] + +/-- The re Witness construction in `FFL.FirstOrder.Theory`. -/ +noncomputable def reWitness : Σ₀.Semisentence 2 := + (ISigma1.exists_matrix_provable T.reCh.sigma_prop).choose + +omit [T.RE] in +omit [L.Primcodable] in +lemma reWitness_spec (V : Type) [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] (e : Fin 1 → V) : + V ⊧/e T.reCh.val ↔ ∃ w, V ⊧/(w :> e) T.reWitness.val := + (models_iff_of_provable_iff (ISigma1.exists_matrix_provable T.reCh.sigma_prop).choose_spec V + e).trans + Semiformula.eval_ex + +@[simp, grind .] +lemma rePred_codes_of_RE : REPred (Encodable.encode '' T) := + (PointwiseComposition.REPred.projection + ((PointwiseComposition.REPred.and (Theory.RE.re.comp Computable.snd)) + (PrimrecPred.computablePred + (Primrec.eq.comp (Primrec.encode.comp Primrec.snd) Primrec.fst)).to_re)).of_eq + fun _ ↦ Iff.rfl + +variable [L.LORDefinable] + +lemma exists_mem_of_reCh (φ : Proposition L) (h : ℕ ⊧/![⌜φ⌝] T.reCh.val) : ∃ σ ∈ T, φ = σ := by + rcases (Set.mem_image ..).mp ((codeOfREPred_spec (rePred_codes_of_RE T)).mp h) with + ⟨σ, hσ, hσφ⟩; + exact + ⟨σ, hσ, + Semiformula.encode_inj_sentence.mp + (by simpa [Semiformula.quote_eq_encode_nat] using hσφ)⟩; + +lemma mem_of_reCh (σ : Sentence L) (h : ℕ ⊧/![⌜σ⌝] T.reCh.val) : σ ∈ T := by + rcases (Set.mem_image ..).mp ((codeOfREPred_spec (rePred_codes_of_RE T)).mp h) with + ⟨ρ, hρ, hρσ⟩; + rwa [Encodable.encode_inj.mp (hρσ.trans (Sentence.quote_eq_encode_nat σ))] at hρ; + +lemma reCh_of_mem (σ : Sentence L) (hσ : σ ∈ T) : ℕ ⊧/![⌜σ⌝] T.reCh.val := + (codeOfREPred_spec (rePred_codes_of_RE T)).mpr + ((Set.mem_image ..).mpr + ⟨σ, hσ, by simp [Sentence.quote_def, Semiformula.quote_eq_encode_nat]⟩) + +/-- The craig construction in `FFL.FirstOrder.Theory`. -/ +def craig : Theory L := + {φ | ∃ (σ : Sentence L) (s : ℕ), ℕ ⊧/![(s : ℕ), ⌜σ⌝] T.reWitness.val ∧ φ = σ.padding s} + +end + +end Theory +end FirstOrder +end FFL + +namespace FFL +namespace FirstOrder +namespace Arithmetic +namespace Bootstrapping + +variable {L : Language} [L.Encodable] [L.LORDefinable] + +lemma quote_eq_qqAnd_iff {φ : Proposition L} {p q : ℕ} : + (⌜φ⌝ : ℕ) = p ^⋏ q ↔ ∃ φ₁ φ₂, φ = φ₁ ⋏ φ₂ ∧ p = ⌜φ₁⌝ ∧ q = ⌜φ₂⌝ := + by + constructor + · intro h + cases φ with + | rel + | nrel => simp [qqRel, qqNRel, qqAnd] at h + | verum => change qqVerum = p ^⋏ q at h; simp [qqVerum, qqAnd] at h + | falsum => change qqFalsum = p ^⋏ q at h; simp [qqFalsum, qqAnd] at h + | or φ₁ φ₂ => change ⌜φ₁⌝ ^⋎ ⌜φ₂⌝ = p ^⋏ q at h; simp [qqOr, qqAnd] at h + | all φ => change ^∀ ⌜φ⌝ = p ^⋏ q at h; simp [qqAll, qqAnd] at h + | exs φ => + change ^∃ ⌜φ⌝ = p ^⋏ q at h + simp [qqExs, qqAnd] at h + | and φ₁ φ₂ => + rcases (qqAnd_inj _ _ _ _).mp h with ⟨rfl, rfl⟩ + exact ⟨φ₁, φ₂, rfl, rfl, rfl⟩ + · rintro ⟨φ₁, φ₂, rfl, rfl, rfl⟩; rfl + +section + +variable {V : Type*} [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +lemma quote_weight (k : ℕ) : + (⌜(Semiformula.weight k : Proposition L)⌝ : V) = qqVerums (k : V) := by + induction k with + | zero => simp [Semiformula.weight] + | succ k ih => + change ⌜(⊤ : Proposition L) ⋏ Semiformula.weight k⌝ = _ + simp [ih] + +lemma quote_padding (φ : Proposition L) (k : ℕ) : + (⌜φ.padding k⌝ : V) = ⌜φ⌝ ^⋏ qqVerums (k : V) := + by + change ⌜φ ⋏ Semiformula.weight k⌝ = _ + simp [quote_weight] + +namespace Sentence + +lemma quote_padding (σ : Sentence L) (k : ℕ) : (⌜σ.padding k⌝ : V) = ⌜σ⌝ ^⋏ qqVerums (k : V) := + by + simpa [Sentence.quote_def] using + FFL.FirstOrder.Arithmetic.Bootstrapping.quote_padding (V := V) (Rewriting.emb σ) k + +end Sentence + +end + +lemma quote_eq_qqVerums {χ : Proposition L} {s : ℕ} : + (⌜χ⌝ : ℕ) = qqVerums (s : ℕ) → χ = Semiformula.weight s := by + intro h; + exact (Semiformula.quote_inj_iff (V := ℕ)).mp <| by simpa [quote_weight] using h + +variable {V : Type*} [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] [L.Primcodable] + +section + +variable (T : Theory L) [T.RE] + +/-- The Is Craig Axiom construction in `FFL.FirstOrder.Theory`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Theory.IsCraigAxiom : V → Prop := fun x ↦ + ∃ s p : V, x = p ^⋏ qqVerums s ∧ V ⊧/![s, p] T.reWitness.val + +/-- The craig Ch construction in `FFL.FirstOrder.Theory`. -/ +noncomputable def _root_.PointwiseComposition.FFL.FirstOrder.Theory.craigCh : + ∆₁.Semisentence 1 := + .mkDelta + (.mkSigma + (“x. + ∃ s < x, + ∃ p < x, ∃ v < x, !qqVerumsGraph v s ∧ !qqAndDef x p v ∧ !(T.reWitness.val)s p”)) + (.mkPi + (“x. + ∃ s < x, + ∃ p < x, + ∃ v < x, + (∀ v', !qqVerumsGraph v' s → v' = v) ∧ !qqAndDef x p v ∧ !(T.reWitness.val)s p”)) + +end + +instance Theory.IsCraigAxiom.defined {T : Theory L} : + ∆₁-Predicate[V] (T.IsCraigAxiom : V → Prop) via T.craigCh := + .mk <| + by + have h (v : Fin 1 → V) : + (∃ s < v 0, + ∃ p < v 0, + qqVerums s < v 0 ∧ + v 0 = p ^⋏ qqVerums s ∧ (Semiformula.Eval ![s, p] Empty.elim) T.reWitness.val) ↔ + ∃ s p, v 0 = p ^⋏ qqVerums s ∧ (Semiformula.Evalb ![s, p]) T.reWitness.val := + by + constructor + · rintro ⟨s, _, p, _, _, h, hT⟩; use s, p; + · rintro ⟨s, p, hx, hT⟩; + exact + ⟨s, hx ▸ lt_of_le_of_lt (le_qqVerums s) (lt_KProof_right _ _), p, + hx ▸ lt_KProof_left _ _, hx ▸ lt_KProof_right _ _, hx, hT⟩ + constructor + · intro v; simp [Theory.craigCh, h] + · intro v; simp [Theory.craigCh, Theory.IsCraigAxiom, h] + +lemma Theory.isCraigAxiom_quote_iff {T : Theory L} [T.RE] (φ : Proposition L) : + T.IsCraigAxiom (⌜φ⌝ : ℕ) ↔ ∃ ρ ∈ T.craig, φ = ρ := + by + constructor + · rintro ⟨s, p, hφ, hT⟩ + rcases quote_eq_qqAnd_iff.mp hφ with ⟨φ₁, φ₂, hφ, hp, hs⟩ + have hφ₂ : φ₂ = Semiformula.weight s := quote_eq_qqVerums hs.symm + have h₁ : ℕ ⊧/![p] T.reCh.val := (Theory.reWitness_spec T ℕ ![p]).mpr ⟨s, hT⟩ + rcases T.exists_mem_of_reCh φ₁ (by simpa [hp] using h₁) with ⟨ρ, hρ, hρ'⟩ + use ρ.padding s + and_intros + · use ρ, s + and_intros + · simpa [hp, hρ', Sentence.quote_def] using hT + · rfl + · rw [Semiformula.rew_padding] + simpa [Semiformula.padding, Semiformula.weight, hρ', hφ₂] using hφ + · rintro ⟨ρ, ⟨σ, s, hT, rfl⟩, rfl⟩ + use s, ⌜σ⌝ + and_intros + · simpa [Sentence.quote_def] using Sentence.quote_padding (V := ℕ) σ s + · exact hT + +end Bootstrapping +end Arithmetic +end FirstOrder +end FFL + +namespace FFL +namespace FirstOrder +namespace Theory + +open Arithmetic.Bootstrapping + +open FFL.Entailment + +open Encodable + +variable {L : Language} [L.Encodable] [L.LORDefinable] [L.Primcodable] {T : Theory L} [T.RE] + +omit [T.RE] in +omit [L.Primcodable] in +lemma mem_craig_codes_iff (n : ℕ) : + n ∈ Encodable.encode '' T.craig ↔ + ∃ s < n, + ∃ m < n, + (decode₂ (Sentence L) m).isSome ∧ + n = Nat.pair 4 (Nat.pair m (encode (Semiformula.weight s : Sentence L))) + 1 ∧ + ℕ ⊧/![s, m] T.reWitness.val := by + constructor + · rintro ⟨φ, ⟨σ, s, hs, rfl⟩, rfl⟩; + use s, Semiformula.lt_encode_padding σ s, encode σ, + Semiformula.encode_lt_encode_padding σ s; + and_intros; · simp; + · exact (Semiformula.encode_padding σ s).symm; + · simpa [Sentence.quote_def, Semiformula.quote_eq_encode] using hs; + · rintro ⟨s, _, m, _, hm, hn, hT⟩; obtain ⟨σ, hσ⟩ := Option.isSome_iff_exists.mp hm; + have hσm : encode σ = m := decode₂_eq_some.mp hσ; use σ.padding s; and_intros; + · use σ, s; and_intros; + · simpa [Sentence.quote_def, Semiformula.quote_eq_encode, hσm] using hT; + · rfl; + · exact + (Semiformula.encode_padding σ s).trans <| by simpa [hσm] using hn.symm; + -- `p = (m, (n, s))`: `m` is the sentence code, `n` is the candidate craig axiom code, + -- `s` is the padding index. + +omit [L.LORDefinable] in +omit [T.RE] in +lemma primrecPred_craig_core : + PrimrecPred fun p : ℕ × (ℕ × ℕ) ↦ + (decode₂ (Sentence L) p.1).isSome ∧ + p.2.1 = Nat.pair 4 (Nat.pair p.1 (encode (Semiformula.weight p.2.2 : Sentence L))) + 1 ∧ + ℕ ⊧/![p.2.2, p.1] T.reWitness.val := + by + have hm : Primrec fun p : ℕ × (ℕ × ℕ) ↦ p.1 := Primrec.fst; + have hn : Primrec fun p : ℕ × (ℕ × ℕ) ↦ p.2.1 := Primrec.fst.comp Primrec.snd; + have hs : Primrec fun p : ℕ × (ℕ × ℕ) ↦ p.2.2 := Primrec.snd.comp Primrec.snd; + have hweight : Primrec fun p : ℕ × (ℕ × ℕ) ↦ encode (Semiformula.weight p.2.2 : Sentence L) := + Semiformula.primrec_encode_weight.comp hs; + have hdecode : PrimrecPred fun p : ℕ × (ℕ × ℕ) ↦ (decode₂ (Sentence L) p.1).isSome := by + simpa using + Primrec.eq.comp (Primrec.option_isSome.comp (Primrec.decode₂.comp hm)) + (Primrec.const true); + have heq : + PrimrecPred fun p : ℕ × (ℕ × ℕ) ↦ + p.2.1 = Nat.pair 4 (Nat.pair p.1 (encode (Semiformula.weight p.2.2 : Sentence L))) + 1 := + Primrec.eq.comp hn + (Primrec.nat_add.comp + (Primrec₂.natPair.comp (Primrec.const 4) (Primrec₂.natPair.comp hm hweight)) + (Primrec.const 1)); + have heval : PrimrecPred fun p : ℕ × (ℕ × ℕ) ↦ ℕ ⊧/![p.2.2, p.1] T.reWitness.val := + ((Arithmetic.delta0_primrec Empty.elim T.reWitness.sigma_prop).comp + (Primrec.vector_cons.comp hs + (Primrec.vector_cons.comp hm (Primrec.const List.Vector.nil)))).of_eq + fun p ↦ by simp [List.Vector.cons_get]; + exact hdecode.and (heq.and heval); + +omit [T.RE] in +lemma primrecPred_craig_codes : PrimrecPred (· ∈ Encodable.encode '' T.craig) := by + refine PrimrecPred.of_eq ?_ fun n ↦ (mem_craig_codes_iff n).symm; + have hinner : + PrimrecPred fun p : ℕ × ℕ ↦ + ∃ m < p.1, + (decode₂ (Sentence L) m).isSome ∧ + p.1 = Nat.pair 4 (Nat.pair m (encode (Semiformula.weight p.2 : Sentence L))) + 1 ∧ + ℕ ⊧/![p.2, m] T.reWitness.val := + ((PrimrecRel.exists_mem_list (primrecPred_craig_core (T := T)).primrecRel).comp + (Primrec.list_range.comp Primrec.fst) Primrec.id).of_eq + (by simp); + exact + ((PrimrecRel.exists_mem_list + (hinner.comp (Primrec.pair Primrec.snd Primrec.fst)).primrecRel).comp + Primrec.list_range Primrec.id).of_eq + (by simp); + +instance : T.craig.Primrec := + ⟨((primrecPred_craig_codes (T := T)).comp Primrec.encode).of_eq fun _ ↦ by simp⟩ + +section + +noncomputable instance : (T.craig).Δ₁ + where + ch := T.craigCh + mem_iff + φ := + (Theory.IsCraigAxiom.defined (V := ℕ) (T := T)).iff.trans (Theory.isCraigAxiom_quote_iff φ) + isDelta1 := + Arithmetic.HierarchySymbol.Semiformula.ProvablyProperOn.ofProperOn.{0} _ fun V _ _ ↦ + (Theory.IsCraigAxiom.defined (V := V) (T := T)).proper + +variable [L.DecidableEq] + +instance : T.craig ≼ T := + WeakerThan.ofAxmProof <| by + rintro σ ⟨ρ, s, hρ, rfl⟩; + have hρ' : ℕ ⊧/![⌜ρ⌝] T.reCh.val := (reWitness_spec T ℕ ![⌜ρ⌝]).mpr ⟨s, hρ⟩ + have hρT : ρ ∈ T := T.mem_of_reCh ρ hρ' + exact mdp (C_of_E_mpr (Entailment.padding_iff ρ s)) (by_axm hρT) + +instance : T ≼ T.craig := + WeakerThan.ofAxmProof <| by + intro σ hσ; have hσ' : ℕ ⊧/![⌜σ⌝] T.reCh.val := T.reCh_of_mem σ hσ + rcases (reWitness_spec T ℕ ![⌜σ⌝]).mp hσ' with ⟨s, hs⟩ + have hpadding : σ.padding s ∈ T.craig := ⟨σ, s, hs, rfl⟩ + exact mdp (C_of_E_mp (Entailment.padding_iff σ s)) (by_axm hpadding) + +instance : T ≊ T.craig := + Equiv.antisymm_iff.mpr ⟨inferInstance, inferInstance⟩ + +instance [Consistent T] : Consistent T.craig := + Consistent.of_le inferInstance (inferInstance : T.craig ≼ T) + +end + +end Theory +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Formula/Basic.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Formula/Basic.lean new file mode 100644 index 000000000..2f8507da3 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Formula/Basic.lean @@ -0,0 +1,1906 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Term.Basic +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Induction + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace FFL +namespace FirstOrder +namespace Arithmetic +namespace Bootstrapping + +variable {V : Type*} [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +variable {L : Language} [L.Encodable] [L.LORDefinable] + +/-- The qq Rel construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def qqRel (k r v : V) : V := + ⟪0, k, r, v⟫ + 1 + +/-- The qq NRel construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def qqNRel (k r v : V) : V := + ⟪1, k, r, v⟫ + 1 + +/-- The qq Verum construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def qqVerum : V := + ⟪2, 0⟫ + 1 + +/-- The qq Falsum construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def qqFalsum : V := + ⟪3, 0⟫ + 1 + +/-- The qq And construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def qqAnd (p q : V) : V := + ⟪4, p, q⟫ + 1 + +/-- The qq Or construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def qqOr (p q : V) : V := + ⟪5, p, q⟫ + 1 + +/-- The qq All construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def qqAll (p : V) : V := + ⟪6, p⟫ + 1 + +/-- The qq Exs construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def qqExs (p : V) : V := + ⟪7, p⟫ + 1 + +/-- The «term^rel » construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +scoped prefix:max "^rel " => qqRel + +/-- The «term^nrel » construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +scoped prefix:max "^nrel " => qqNRel + +/-- The «term^⊤» construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +scoped notation "^⊤" => qqVerum + +/-- The «term^⊥» construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +scoped notation "^⊥" => qqFalsum + +/-- The «term ^⋏ » construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +scoped notation p:69 " ^⋏ " q:70 => qqAnd p q + +/-- The «term ^⋎ » construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +scoped notation p:68 " ^⋎ " q:69 => qqOr p q + +/-- The «term^∀ » construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +scoped notation "^∀ " p:64 => qqAll p + +/-- The «term^∃ » construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +scoped notation "^∃ " p:64 => qqExs p + +section + +/-- The qq Rel Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.qqRelDef : Σ₀.Semisentence 4 := + .mkSigma (“p k r v. ∃ p' < p, !pair₄Def p' 0k r v ∧ p = p' + 1”) + +/-- The qq NRel Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.qqNRelDef : Σ₀.Semisentence 4 := + .mkSigma (“p k r v. ∃ p' < p, !pair₄Def p' 1k r v ∧ p = p' + 1”) + +/-- The qq Verum Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.qqVerumDef : Σ₀.Semisentence 1 := + .mkSigma (“p. ∃ p' < p, !pairDef p' 2 0 ∧ p = p' + 1”) + +/-- The qq Falsum Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.qqFalsumDef : Σ₀.Semisentence 1 := + .mkSigma (“p. ∃ p' < p, !pairDef p' 3 0 ∧ p = p' + 1”) + +/-- The qq And Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.qqAndDef : Σ₀.Semisentence 3 := + .mkSigma (“r p q. ∃ r' < r, !pair₃Def r' 4p q ∧ r = r' + 1”) + +/-- The qq Or Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.qqOrDef : Σ₀.Semisentence 3 := + .mkSigma (“r p q. ∃ r' < r, !pair₃Def r' 5p q ∧ r = r' + 1”) + +/-- The qq All Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.qqAllDef : Σ₀.Semisentence 2 := + .mkSigma (“r p. ∃ r' < r, !pairDef r' 6p ∧ r = r' + 1”) + +/-- The qq Exs Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.qqExsDef : Σ₀.Semisentence 2 := + .mkSigma (“r p. ∃ r' < r, !pairDef r' 7p ∧ r = r' + 1”) + +instance qqRel_defined : Σ₀-Function₃ (qqRel : V → V → V → V) via qqRelDef := + .mk fun v ↦ by simp_all [qqRelDef, qqRel] + +instance qqNRel_defined : Σ₀-Function₃ (qqNRel : V → V → V → V) via qqNRelDef := + .mk fun v ↦ by simp_all [qqNRelDef, qqNRel] + +instance qqVerum_defined : Σ₀-Function₀ (qqVerum : V) via qqVerumDef := + .mk fun v ↦ by simp_all [qqVerumDef, qqVerum] + +instance qqFalsum_defined : Σ₀-Function₀ (qqFalsum : V) via qqFalsumDef := + .mk fun v ↦ by simp_all [qqFalsumDef, qqFalsum] + +instance qqAnd_defined : Σ₀-Function₂ (qqAnd : V → V → V) via qqAndDef := + .mk fun v ↦ by simp_all [qqAndDef, qqAnd] + +instance qqOr_defined : Σ₀-Function₂ (qqOr : V → V → V) via qqOrDef := + .mk fun v ↦ by simp_all [qqOrDef, numeral_eq_natCast, qqOr] + +instance qqForall_defined : Σ₀-Function₁ (qqAll : V → V) via qqAllDef := + .mk fun v ↦ by simp_all [qqAllDef, numeral_eq_natCast, qqAll] + +instance qqExsists_defined : Σ₀-Function₁ (qqExs : V → V) via qqExsDef := + .mk fun v ↦ by simp_all [qqExsDef, numeral_eq_natCast, qqExs] + +instance (ℌ : HierarchySymbol) : ℌ-Function₃ (qqRel : V → V → V → V) := + .of_zero qqRel_defined.to_definable + +instance (ℌ : HierarchySymbol) : ℌ-Function₃ (qqNRel : V → V → V → V) := + .of_zero qqNRel_defined.to_definable + +instance (ℌ : HierarchySymbol) : ℌ-Function₂ (qqAnd : V → V → V) := + .of_zero qqAnd_defined.to_definable + +instance (ℌ : HierarchySymbol) : ℌ-Function₂ (qqOr : V → V → V) := + .of_zero qqOr_defined.to_definable + +instance (ℌ : HierarchySymbol) : ℌ-Function₁ (qqAll : V → V) := + .of_zero qqForall_defined.to_definable + +instance (ℌ : HierarchySymbol) : ℌ-Function₁ (qqExs : V → V) := + .of_zero qqExsists_defined.to_definable + +end + +@[simp] +lemma qqRel_inj (k₁ r₁ v₁ k₂ r₂ v₂ : V) : + ^rel k₁ r₁ v₁ = ^rel k₂ r₂ v₂ ↔ k₁ = k₂ ∧ r₁ = r₂ ∧ v₁ = v₂ := by simp [qqRel] + +@[simp] +lemma qqNRel_inj (k₁ r₁ v₁ k₂ r₂ v₂ : V) : + ^nrel k₁ r₁ v₁ = ^nrel k₂ r₂ v₂ ↔ k₁ = k₂ ∧ r₁ = r₂ ∧ v₁ = v₂ := by simp [qqNRel] + +@[simp] +lemma qqAnd_inj (p₁ q₁ p₂ q₂ : V) : p₁ ^⋏ q₁ = p₂ ^⋏ q₂ ↔ p₁ = p₂ ∧ q₁ = q₂ := by simp [qqAnd] + +@[simp] +lemma qqOr_inj (p₁ q₁ p₂ q₂ : V) : p₁ ^⋎ q₁ = p₂ ^⋎ q₂ ↔ p₁ = p₂ ∧ q₁ = q₂ := by simp [qqOr] + +@[simp] +lemma qqAll_inj (p₁ p₂ : V) : ^∀ p₁ = ^∀ p₂ ↔ p₁ = p₂ := by simp [qqAll] + +@[simp] +lemma qqExs_inj (p₁ p₂ : V) : ^∃ p₁ = ^∃ p₂ ↔ p₁ = p₂ := by simp [qqExs] + +@[simp] +lemma arity_lt_rel (k r v : V) : k < ^rel k r v := + le_iff_lt_succ.mp <| le_trans (le_pair_left k ⟪r, v⟫) <| le_pair_right _ _ + +@[simp] +lemma r_lt_rel (k r v : V) : r < ^rel k r v := + le_iff_lt_succ.mp <| + le_trans (le_trans (le_pair_left _ _) <| le_pair_right _ _) <| le_pair_right _ _ + +@[simp] +lemma v_lt_rel (k r v : V) : v < ^rel k r v := + le_iff_lt_succ.mp <| + le_trans (le_trans (le_pair_right _ _) <| le_pair_right _ _) <| le_pair_right _ _ + +@[simp] +lemma arity_lt_nrel (k r v : V) : k < ^nrel k r v := + le_iff_lt_succ.mp <| le_trans (le_pair_left _ _) <| le_pair_right _ _ + +@[simp] +lemma r_lt_nrel (k r v : V) : r < ^nrel k r v := + le_iff_lt_succ.mp <| + le_trans (le_trans (le_pair_left _ _) <| le_pair_right _ _) <| le_pair_right _ _ + +@[simp] +lemma v_lt_nrel (k r v : V) : v < ^nrel k r v := + le_iff_lt_succ.mp <| + le_trans (le_trans (le_pair_right _ _) <| le_pair_right _ _) <| le_pair_right _ _ + +lemma nth_lt_qqRel_of_lt {i k r v : V} (hi : i < len v) : v.[i] < ^rel k r v := + lt_trans (nth_lt_self hi) (v_lt_rel _ _ _) + +lemma nth_lt_qqNRel_of_lt {i k r v : V} (hi : i < len v) : v.[i] < ^nrel k r v := + lt_trans (nth_lt_self hi) (v_lt_nrel _ _ _) + +@[simp] +lemma lt_KProof_left (p q : V) : p < p ^⋏ q := + le_iff_lt_succ.mp <| le_trans (le_pair_left _ _) <| le_pair_right _ _ + +@[simp] +lemma lt_KProof_right (p q : V) : q < p ^⋏ q := + le_iff_lt_succ.mp <| le_trans (le_pair_right _ _) <| le_pair_right _ _ + +@[simp] +lemma lt_or_left (p q : V) : p < p ^⋎ q := + le_iff_lt_succ.mp <| le_trans (le_pair_left _ _) <| le_pair_right _ _ + +@[simp] +lemma lt_or_right (p q : V) : q < p ^⋎ q := + le_iff_lt_succ.mp <| le_trans (le_pair_right _ _) <| le_pair_right _ _ + +@[simp] +lemma lt_forall (p : V) : p < ^∀ p := + le_iff_lt_succ.mp <| le_pair_right _ _ + +@[simp] +lemma lt_exists (p : V) : p < ^∃ p := + le_iff_lt_succ.mp <| le_pair_right _ _ + +namespace FormalizedFormula + +variable (L) + +/-- The Phi construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.FormalizedFormula`. -/ +def Phi (C : Set V) (p : V) : Prop := + (∃ k R v, L.IsRel k R ∧ IsUTermVec L k v ∧ p = ^rel k R v) ∨ + (∃ k R v, L.IsRel k R ∧ IsUTermVec L k v ∧ p = ^nrel k R v) ∨ + (p = ^⊤) ∨ + (p = ^⊥) ∨ + (∃ p₁ p₂, p₁ ∈ C ∧ p₂ ∈ C ∧ p = p₁ ^⋏ p₂) ∨ + (∃ p₁ p₂, p₁ ∈ C ∧ p₂ ∈ C ∧ p = p₁ ^⋎ p₂) ∨ + (∃ p₁, p₁ ∈ C ∧ p = ^∀ p₁) ∨ (∃ p₁, p₁ ∈ C ∧ p = ^∃ p₁) + +private lemma phi_iff (C p : V) : + Phi L {x | x ∈ C} p ↔ + (∃ k < p, ∃ r < p, ∃ v < p, L.IsRel k r ∧ IsUTermVec L k v ∧ p = ^rel k r v) ∨ + (∃ k < p, ∃ r < p, ∃ v < p, L.IsRel k r ∧ IsUTermVec L k v ∧ p = ^nrel k r v) ∨ + (p = ^⊤) ∨ + (p = ^⊥) ∨ + (∃ p₁ < p, ∃ p₂ < p, p₁ ∈ C ∧ p₂ ∈ C ∧ p = p₁ ^⋏ p₂) ∨ + (∃ p₁ < p, ∃ p₂ < p, p₁ ∈ C ∧ p₂ ∈ C ∧ p = p₁ ^⋎ p₂) ∨ + (∃ p₁ < p, p₁ ∈ C ∧ p = ^∀ p₁) ∨ (∃ p₁ < p, p₁ ∈ C ∧ p = ^∃ p₁) + where + mp := by + rintro (⟨k, r, v, hkr, hv, rfl⟩ | ⟨k, r, v, hkr, hv, rfl⟩ | H) + · left; refine ⟨k, ?_, r, ?_, v, ?_, hkr, hv, rfl⟩ <;> simp + · right; left; refine ⟨k, ?_, r, ?_, v, ?_, hkr, hv, rfl⟩ <;> simp + right; right + rcases H with (rfl | rfl | H) + · left; rfl + · right; left; rfl + right; right + rcases H with (⟨q, r, hp, hq, rfl⟩ | ⟨q, r, hp, hq, rfl⟩ | H) + · left; refine ⟨q, ?_, r, ?_, hp, hq, rfl⟩ <;> simp + · right; left; refine ⟨q, ?_, r, ?_, hp, hq, rfl⟩ <;> simp + right; right + rcases H with (⟨q, h, rfl⟩ | ⟨q, h, rfl⟩) + · left; refine ⟨q, ?_, h, rfl⟩; simp + · right; refine ⟨q, ?_, h, rfl⟩; simp + mpr := by + unfold Phi + rintro (⟨k, _, r, _, v, _, hkr, hv, rfl⟩ | ⟨k, _, r, _, v, _, hkr, hv, rfl⟩ | H) + · left; exact ⟨k, r, v, hkr, hv, rfl⟩ + · right; left; exact ⟨k, r, v, hkr, hv, rfl⟩ + right; right + rcases H with (rfl | rfl | H) + · left; rfl + · right; left; rfl + right; right + rcases H with (⟨q, _, r, _, hq, hr, rfl⟩ | ⟨q, _, r, _, hq, hr, rfl⟩ | H) + · left; exact ⟨q, r, hq, hr, rfl⟩ + · right; left; exact ⟨q, r, hq, hr, rfl⟩ + right; right + rcases H with (⟨q, _, hq, rfl⟩ | ⟨q, _, hq, rfl⟩) + · left; exact ⟨q, hq, rfl⟩ + · right; exact ⟨q, hq, rfl⟩ + +/-- The formula Aux construction in +`FFL.FirstOrder.Arithmetic.Bootstrapping.FormalizedFormula`. -/ +def formulaAux : Σ₀.Semisentence 2 := + .mkSigma + (“p C. + !qqVerumDef p ∨ + !qqFalsumDef p ∨ + (∃ p₁ < p, ∃ p₂ < p, p₁ ∈ C ∧ p₂ ∈ C ∧ !qqAndDef p p₁ p₂) ∨ + (∃ p₁ < p, ∃ p₂ < p, p₁ ∈ C ∧ p₂ ∈ C ∧ !qqOrDef p p₁ p₂) ∨ + (∃ p₁ < p, p₁ ∈ C ∧ !qqAllDef p p₁) ∨ (∃ p₁ < p, p₁ ∈ C ∧ !qqExsDef p p₁)”) + +/-- +The blueprint construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.FormalizedFormula`. -/ +noncomputable def blueprint : Fixpoint.Blueprint 0 := + ⟨.mkDelta + (.mkSigma + (“p C. + (∃ k < p, + ∃ r < p, + ∃ v < p, !L.isRel k r ∧ !(isUTermVec L).sigma k v ∧ !qqRelDef p k r v) ∨ + (∃ k < p, + ∃ r < p, + ∃ v < p, !L.isRel k r ∧ !(isUTermVec L).sigma k v ∧ !qqNRelDef p k r v) ∨ + !formulaAux p C”)) + (.mkPi + (“p C. + (∃ k < p, + ∃ r < p, ∃ v < p, !L.isRel k r ∧ !(isUTermVec L).pi k v ∧ !qqRelDef p k r v) ∨ + (∃ k < p, + ∃ r < p, + ∃ v < p, !L.isRel k r ∧ !(isUTermVec L).pi k v ∧ !qqNRelDef p k r v) ∨ + !formulaAux p C”))⟩ + +/-- The construction construction in +`FFL.FirstOrder.Arithmetic.Bootstrapping.FormalizedFormula`. -/ +def construction : Fixpoint.Construction V (blueprint L) + where + Φ := fun _ ↦ Phi L + defined := + .mk <| by + constructor + · intro v + simp [blueprint] + · intro v + symm + simpa [blueprint, formulaAux] using phi_iff L _ _ + monotone := by + unfold Phi + rintro C C' hC _ x (h | h | h | h | H) + · left; exact h + · right; left; exact h + · right; right; left; exact h + · right; right; right; left; exact h + right; right; right; right + rcases H with (⟨q, r, hqC, hrC, rfl⟩ | ⟨q, r, hqC, hrC, rfl⟩ | H) + · left; exact ⟨q, r, hC hqC, hC hrC, rfl⟩ + · right; left; exact ⟨q, r, hC hqC, hC hrC, rfl⟩ + right; right + rcases H with (⟨q, hqC, rfl⟩ | ⟨q, hqC, rfl⟩) + · left; exact ⟨q, hC hqC, rfl⟩ + · right; exact ⟨q, hC hqC, rfl⟩ + +instance : (construction L).StrongFinite V where + strong_finite := by + unfold construction Phi + rintro C _ x (h | h | h | h | H) + · left; exact h + · right; left; exact h + · right; right; left; exact h + · right; right; right; left; exact h + right; right; right; right + rcases H with (⟨q, r, hqC, hrC, rfl⟩ | ⟨q, r, hqC, hrC, rfl⟩ | H) + · left; exact ⟨q, r, by simp [hqC], by simp [hrC], rfl⟩ + · right; left; exact ⟨q, r, by simp [hqC], by simp [hrC], rfl⟩ + right; right + rcases H with (⟨q, hqC, rfl⟩ | ⟨q, hqC, rfl⟩) + · left; exact ⟨q, by simp [hqC], rfl⟩ + · right; exact ⟨q, by simp [hqC], rfl⟩ + +end FormalizedFormula + +variable (L) + +/-- The Is UFormula construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +def IsUFormula : V → Prop := + (FormalizedFormula.construction L).IsFixedPoint ![] + +/-- The is UFormula construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def isUFormula : ∆₁.Semisentence 1 := + (FormalizedFormula.blueprint L).fixpointDefΔ₁ + +variable {L} + +namespace IsUFormula + +open FormalizedFormula + +section + +instance defined : ∆₁-Predicate IsUFormula (V := V) L via isUFormula L := + (construction L).fixpoint_definedΔ₁ + +instance definable : ∆₁-Predicate IsUFormula (V := V) L := + IsUFormula.defined.to_definable + +instance definable' : Γ-[m + 1]-Predicate IsUFormula (V := V) L := + IsUFormula.definable.of_deltaOne + +end + +lemma case_iff {p : V} : + IsUFormula L p ↔ + (∃ k R v, L.IsRel k R ∧ IsUTermVec L k v ∧ p = ^rel k R v) ∨ + (∃ k R v, L.IsRel k R ∧ IsUTermVec L k v ∧ p = ^nrel k R v) ∨ + (p = ^⊤) ∨ + (p = ^⊥) ∨ + (∃ p₁ p₂, IsUFormula L p₁ ∧ IsUFormula L p₂ ∧ p = p₁ ^⋏ p₂) ∨ + (∃ p₁ p₂, IsUFormula L p₁ ∧ IsUFormula L p₂ ∧ p = p₁ ^⋎ p₂) ∨ + (∃ p₁, IsUFormula L p₁ ∧ p = ^∀ p₁) ∨ (∃ p₁, IsUFormula L p₁ ∧ p = ^∃ p₁) := + (construction L).case + +alias ⟨case, mk⟩ := case_iff + +@[simp] +lemma rel {k r v : V} : IsUFormula L (^rel k r v) ↔ L.IsRel k r ∧ IsUTermVec L k v := + ⟨by + intro h + rcases h.case with + (⟨k, r, v, hkr, hv, h⟩ | ⟨_, _, _, _, _, h⟩ | h | h | ⟨_, _, _, _, h⟩ | + ⟨_, _, _, _, h⟩ | ⟨_, _, h⟩ | ⟨_, _, h⟩) <;> + simp only [qqRel, add_left_inj, pair_ext_iff, true_and, qqNRel, zero_ne_one, false_and, + qqVerum, OfNat.zero_ne_ofNat, qqFalsum, qqAnd, qqOr, qqAll, qqExs] at h + · rcases h with ⟨rfl, rfl, rfl, rfl⟩; exact ⟨hkr, hv⟩, + by + rintro ⟨hkr, hv⟩ + exact mk (Or.inl ⟨k, r, v, hkr, hv, rfl⟩)⟩ + +@[simp] +lemma nrel {k r v : V} : IsUFormula L (^nrel k r v) ↔ L.IsRel k r ∧ IsUTermVec L k v := + ⟨by + intro h + rcases h.case with + (⟨_, _, _, _, _, h⟩ | ⟨k, r, v, hkr, hv, h⟩ | h | h | ⟨_, _, _, _, h⟩ | + ⟨_, _, _, _, h⟩ | ⟨_, _, h⟩ | ⟨_, _, h⟩) <;> + simp only [qqNRel, qqRel, add_left_inj, pair_ext_iff, _root_.one_ne_zero, false_and, + true_and, qqVerum, OfNat.one_ne_ofNat, qqFalsum, qqAnd, qqOr, qqAll, qqExs] at h + · rcases h with ⟨rfl, rfl, rfl, rfl⟩; exact ⟨hkr, hv⟩, + by + rintro ⟨hkr, hv⟩ + exact mk (Or.inr <| Or.inl ⟨k, r, v, hkr, hv, rfl⟩)⟩ + +@[simp] +lemma verum : IsUFormula L (^⊤ : V) := + mk (Or.inr <| Or.inr <| Or.inl rfl) + +@[simp] +lemma falsum : IsUFormula L (^⊥ : V) := + mk (Or.inr <| Or.inr <| Or.inr <| Or.inl rfl) + +@[simp] +lemma and {p q : V} : IsUFormula L (p ^⋏ q) ↔ IsUFormula L p ∧ IsUFormula L q := + ⟨by + intro h + rcases h.case with + (⟨_, _, _, _, _, h⟩ | ⟨_, _, _, _, _, h⟩ | h | h | ⟨_, _, hp, hq, h⟩ | ⟨_, _, _, _, h⟩ | + ⟨_, _, h⟩ | ⟨_, _, h⟩) <;> + simp only [qqAnd, qqRel, add_left_inj, pair_ext_iff, OfNat.ofNat_ne_zero, false_and, + qqNRel, OfNat.ofNat_ne_one, qqVerum, OfNat.ofNat_eq_ofNat, Nat.reduceEqDiff, + qqFalsum, Nat.succ_ne_self, true_and, qqOr, qqAll, qqExs] at h + · rcases h with ⟨rfl, rfl, rfl, rfl⟩; exact ⟨hp, hq⟩, + by + rintro ⟨hp, hq⟩ + exact mk (Or.inr <| Or.inr <| Or.inr <| Or.inr <| Or.inl ⟨p, q, hp, hq, rfl⟩)⟩ + +@[simp] +lemma or {p q : V} : IsUFormula L (p ^⋎ q) ↔ IsUFormula L p ∧ IsUFormula L q := + ⟨by + intro h + rcases h.case with + (⟨_, _, _, _, _, h⟩ | ⟨_, _, _, _, _, h⟩ | h | h | ⟨_, _, _, _, h⟩ | ⟨_, _, hp, hq, h⟩ | + ⟨_, _, h⟩ | ⟨_, _, h⟩) <;> + simp only [qqOr, qqRel, add_left_inj, pair_ext_iff, OfNat.ofNat_ne_zero, false_and, + qqNRel, OfNat.ofNat_ne_one, qqVerum, OfNat.ofNat_eq_ofNat, Nat.reduceEqDiff, + qqFalsum, qqAnd, Nat.succ_ne_self, true_and, qqAll, qqExs] at h + · rcases h with ⟨rfl, rfl, rfl, rfl⟩; exact ⟨hp, hq⟩, + by + rintro ⟨hp, hq⟩ + exact mk (Or.inr <| Or.inr <| Or.inr <| Or.inr <| Or.inr <| Or.inl ⟨p, q, hp, hq, rfl⟩)⟩ + +@[simp] +lemma all {p : V} : IsUFormula L (^∀ p) ↔ IsUFormula L p := + ⟨by + intro h + rcases h.case with + (⟨_, _, _, _, _, h⟩ | ⟨_, _, _, _, _, h⟩ | h | h | ⟨_, _, _, _, h⟩ | ⟨_, _, _, _, h⟩ | + ⟨_, hp, h⟩ | ⟨_, _, h⟩) <;> + simp only [qqAll, qqRel, add_left_inj, pair_ext_iff, OfNat.ofNat_ne_zero, false_and, + qqNRel, OfNat.ofNat_ne_one, qqVerum, OfNat.ofNat_eq_ofNat, Nat.reduceEqDiff, + qqFalsum, qqAnd, qqOr, Nat.succ_ne_self, true_and, qqExs] at h + · rcases h with ⟨rfl, rfl, rfl, rfl⟩; exact hp, + by + rintro hp + exact mk (Or.inr <| Or.inr <| Or.inr <| Or.inr <| Or.inr <| Or.inr <| Or.inl ⟨p, hp, rfl⟩)⟩ + +@[simp] +lemma ex {p : V} : IsUFormula L (^∃ p) ↔ IsUFormula L p := + ⟨by + intro h + rcases h.case with + (⟨_, _, _, _, _, h⟩ | ⟨_, _, _, _, _, h⟩ | h | h | ⟨_, _, _, _, h⟩ | ⟨_, _, _, _, h⟩ | + ⟨_, _, h⟩ | ⟨_, hp, h⟩) <;> + simp only [qqExs, qqRel, add_left_inj, pair_ext_iff, OfNat.ofNat_ne_zero, false_and, + qqNRel, OfNat.ofNat_ne_one, qqVerum, OfNat.ofNat_eq_ofNat, Nat.reduceEqDiff, + qqFalsum, qqAnd, qqOr, qqAll, Nat.succ_ne_self, true_and] at h + · rcases h with ⟨rfl, rfl, rfl, rfl⟩; exact hp, + by + rintro hp + exact mk (Or.inr <| Or.inr <| Or.inr <| Or.inr <| Or.inr <| Or.inr <| Or.inr ⟨p, hp, rfl⟩)⟩ + +lemma pos {p : V} (h : IsUFormula L p) : 0 < p := by + rcases h.case with + (⟨_, _, _, _, _, _, rfl⟩ | ⟨_, _, _, _, _, _, rfl⟩ | ⟨_, rfl⟩ | ⟨_, rfl⟩ | + ⟨_, _, _, _, _, rfl⟩ | ⟨_, _, _, _, _, rfl⟩ | ⟨_, _, _, rfl⟩ | ⟨_, _, _, rfl⟩) <;> + simp [qqRel, qqNRel, qqVerum, qqFalsum, qqAnd, qqOr, qqAll, qqExs] + --lemma IsSemiformula.pos {n p : V} (h : Semiformula L n p) : 0 < p := h.1.pos + +@[simp] +lemma not_zero : ¬IsUFormula L (0 : V) := by intro h; simpa using h.pos + +lemma induction1 (Γ) {P : V → Prop} (hP : Γ-[1]-Predicate P) + (hrel : ∀ k r v, L.IsRel k r → IsUTermVec L k v → P (^rel k r v)) + (hnrel : ∀ k r v, L.IsRel k r → IsUTermVec L k v → P (^nrel k r v)) (hverum : P ^⊤) + (hfalsum : P ^⊥) (hand : ∀ p q, IsUFormula L p → IsUFormula L q → P p → P q → P (p ^⋏ q)) + (hor : ∀ p q, IsUFormula L p → IsUFormula L q → P p → P q → P (p ^⋎ q)) + (hall : ∀ p, IsUFormula L p → P p → P (^∀ p)) + (hexs : ∀ p, IsUFormula L p → P p → P (^∃ p)) : ∀ p, IsUFormula L p → P p := + (construction L).induction (v := ![]) hP + (by + rintro C hC x + (⟨k, r, v, hkr, hv, rfl⟩ | ⟨k, r, v, hkr, hv, rfl⟩ | ⟨n, rfl⟩ | ⟨n, rfl⟩ | + ⟨p, q, hp, hq, rfl⟩ | ⟨p, q, hp, hq, rfl⟩ | ⟨p, hp, rfl⟩ | ⟨p, hp, rfl⟩) + · exact hrel k r v hkr hv + · exact hnrel k r v hkr hv + · exact hverum + · exact hfalsum + · exact hand p q (hC p hp).1 (hC q hq).1 (hC p hp).2 (hC q hq).2 + · exact hor p q (hC p hp).1 (hC q hq).1 (hC p hp).2 (hC q hq).2 + · exact hall p (hC p hp).1 (hC p hp).2 + · exact hexs p (hC p hp).1 (hC p hp).2) + +lemma ISigma1.sigma1_succ_induction {P : V → Prop} (hP : Σ₁-Predicate P) + (hrel : ∀ k r v, L.IsRel k r → IsUTermVec L k v → P (^rel k r v)) + (hnrel : ∀ k r v, L.IsRel k r → IsUTermVec L k v → P (^nrel k r v)) (hverum : P ^⊤) + (hfalsum : P ^⊥) (hand : ∀ p q, IsUFormula L p → IsUFormula L q → P p → P q → P (p ^⋏ q)) + (hor : ∀ p q, IsUFormula L p → IsUFormula L q → P p → P q → P (p ^⋎ q)) + (hall : ∀ p, IsUFormula L p → P p → P (^∀ p)) + (hexs : ∀ p, IsUFormula L p → P p → P (^∃ p)) : ∀ p, IsUFormula L p → P p := + induction1 Σ hP hrel hnrel hverum hfalsum hand hor hall hexs + +lemma ISigma1.pi1_succ_induction {P : V → Prop} (hP : Π₁-Predicate P) + (hrel : ∀ k r v, L.IsRel k r → IsUTermVec L k v → P (^rel k r v)) + (hnrel : ∀ k r v, L.IsRel k r → IsUTermVec L k v → P (^nrel k r v)) (hverum : P ^⊤) + (hfalsum : P ^⊥) (hand : ∀ p q, IsUFormula L p → IsUFormula L q → P p → P q → P (p ^⋏ q)) + (hor : ∀ p q, IsUFormula L p → IsUFormula L q → P p → P q → P (p ^⋎ q)) + (hall : ∀ p, IsUFormula L p → P p → P (^∀ p)) + (hexs : ∀ p, IsUFormula L p → P p → P (^∃ p)) : ∀ p, IsUFormula L p → P p := + induction1 Π hP hrel hnrel hverum hfalsum hand hor hall hexs + +end IsUFormula + +namespace UformulaRec1 + +/-- Data specifying the encoded construction in +`FFL.FirstOrder.Arithmetic.Bootstrapping.UformulaRec1`. -/ +structure Blueprint where + /-- The rel construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.UformulaRec1.Blueprint`. -/ + rel : Σ₁.Semisentence 5 + /-- The nrel construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.UformulaRec1.Blueprint`. -/ + nrel : Σ₁.Semisentence 5 + /-- The verum construction in + `FFL.FirstOrder.Arithmetic.Bootstrapping.UformulaRec1.Blueprint`. -/ + verum : Σ₁.Semisentence 2 + /-- The falsum construction in + `FFL.FirstOrder.Arithmetic.Bootstrapping.UformulaRec1.Blueprint`. -/ + falsum : Σ₁.Semisentence 2 + /-- The and construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.UformulaRec1.Blueprint`. -/ + and : Σ₁.Semisentence 6 + /-- The or construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.UformulaRec1.Blueprint`. -/ + or : Σ₁.Semisentence 6 + /-- The all construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.UformulaRec1.Blueprint`. -/ + all : Σ₁.Semisentence 4 + /-- The exs construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.UformulaRec1.Blueprint`. -/ + exs : Σ₁.Semisentence 4 + /-- The all Changes construction in + `FFL.FirstOrder.Arithmetic.Bootstrapping.UformulaRec1.Blueprint`. -/ + allChanges : Σ₁.Semisentence 2 + /-- The exs Changes construction in + `FFL.FirstOrder.Arithmetic.Bootstrapping.UformulaRec1.Blueprint`. -/ + exsChanges : Σ₁.Semisentence 2 + +namespace Blueprint + +variable (L) (β : Blueprint) + +/-- The blueprint construction in +`FFL.FirstOrder.Arithmetic.Bootstrapping.UformulaRec1.Blueprint`. -/ +noncomputable def blueprint (β : Blueprint) : Fixpoint.Blueprint 0 := + ⟨.mkDelta + (.mkSigma + (“pr C. + ∃ param <⁺ pr, + ∃ p <⁺ pr, + ∃ y <⁺ pr, + !pair₃Def pr param p y ∧ + !(isUFormula L).sigma p ∧ + ((∃ k < p, ∃ R < p, ∃ v < p, !qqRelDef p k R v ∧ !β.rel y param k R v) ∨ + (∃ k < p, + ∃ R < p, ∃ v < p, !qqNRelDef p k R v ∧ !β.nrel y param k R v) ∨ + (!qqVerumDef p ∧ !β.verum y param) ∨ + (!qqFalsumDef p ∧ !β.falsum y param) ∨ + (∃ p₁ < p, + ∃ p₂ < p, + ∃ y₁ < C, + ∃ y₂ < C, + :⟪param, p₁, y₁⟫:∈ C ∧ + :⟪param, p₂, y₂⟫:∈ C ∧ + !qqAndDef p p₁ p₂ ∧ !β.and y param p₁ p₂ y₁ y₂) ∨ + (∃ p₁ < p, + ∃ p₂ < p, + ∃ y₁ < C, + ∃ y₂ < C, + :⟪param, p₁, y₁⟫:∈ C ∧ + :⟪param, p₂, y₂⟫:∈ C ∧ + !qqOrDef p p₁ p₂ ∧ !β.or y param p₁ p₂ y₁ y₂) ∨ + (∃ p₁ < p, + ∃ y₁ < C, + (∃ param', + !β.allChanges param' param ∧ + :⟪param', p₁, y₁⟫:∈ C) ∧ + !qqAllDef p p₁ ∧ !β.all y param p₁ y₁) ∨ + (∃ p₁ < p, + ∃ y₁ < C, + (∃ param', + !β.exsChanges param' param ∧ + :⟪param', p₁, y₁⟫:∈ C) ∧ + !qqExsDef p p₁ ∧ !β.exs y param p₁ y₁))”)) + (.mkPi + (“pr C. + ∃ param <⁺ pr, + ∃ p <⁺ pr, + ∃ y <⁺ pr, + !pair₃Def pr param p y ∧ + !(isUFormula L).pi p ∧ + ((∃ k < p, + ∃ R < p, + ∃ v < p, + !qqRelDef p k R v ∧ !β.rel.graphDelta.pi.val y param k R v) ∨ + (∃ k < p, + ∃ R < p, + ∃ v < p, + !qqNRelDef p k R v ∧ + !β.nrel.graphDelta.pi.val y param k R v) ∨ + (!qqVerumDef p ∧ !β.verum.graphDelta.pi.val y param) ∨ + (!qqFalsumDef p ∧ !β.falsum.graphDelta.pi.val y param) ∨ + (∃ p₁ < p, + ∃ p₂ < p, + ∃ y₁ < C, + ∃ y₂ < C, + :⟪param, p₁, y₁⟫:∈ C ∧ + :⟪param, p₂, y₂⟫:∈ C ∧ + !qqAndDef p p₁ p₂ ∧ + !β.and.graphDelta.pi.val y param p₁ p₂ y₁ y₂) ∨ + (∃ p₁ < p, + ∃ p₂ < p, + ∃ y₁ < C, + ∃ y₂ < C, + :⟪param, p₁, y₁⟫:∈ C ∧ + :⟪param, p₂, y₂⟫:∈ C ∧ + !qqOrDef p p₁ p₂ ∧ + !β.or.graphDelta.pi.val y param p₁ p₂ y₁ y₂) ∨ + (∃ p₁ < p, + ∃ y₁ < C, + (∀ param', + !β.allChanges param' param → + :⟪param', p₁, y₁⟫:∈ C) ∧ + !qqAllDef p p₁ ∧ + !β.all.graphDelta.pi.val y param p₁ y₁) ∨ + (∃ p₁ < p, + ∃ y₁ < C, + (∀ param', + !β.exsChanges param' param → + :⟪param', p₁, y₁⟫:∈ C) ∧ + !qqExsDef p p₁ ∧ + !β.exs.graphDelta.pi.val y param p₁ y₁))”))⟩ + +/-- +Note: `noncomputable` attribute to prohibit compilation of a large term. This is necessary for +Zoo and integration with Verso. -/ +noncomputable def graph : Σ₁.Semisentence 3 := + .mkSigma (“param p y. ∃ pr, !pair₃Def pr param p y ∧ !(β.blueprint L).fixpointDef pr”) + +/-- +Note: `noncomputable` attribute to prohibit compilation of a large term. This is necessary for +Zoo and integration with Verso. -/ +noncomputable def result : Σ₁.Semisentence 3 := + .mkSigma + (“y param p. + (!(isUFormula L).pi p → !(β.graph L)param p y) ∧ (¬!(isUFormula L).sigma p → y = 0)”) + +end Blueprint + +variable (V) + +/-- Data and laws for Construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.UformulaRec1`. -/ +structure Construction (φ : Blueprint) where + /-- The rel construction in + `FFL.FirstOrder.Arithmetic.Bootstrapping.UformulaRec1.Construction`. -/ + rel (param k R v : V) : V + /-- The nrel construction in + `FFL.FirstOrder.Arithmetic.Bootstrapping.UformulaRec1.Construction`. -/ + nrel (param k R v : V) : V + /-- The verum construction in + `FFL.FirstOrder.Arithmetic.Bootstrapping.UformulaRec1.Construction`. -/ + verum (param : V) : V + /-- The falsum construction in + `FFL.FirstOrder.Arithmetic.Bootstrapping.UformulaRec1.Construction`. -/ + falsum (param : V) : V + /-- The and construction in + `FFL.FirstOrder.Arithmetic.Bootstrapping.UformulaRec1.Construction`. -/ + and (param p₁ p₂ y₁ y₂ : V) : V + /-- The or construction in + `FFL.FirstOrder.Arithmetic.Bootstrapping.UformulaRec1.Construction`. -/ + or (param p₁ p₂ y₁ y₂ : V) : V + /-- The all construction in + `FFL.FirstOrder.Arithmetic.Bootstrapping.UformulaRec1.Construction`. -/ + all (param p₁ y₁ : V) : V + /-- The exs construction in + `FFL.FirstOrder.Arithmetic.Bootstrapping.UformulaRec1.Construction`. -/ + exs (param p₁ y₁ : V) : V + /-- The all Changes construction in + `FFL.FirstOrder.Arithmetic.Bootstrapping.UformulaRec1.Construction`. -/ + allChanges (param : V) : V + /-- The exs Changes construction in + `FFL.FirstOrder.Arithmetic.Bootstrapping.UformulaRec1.Construction`. -/ + exsChanges (param : V) : V + rel_defined : Σ₁-Function₄ rel via φ.rel + nrel_defined : Σ₁-Function₄ nrel via φ.nrel + verum_defined : Σ₁-Function₁ verum via φ.verum + falsum_defined : Σ₁-Function₁ falsum via φ.falsum + and_defined : Σ₁-Function₅ and via φ.and + or_defined : Σ₁-Function₅ or via φ.or + all_defined : Σ₁-Function₃ all via φ.all + exs_defined : Σ₁-Function₃ exs via φ.exs + allChanges_defined : Σ₁-Function₁ allChanges via φ.allChanges + exChanges_defined : Σ₁-Function₁ exsChanges via φ.exsChanges + +variable {V} + +namespace Construction + +variable (L) {β : Blueprint} (c : Construction V β) + +/-- The Phi construction in +`FFL.FirstOrder.Arithmetic.Bootstrapping.UformulaRec1.Construction`. -/ +def Phi (C : Set V) (pr : V) : Prop := + ∃ param p y, + pr = ⟪param, p, y⟫ ∧ + IsUFormula L p ∧ + ((∃ k r v, p = ^rel k r v ∧ y = c.rel param k r v) ∨ + (∃ k r v, p = ^nrel k r v ∧ y = c.nrel param k r v) ∨ + (p = ^⊤ ∧ y = c.verum param) ∨ + (p = ^⊥ ∧ y = c.falsum param) ∨ + (∃ p₁ p₂ y₁ y₂, + ⟪param, p₁, y₁⟫ ∈ C ∧ + ⟪param, p₂, y₂⟫ ∈ C ∧ p = p₁ ^⋏ p₂ ∧ y = c.and param p₁ p₂ y₁ y₂) ∨ + (∃ p₁ p₂ y₁ y₂, + ⟪param, p₁, y₁⟫ ∈ C ∧ + ⟪param, p₂, y₂⟫ ∈ C ∧ p = p₁ ^⋎ p₂ ∧ y = c.or param p₁ p₂ y₁ y₂) ∨ + (∃ p₁ y₁, + ⟪c.allChanges param, p₁, y₁⟫ ∈ C ∧ p = ^∀ p₁ ∧ y = c.all param p₁ y₁) ∨ + (∃ p₁ y₁, + ⟪c.exsChanges param, p₁, y₁⟫ ∈ C ∧ p = ^∃ p₁ ∧ y = c.exs param p₁ y₁)) + +private lemma phi_iff (C pr : V) : + c.Phi L {x | x ∈ C} pr ↔ + ∃ param ≤ pr, + ∃ p ≤ pr, + ∃ y ≤ pr, + pr = ⟪param, p, y⟫ ∧ + IsUFormula L p ∧ + ((∃ k < p, ∃ R < p, ∃ v < p, p = ^rel k R v ∧ y = c.rel param k R v) ∨ + (∃ k < p, ∃ R < p, ∃ v < p, p = ^nrel k R v ∧ y = c.nrel param k R v) ∨ + (p = ^⊤ ∧ y = c.verum param) ∨ + (p = ^⊥ ∧ y = c.falsum param) ∨ + (∃ p₁ < p, + ∃ p₂ < p, + ∃ y₁ < C, + ∃ y₂ < C, + ⟪param, p₁, y₁⟫ ∈ C ∧ + ⟪param, p₂, y₂⟫ ∈ C ∧ + p = p₁ ^⋏ p₂ ∧ y = c.and param p₁ p₂ y₁ y₂) ∨ + (∃ p₁ < p, + ∃ p₂ < p, + ∃ y₁ < C, + ∃ y₂ < C, + ⟪param, p₁, y₁⟫ ∈ C ∧ + ⟪param, p₂, y₂⟫ ∈ C ∧ + p = p₁ ^⋎ p₂ ∧ y = c.or param p₁ p₂ y₁ y₂) ∨ + (∃ p₁ < p, + ∃ y₁ < C, + ⟪c.allChanges param, p₁, y₁⟫ ∈ C ∧ + p = ^∀ p₁ ∧ y = c.all param p₁ y₁) ∨ + (∃ p₁ < p, + ∃ y₁ < C, + ⟪c.exsChanges param, p₁, y₁⟫ ∈ C ∧ + p = ^∃ p₁ ∧ y = c.exs param p₁ y₁)) := + by + constructor + · rintro ⟨param, p, y, rfl, hp, H⟩ + refine + ⟨param, by simp, p, le_trans (le_pair_left p y) (le_pair_right _ _), y, + le_trans (le_pair_right p y) (le_pair_right _ _), rfl, hp, ?_⟩ + rcases H with (⟨k, r, v, rfl, rfl⟩ | ⟨k, r, v, rfl, rfl⟩ | H) + · left; exact ⟨k, by simp, r, by simp, v, by simp, rfl, rfl⟩ + · right; left; exact ⟨k, by simp, r, by simp, v, by simp, rfl, rfl⟩ + right; right + rcases H with (⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | H) + · left; exact ⟨rfl, rfl⟩ + · right; left; exact ⟨rfl, rfl⟩ + right; right + rcases H with (⟨p₁, p₂, y₁, y₂, h₁, h₂, rfl, rfl⟩ | ⟨p₁, p₂, y₁, y₂, h₁, h₂, rfl, rfl⟩ | H) + · left; + exact + ⟨p₁, by simp, p₂, by simp, y₁, lt_of_le_of_lt (by simp) (lt_of_mem_rng h₁), y₂, + lt_of_le_of_lt (by simp) (lt_of_mem_rng h₂), h₁, h₂, rfl, rfl⟩ + · right; left; + exact + ⟨p₁, by simp, p₂, by simp, y₁, lt_of_le_of_lt (by simp) (lt_of_mem_rng h₁), y₂, + lt_of_le_of_lt (by simp) (lt_of_mem_rng h₂), h₁, h₂, rfl, rfl⟩ + right; right + rcases H with (⟨p₁, y₁, h₁, rfl, rfl⟩ | ⟨p₁, y₁, h₁, rfl, rfl⟩) + · left; exact ⟨p₁, by simp, y₁, lt_of_le_of_lt (by simp) (lt_of_mem_rng h₁), h₁, rfl, rfl⟩ + · right; exact ⟨p₁, by simp, y₁, lt_of_le_of_lt (by simp) (lt_of_mem_rng h₁), h₁, rfl, rfl⟩ + · rintro ⟨param, _, p, _, y, _, rfl, hp, H⟩ + refine ⟨param, p, y, rfl, hp, ?_⟩ + rcases H with (⟨k, _, r, _, v, _, rfl, rfl⟩ | ⟨k, _, r, _, v, _, rfl, rfl⟩ | H) + · left; exact ⟨k, r, v, rfl, rfl⟩ + · right; left; exact ⟨k, r, v, rfl, rfl⟩ + right; right + rcases H with (⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | H) + · left; exact ⟨rfl, rfl⟩ + · right; left; exact ⟨rfl, rfl⟩ + right; right + rcases H with + (⟨p₁, _, p₂, _, y₁, _, y₂, _, h₁, h₂, rfl, rfl⟩ | + ⟨p₁, _, p₂, _, y₁, _, y₂, _, h₁, h₂, rfl, rfl⟩ | H) + · left; exact ⟨p₁, p₂, y₁, y₂, h₁, h₂, rfl, rfl⟩ + · right; left; exact ⟨p₁, p₂, y₁, y₂, h₁, h₂, rfl, rfl⟩ + right; right + rcases H with (⟨p₁, _, y₁, _, h₁, rfl, rfl⟩ | ⟨p₁, _, y₁, _, h₁, rfl, rfl⟩) + · left; exact ⟨p₁, y₁, h₁, rfl, rfl⟩ + · right; exact ⟨p₁, y₁, h₁, rfl, rfl⟩ + +/-- The construction construction in +`FFL.FirstOrder.Arithmetic.Bootstrapping.UformulaRec1.Construction`. -/ +def construction : Fixpoint.Construction V (β.blueprint L) + where + Φ := fun _ ↦ c.Phi L + defined := + .mk <| by + constructor + · intro v + simp [Blueprint.blueprint, c.rel_defined.iff, c.rel_defined.graph_delta.proper.iff', + c.nrel_defined.iff, c.nrel_defined.graph_delta.proper.iff', c.verum_defined.iff, + c.verum_defined.graph_delta.proper.iff', c.falsum_defined.iff, + c.falsum_defined.graph_delta.proper.iff', c.and_defined.iff, + c.and_defined.graph_delta.proper.iff', c.or_defined.iff, + c.or_defined.graph_delta.proper.iff', c.all_defined.iff, + c.all_defined.graph_delta.proper.iff', c.exs_defined.iff, + c.exs_defined.graph_delta.proper.iff', c.allChanges_defined.iff, + c.exChanges_defined.iff] + · intro v + symm + simpa [Blueprint.blueprint, c.rel_defined.iff, c.nrel_defined.iff, c.verum_defined.iff, + c.falsum_defined.iff, c.and_defined.iff, c.or_defined.iff, c.all_defined.iff, + c.exs_defined.iff, c.allChanges_defined.iff, c.exChanges_defined.iff] using + c.phi_iff L _ _ + monotone := by + unfold Phi + rintro C C' hC _ _ ⟨param, p, y, rfl, hp, H⟩ + refine ⟨param, p, y, rfl, hp, ?_⟩ + rcases H with (h | h | h | h | H) + · left; exact h + · right; left; exact h + · right; right; left; exact h + · right; right; right; left; exact h + right; right; right; right + rcases H with (⟨p₁, p₂, r₁, r₂, h₁, h₂, rfl, rfl⟩ | ⟨p₁, p₂, r₁, r₂, h₁, h₂, rfl, rfl⟩ | H) + · left; exact ⟨p₁, p₂, r₁, r₂, hC h₁, hC h₂, rfl, rfl⟩ + · right; left; exact ⟨p₁, p₂, r₁, r₂, hC h₁, hC h₂, rfl, rfl⟩ + right; right + rcases H with (⟨p₁, r₁, h₁, rfl, rfl⟩ | ⟨p₁, r₁, h₁, rfl, rfl⟩) + · left; exact ⟨p₁, r₁, hC h₁, rfl, rfl⟩ + · right; exact ⟨p₁, r₁, hC h₁, rfl, rfl⟩ + +instance : (c.construction L).Finite where + finite + {C _ pr + h} := + by + rcases h with + ⟨param, p, y, rfl, hp, + (h | h | h | h | ⟨p₁, p₂, y₁, y₂, h₁, h₂, rfl, rfl⟩ | + ⟨p₁, p₂, y₁, y₂, h₁, h₂, rfl, rfl⟩ | ⟨p₁, y₁, h₁, rfl, rfl⟩ | ⟨p₁, y₁, h₁, rfl, rfl⟩)⟩ + · exact ⟨0, param, _, _, rfl, hp, Or.inl h⟩ + · exact ⟨0, param, _, _, rfl, hp, Or.inr <| Or.inl h⟩ + · exact ⟨0, param, _, _, rfl, hp, Or.inr <| Or.inr <| Or.inl h⟩ + · exact ⟨0, param, _, _, rfl, hp, Or.inr <| Or.inr <| Or.inr <| Or.inl h⟩ + · exact + ⟨Max.max ⟪param, p₁, y₁⟫ ⟪param, p₂, y₂⟫ + 1, param, _, _, rfl, hp, + by + right; right; right; right; left + exact + ⟨p₁, p₂, y₁, y₂, by simp [h₁, lt_succ_iff_le], by simp [h₂, lt_succ_iff_le], rfl, + rfl⟩⟩ + · exact + ⟨Max.max ⟪param, p₁, y₁⟫ ⟪param, p₂, y₂⟫ + 1, param, _, _, rfl, hp, + by + right; right; right; right; right; left + exact + ⟨p₁, p₂, y₁, y₂, by simp [h₁, lt_succ_iff_le], by simp [h₂, lt_succ_iff_le], rfl, + rfl⟩⟩ + · exact + ⟨⟪c.allChanges param, p₁, y₁⟫ + 1, param, _, _, rfl, hp, + by + right; right; right; right; right; right; left + exact ⟨p₁, y₁, by simp [h₁], rfl, rfl⟩⟩ + · exact + ⟨⟪c.exsChanges param, p₁, y₁⟫ + 1, param, _, _, rfl, hp, + by + right; right; right; right; right; right; right + exact ⟨p₁, y₁, by simp [h₁], rfl, rfl⟩⟩ + +/-- The Graph construction in +`FFL.FirstOrder.Arithmetic.Bootstrapping.UformulaRec1.Construction`. -/ +def Graph (param : V) (x y : V) : Prop := + (c.construction L).IsFixedPoint ![] ⟪param, x, y⟫ + +variable {param : V} + +variable {L c} + +lemma Graph.case_iff {p y : V} : + c.Graph L param p y ↔ + IsUFormula L p ∧ + ((∃ k R v, p = ^rel k R v ∧ y = c.rel param k R v) ∨ + (∃ k R v, p = ^nrel k R v ∧ y = c.nrel param k R v) ∨ + (p = ^⊤ ∧ y = c.verum param) ∨ + (p = ^⊥ ∧ y = c.falsum param) ∨ + (∃ p₁ p₂ y₁ y₂, + c.Graph L param p₁ y₁ ∧ + c.Graph L param p₂ y₂ ∧ p = p₁ ^⋏ p₂ ∧ y = c.and param p₁ p₂ y₁ y₂) ∨ + (∃ p₁ p₂ y₁ y₂, + c.Graph L param p₁ y₁ ∧ + c.Graph L param p₂ y₂ ∧ p = p₁ ^⋎ p₂ ∧ y = c.or param p₁ p₂ y₁ y₂) ∨ + (∃ p₁ y₁, + c.Graph L (c.allChanges param) p₁ y₁ ∧ + p = ^∀ p₁ ∧ y = c.all param p₁ y₁) ∨ + (∃ p₁ y₁, + c.Graph L (c.exsChanges param) p₁ y₁ ∧ + p = ^∃ p₁ ∧ y = c.exs param p₁ y₁)) := + Iff.trans (c.construction L).case + (by + constructor + · rintro ⟨param, p', y', e, H⟩; + rcases show _ = param ∧ p = p' ∧ y = y' by simpa using e with ⟨rfl, rfl, rfl⟩ + refine H + · intro H; exact ⟨_, _, _, rfl, H⟩) + +variable (c β) + +lemma graph_defined : Σ₁-Relation₃ c.Graph L via β.graph L := + .mk fun v ↦ by + simp [Blueprint.graph, (c.construction L).fixpoint_defined.iff, Matrix.empty_eq]; rfl + +lemma eval_graphDef (v : Fin 3 → V) : (β.graph L).val.Evalb v ↔ c.Graph L (v 0) (v 1) (v 2) := + (graph_defined β c).iff + +instance graph_definable : Σ-[0 + 1]-Relation₃ c.Graph L := + c.graph_defined.to_definable + +variable {β} + +lemma graph_dom_uformula {p r} : c.Graph L param p r → IsUFormula L p := fun h ↦ + Graph.case_iff.mp h |>.1 + +lemma graph_rel_iff {k r v y} (hkr : L.IsRel k r) (hv : IsUTermVec L k v) : + c.Graph L param (^rel k r v) y ↔ y = c.rel param k r v := + by + constructor + · intro h + rcases Graph.case_iff.mp h with + ⟨_, + (⟨k, r, v, H, rfl⟩ | ⟨_, _, _, H, _⟩ | ⟨H, _⟩ | ⟨H, _⟩ | ⟨_, _, _, _, _, _, H, _⟩ | + ⟨_, _, _, _, _, _, H, _⟩ | ⟨_, _, _, H, _⟩ | ⟨_, _, _, H, _⟩)⟩ + · rcases (by simpa [qqRel] using H) with ⟨rfl, rfl, rfl, rfl⟩; rfl + · simp [qqRel, qqNRel] at H + · simp [qqRel, qqVerum] at H + · simp [qqRel, qqFalsum] at H + · simp [qqRel, qqAnd] at H + · simp [qqRel, qqOr] at H + · simp [qqRel, qqAll] at H + · simp [qqRel, qqExs] at H + · rintro rfl; exact (Graph.case_iff).mpr ⟨by simp [hkr, hv], Or.inl ⟨k, r, v, rfl, rfl⟩⟩ + +lemma graph_nrel_iff {k r v y} (hkr : L.IsRel k r) (hv : IsUTermVec L k v) : + c.Graph L param (^nrel k r v) y ↔ y = c.nrel param k r v := + by + constructor + · intro h + rcases Graph.case_iff.mp h with + ⟨_, + (⟨_, _, _, H, _⟩ | ⟨_, _, _, H, rfl⟩ | ⟨H, _⟩ | ⟨H, _⟩ | ⟨_, _, _, _, _, _, H, _⟩ | + ⟨_, _, _, _, _, _, H, _⟩ | ⟨_, _, _, H, _⟩ | ⟨_, _, _, H, _⟩)⟩ + · simp [qqNRel, qqRel] at H + · rcases (by simpa [qqNRel] using H) with ⟨rfl, rfl, rfl, rfl⟩; rfl + · simp [qqNRel, qqVerum] at H + · simp [qqNRel, qqFalsum] at H + · simp [qqNRel, qqAnd] at H + · simp [qqNRel, qqOr] at H + · simp [qqNRel, qqAll] at H + · simp [qqNRel, qqExs] at H + · rintro rfl; + exact (Graph.case_iff).mpr ⟨by simp [hkr, hv], Or.inr <| Or.inl ⟨k, r, v, rfl, rfl⟩⟩ + +lemma graph_verum_iff {y} : c.Graph L param ^⊤ y ↔ y = c.verum param := + by + constructor + · intro h + rcases Graph.case_iff.mp h with + ⟨_, + (⟨_, _, _, H, _⟩ | ⟨_, _, _, H, _⟩ | ⟨H, rfl⟩ | ⟨H, _⟩ | ⟨_, _, _, _, _, _, H, _⟩ | + ⟨_, _, _, _, _, _, H, _⟩ | ⟨_, _, _, H, _⟩ | ⟨_, _, _, H, _⟩)⟩ + · simp [qqVerum, qqRel] at H + · simp [qqVerum, qqNRel] at H + · rcases (by simpa [qqVerum] using H); rfl + · simp [qqVerum, qqFalsum] at H + · simp [qqVerum, qqAnd] at H + · simp [qqVerum, qqOr] at H + · simp [qqVerum, qqAll] at H + · simp [qqVerum, qqExs] at H + · rintro rfl; exact (Graph.case_iff).mpr ⟨by simp, Or.inr <| Or.inr <| Or.inl ⟨rfl, rfl⟩⟩ + +lemma graph_falsum_iff {y} : c.Graph L param ^⊥ y ↔ y = c.falsum param := + by + constructor + · intro h + rcases Graph.case_iff.mp h with + ⟨_, + (⟨_, _, _, H, _⟩ | ⟨_, _, _, H, _⟩ | ⟨H, _⟩ | ⟨H, rfl⟩ | ⟨_, _, _, _, _, _, H, _⟩ | + ⟨_, _, _, _, _, _, H, _⟩ | ⟨_, _, _, H, _⟩ | ⟨_, _, _, H, _⟩)⟩ + · simp [qqFalsum, qqRel] at H + · simp [qqFalsum, qqNRel] at H + · simp [qqFalsum, qqVerum] at H + · rcases (by simpa [qqFalsum] using H); rfl + · simp [qqFalsum, qqAnd] at H + · simp [qqFalsum, qqOr] at H + · simp [qqFalsum, qqAll] at H + · simp [qqFalsum, qqExs] at H + · rintro rfl; + exact (Graph.case_iff).mpr ⟨by simp, Or.inr <| Or.inr <| Or.inr <| Or.inl ⟨rfl, rfl⟩⟩ + +lemma graph_rel {k r v} (hkr : L.IsRel k r) (hv : IsUTermVec L k v) : + c.Graph L param (^rel k r v) (c.rel param k r v) := + (Graph.case_iff).mpr ⟨by simp [hkr, hv], Or.inl ⟨k, r, v, rfl, rfl⟩⟩ + +lemma graph_nrel {k r v} (hkr : L.IsRel k r) (hv : IsUTermVec L k v) : + c.Graph L param (^nrel k r v) (c.nrel param k r v) := + (Graph.case_iff).mpr ⟨by simp [hkr, hv], Or.inr <| Or.inl ⟨k, r, v, rfl, rfl⟩⟩ + +lemma graph_verum : c.Graph L param ^⊤ (c.verum param) := + (Graph.case_iff).mpr ⟨by simp, Or.inr <| Or.inr <| Or.inl ⟨rfl, rfl⟩⟩ + +lemma graph_falsum : c.Graph L param ^⊥ (c.falsum param) := + (Graph.case_iff).mpr ⟨by simp, Or.inr <| Or.inr <| Or.inr <| Or.inl ⟨rfl, rfl⟩⟩ + +lemma graph_and {p₁ p₂ r₁ r₂ : V} (hp₁ : IsUFormula L p₁) (hp₂ : IsUFormula L p₂) + (h₁ : c.Graph L param p₁ r₁) (h₂ : c.Graph L param p₂ r₂) : + c.Graph L param (p₁ ^⋏ p₂) (c.and param p₁ p₂ r₁ r₂) := + (Graph.case_iff).mpr + ⟨by simp [hp₁, hp₂], + Or.inr <| Or.inr <| Or.inr <| Or.inr <| Or.inl ⟨p₁, p₂, r₁, r₂, h₁, h₂, rfl, rfl⟩⟩ + +lemma graph_and_inv {p₁ p₂ r : V} : + c.Graph L param (p₁ ^⋏ p₂) r → + ∃ r₁ r₂, c.Graph L param p₁ r₁ ∧ c.Graph L param p₂ r₂ ∧ r = c.and param p₁ p₂ r₁ r₂ := + by + intro h + rcases Graph.case_iff.mp h with + ⟨_, + (⟨_, _, _, H, _⟩ | ⟨_, _, _, H, _⟩ | ⟨H, _⟩ | ⟨H, _⟩ | ⟨_, _, _, _, _, _, H, rfl⟩ | + ⟨_, _, _, _, _, _, H, _⟩ | ⟨_, _, _, H, _⟩ | ⟨_, _, _, H, _⟩)⟩ + · simp [qqAnd, qqRel] at H + · simp [qqAnd, qqNRel] at H + · simp [qqAnd, qqVerum] at H + · simp [qqAnd, qqFalsum] at H + · rcases (by simpa [qqAnd] using H) with ⟨rfl, rfl, rfl⟩ + exact ⟨_, _, by assumption, by assumption, rfl⟩ + · simp [qqAnd, qqOr] at H + · simp [qqAnd, qqAll] at H + · simp [qqAnd, qqExs] at H + +lemma graph_or {p₁ p₂ r₁ r₂ : V} (hp₁ : IsUFormula L p₁) (hp₂ : IsUFormula L p₂) + (h₁ : c.Graph L param p₁ r₁) (h₂ : c.Graph L param p₂ r₂) : + c.Graph L param (p₁ ^⋎ p₂) (c.or param p₁ p₂ r₁ r₂) := + (Graph.case_iff).mpr + ⟨by simp [hp₁, hp₂], + Or.inr <| + Or.inr <| Or.inr <| Or.inr <| Or.inr <| Or.inl ⟨p₁, p₂, r₁, r₂, h₁, h₂, rfl, rfl⟩⟩ + +lemma graph_or_inv {p₁ p₂ r : V} : + c.Graph L param (p₁ ^⋎ p₂) r → + ∃ r₁ r₂, c.Graph L param p₁ r₁ ∧ c.Graph L param p₂ r₂ ∧ r = c.or param p₁ p₂ r₁ r₂ := + by + intro h + rcases Graph.case_iff.mp h with + ⟨_, + (⟨_, _, _, H, _⟩ | ⟨_, _, _, H, _⟩ | ⟨H, _⟩ | ⟨H, _⟩ | ⟨_, _, _, _, _, _, H, _⟩ | + ⟨_, _, _, _, _, _, H, rfl⟩ | ⟨_, _, _, H, _⟩ | ⟨_, _, _, H, _⟩)⟩ + · simp [qqOr, qqRel] at H + · simp [qqOr, qqNRel] at H + · simp [qqOr, qqVerum] at H + · simp [qqOr, qqFalsum] at H + · simp [qqOr, qqAnd] at H + · rcases (by simpa [qqOr] using H) with ⟨rfl, rfl, rfl⟩ + exact ⟨_, _, by assumption, by assumption, rfl⟩ + · simp [qqOr, qqAll] at H + · simp [qqOr, qqExs] at H + +lemma graph_all {p₁ r₁ : V} (hp₁ : IsUFormula L p₁) + (h₁ : c.Graph L (c.allChanges param) p₁ r₁) : c.Graph L param (^∀ p₁) (c.all param p₁ r₁) := + (Graph.case_iff).mpr + ⟨by simp [hp₁], + Or.inr <| Or.inr <| Or.inr <| Or.inr <| Or.inr <| Or.inr <| Or.inl ⟨p₁, r₁, h₁, rfl, rfl⟩⟩ + +lemma graph_all_inv {p₁ r : V} : + c.Graph L param (^∀ p₁) r → + ∃ r₁, c.Graph L (c.allChanges param) p₁ r₁ ∧ r = c.all param p₁ r₁ := + by + intro h + rcases Graph.case_iff.mp h with + ⟨_, + (⟨_, _, _, H, _⟩ | ⟨_, _, _, H, _⟩ | ⟨H, _⟩ | ⟨H, _⟩ | ⟨_, _, _, _, _, _, H, _⟩ | + ⟨_, _, _, _, _, _, H, _⟩ | ⟨_, _, _, H, rfl⟩ | ⟨_, _, _, H, _⟩)⟩ + · simp [qqAll, qqRel] at H + · simp [qqAll, qqNRel] at H + · simp [qqAll, qqVerum] at H + · simp [qqAll, qqFalsum] at H + · simp [qqAll, qqAnd] at H + · simp [qqAll, qqOr] at H + · rcases (by simpa [qqAll] using H) with ⟨rfl, rfl⟩ + exact ⟨_, by assumption, rfl⟩ + · simp [qqAll, qqExs] at H + +lemma graph_ex {p₁ r₁ : V} (hp₁ : IsUFormula L p₁) (h₁ : c.Graph L (c.exsChanges param) p₁ r₁) : + c.Graph L param (^∃ p₁) (c.exs param p₁ r₁) := + (Graph.case_iff).mpr + ⟨by simp [hp₁], + Or.inr <| Or.inr <| Or.inr <| Or.inr <| Or.inr <| Or.inr <| Or.inr ⟨p₁, r₁, h₁, rfl, rfl⟩⟩ + +lemma graph_ex_inv {p₁ r : V} : + c.Graph L param (^∃ p₁) r → + ∃ r₁, c.Graph L (c.exsChanges param) p₁ r₁ ∧ r = c.exs param p₁ r₁ := + by + intro h + rcases Graph.case_iff.mp h with + ⟨_, + (⟨_, _, _, H, _⟩ | ⟨_, _, _, H, _⟩ | ⟨H, _⟩ | ⟨H, _⟩ | ⟨_, _, _, _, _, _, H, _⟩ | + ⟨_, _, _, _, _, _, H, _⟩ | ⟨_, _, _, H, _⟩ | ⟨_, _, _, H, rfl⟩)⟩ + · simp [qqExs, qqRel] at H + · simp [qqExs, qqNRel] at H + · simp [qqExs, qqVerum] at H + · simp [qqExs, qqFalsum] at H + · simp [qqExs, qqAnd] at H + · simp [qqExs, qqOr] at H + · simp [qqExs, qqAll] at H + · rcases (by simpa [qqExs] using H) with ⟨rfl, rfl⟩ + exact ⟨_, by assumption, rfl⟩ + +variable (param) + +lemma graph_exists {p : V} : IsUFormula L p → ∃ y, c.Graph L param p y := + by + have : Σ₁-Function₁ c.allChanges := c.allChanges_defined.to_definable + have : Σ₁-Function₁ c.exsChanges := c.exChanges_defined.to_definable + let f : V → V → V := fun _ param ↦ + Max.max param (Max.max (c.allChanges param) (c.exsChanges param)) + have hf : Σ₁-Function₂ f := by definability + apply bounded_all_sigma1_order_induction hf ?_ ?_ p param + · definability + intro p param ih hp + rcases hp.case with + (⟨k, r, v, hkr, hv, rfl⟩ | ⟨k, r, v, hkr, hv, rfl⟩ | rfl | rfl | ⟨p₁, p₂, hp₁, hp₂, rfl⟩ | + ⟨p₁, p₂, hp₁, hp₂, rfl⟩ | ⟨p₁, hp₁, rfl⟩ | ⟨p₁, hp₁, rfl⟩) + · exact ⟨c.rel param k r v, c.graph_rel hkr hv⟩ + · exact ⟨c.nrel param k r v, c.graph_nrel hkr hv⟩ + · exact ⟨c.verum param, c.graph_verum⟩ + · exact ⟨c.falsum param, c.graph_falsum⟩ + · rcases ih p₁ (by simp) param (by simp [f]) hp₁ with ⟨y₁, h₁⟩ + rcases ih p₂ (by simp) param (by simp [f]) hp₂ with ⟨y₂, h₂⟩ + exact ⟨c.and param p₁ p₂ y₁ y₂, c.graph_and hp₁ hp₂ h₁ h₂⟩ + · rcases ih p₁ (by simp) param (by simp [f]) hp₁ with ⟨y₁, h₁⟩ + rcases ih p₂ (by simp) param (by simp [f]) hp₂ with ⟨y₂, h₂⟩ + exact ⟨c.or param p₁ p₂ y₁ y₂, c.graph_or hp₁ hp₂ h₁ h₂⟩ + · rcases ih p₁ (by simp) (c.allChanges param) (by simp [f]) hp₁ with ⟨y₁, h₁⟩ + exact ⟨c.all param p₁ y₁, c.graph_all hp₁ h₁⟩ + · rcases ih p₁ (by simp) (c.exsChanges param) (by simp [f]) hp₁ with ⟨y₁, h₁⟩ + exact ⟨c.exs param p₁ y₁, c.graph_ex hp₁ h₁⟩ + +lemma graph_unique {p : V} : + IsUFormula L p → ∀ {param r r'}, c.Graph L param p r → c.Graph L param p r' → r = r' := + by + apply + IsUFormula.ISigma1.pi1_succ_induction (P := fun p ↦ + ∀ {param r r'}, c.Graph L param p r → c.Graph L param p r' → r = r') (by definability) + case hrel => + intro k R v hkR hv + simp [c.graph_rel_iff hkR hv] + case hnrel => + intro k R v hkR hv + simp [c.graph_nrel_iff hkR hv] + case hverum => simp [c.graph_verum_iff] + case hfalsum => simp [c.graph_falsum_iff] + case hand => + intro p₁ p₂ _ _ ih₁ ih₂ param r r' hr hr' + rcases c.graph_and_inv hr with ⟨r₁, r₂, h₁, h₂, rfl⟩ + rcases c.graph_and_inv hr' with ⟨r₁', r₂', h₁', h₂', rfl⟩ + rcases ih₁ h₁ h₁'; rcases ih₂ h₂ h₂'; rfl + case hor => + intro p₁ p₂ _ _ ih₁ ih₂ param r r' hr hr' + rcases c.graph_or_inv hr with ⟨r₁, r₂, h₁, h₂, rfl⟩ + rcases c.graph_or_inv hr' with ⟨r₁', r₂', h₁', h₂', rfl⟩ + rcases ih₁ h₁ h₁'; rcases ih₂ h₂ h₂'; rfl + case hall => + intro p _ ih param r r' hr hr' + rcases c.graph_all_inv hr with ⟨r₁, h₁, rfl⟩ + rcases c.graph_all_inv hr' with ⟨r₁', h₁', rfl⟩ + rcases ih h₁ h₁'; rfl + case hexs => + intro p _ ih param r r' hr hr' + rcases c.graph_ex_inv hr with ⟨r₁, h₁, rfl⟩ + rcases c.graph_ex_inv hr' with ⟨r₁', h₁', rfl⟩ + rcases ih h₁ h₁'; rfl + +lemma exists_unique {p : V} (hp : IsUFormula L p) : ∃! r, c.Graph L param p r := + by + rcases c.graph_exists param hp with ⟨r, hr⟩ + exact ExistsUnique.intro r hr (fun r' hr' ↦ c.graph_unique hp hr' hr) + +variable (L) + +lemma exists_unique_all (p : V) : + ∃! r, (IsUFormula L p → c.Graph L param p r) ∧ (¬IsUFormula L p → r = 0) := by + by_cases hp : IsUFormula L p <;> simp [hp, exists_unique] + +/-- The result construction in +`FFL.FirstOrder.Arithmetic.Bootstrapping.UformulaRec1.Construction`. -/ +noncomputable def result (p : V) : V := + Classical.chooseUnique (c.exists_unique_all L param p) + +variable {L} + +lemma result_prop {p : V} (hp : IsUFormula L p) : c.Graph L param p (c.result L param p) := + Classical.chooseUnique_spec (c.exists_unique_all L param p) |>.1 hp + +lemma result_prop_not {p : V} (hp : ¬IsUFormula L p) : c.result L param p = 0 := + Classical.chooseUnique_spec (c.exists_unique_all L param p) |>.2 hp + +variable {param} + +lemma result_eq_of_graph {p r} (h : c.Graph L param p r) : c.result L param p = r := + Eq.symm <| + Classical.choose_uniq (c.exists_unique_all L param p) (by simp [c.graph_dom_uformula h, h]) + +@[simp] +lemma result_rel {k R v} (hR : L.IsRel k R) (hv : IsUTermVec L k v) : + c.result L param (^rel k R v) = c.rel param k R v := + c.result_eq_of_graph (c.graph_rel hR hv) + +@[simp] +lemma result_nrel {k R v} (hR : L.IsRel k R) (hv : IsUTermVec L k v) : + c.result L param (^nrel k R v) = c.nrel param k R v := + c.result_eq_of_graph (c.graph_nrel hR hv) + +@[simp] +lemma result_verum : c.result L param ^⊤ = c.verum param := + c.result_eq_of_graph c.graph_verum + +@[simp] +lemma result_falsum : c.result L param ^⊥ = c.falsum param := + c.result_eq_of_graph c.graph_falsum + +@[simp] +lemma result_and {p q} (hp : IsUFormula L p) (hq : IsUFormula L q) : + c.result L param (p ^⋏ q) = c.and param p q (c.result L param p) (c.result L param q) := + c.result_eq_of_graph (c.graph_and hp hq (c.result_prop param hp) (c.result_prop param hq)) + +@[simp] +lemma result_or {p q} (hp : IsUFormula L p) (hq : IsUFormula L q) : + c.result L param (p ^⋎ q) = c.or param p q (c.result L param p) (c.result L param q) := + c.result_eq_of_graph (c.graph_or hp hq (c.result_prop param hp) (c.result_prop param hq)) + +@[simp] +lemma result_all {p} (hp : IsUFormula L p) : + c.result L param (^∀ p) = c.all param p (c.result L (c.allChanges param) p) := + c.result_eq_of_graph (c.graph_all hp (c.result_prop (c.allChanges param) hp)) + +@[simp] +lemma result_exs {p} (hp : IsUFormula L p) : + c.result L param (^∃ p) = c.exs param p (c.result L (c.exsChanges param) p) := + c.result_eq_of_graph (c.graph_ex hp (c.result_prop _ hp)) + +section + +lemma result_defined : Σ₁-Function₂ c.result L via β.result L := + .mk fun v ↦ by simp [Blueprint.result, result, c.eval_graphDef] + +instance result_definable : Σ-[0 + 1]-Function₂ c.result L := + c.result_defined.to_definable + +end + +lemma uformula_result_induction {P : V → V → V → Prop} (hP : Σ₁-Relation₃ P) + (hRel : + ∀ param k R v, L.IsRel k R → IsUTermVec L k v → P param (^rel k R v) (c.rel param k R v)) + (hNRel : + ∀ param k R v, + L.IsRel k R → IsUTermVec L k v → P param (^nrel k R v) (c.nrel param k R v)) + (hverum : ∀ param, P param ^⊤ (c.verum param)) + (hfalsum : ∀ param, P param ^⊥ (c.falsum param)) + (hand : + ∀ param p q, + IsUFormula L p → + IsUFormula L q → + P param p (c.result L param p) → + P param q (c.result L param q) → + P param (p ^⋏ q) (c.and param p q (c.result L param p) (c.result L param q))) + (hor : + ∀ param p q, + IsUFormula L p → + IsUFormula L q → + P param p (c.result L param p) → + P param q (c.result L param q) → + P param (p ^⋎ q) (c.or param p q (c.result L param p) (c.result L param q))) + (hall : + ∀ param p, + IsUFormula L p → + P (c.allChanges param) p (c.result L (c.allChanges param) p) → + P param (^∀ p) (c.all param p (c.result L (c.allChanges param) p))) + (hexs : + ∀ param p, + IsUFormula L p → + P (c.exsChanges param) p (c.result L (c.exsChanges param) p) → + P param (^∃ p) (c.exs param p (c.result L (c.exsChanges param) p))) : + ∀ {param p : V}, IsUFormula L p → P param p (c.result L param p) := + by + have : Σ₁-Function₂ c.result L := c.result_definable + have : Σ₁-Function₁ c.allChanges := c.allChanges_defined.to_definable + have : Σ₁-Function₁ c.exsChanges := c.exChanges_defined.to_definable + let f : V → V → V := fun _ param ↦ + Max.max param (Max.max (c.allChanges param) (c.exsChanges param)) + have hf : Σ₁-Function₂ f := by definability + intro param p + apply bounded_all_sigma1_order_induction hf ?_ ?_ p param + · apply + HierarchySymbol.Definable.imp + (HierarchySymbol.Definable.comp₁ (HierarchySymbol.DefinableFunction.var _)) + (HierarchySymbol.Definable.comp₃ (HierarchySymbol.DefinableFunction.var _) + (HierarchySymbol.DefinableFunction.var _) + (HierarchySymbol.DefinableFunction₂.comp (HierarchySymbol.DefinableFunction.var _) + (HierarchySymbol.DefinableFunction.var _))) + intro p param ih hp + rcases hp.case with + (⟨k, r, v, hkr, hv, rfl⟩ | ⟨k, r, v, hkr, hv, rfl⟩ | rfl | rfl | ⟨p₁, p₂, hp₁, hp₂, rfl⟩ | + ⟨p₁, p₂, hp₁, hp₂, rfl⟩ | ⟨p₁, hp₁, rfl⟩ | ⟨p₁, hp₁, rfl⟩) + · simpa [hkr, hv] using hRel param k r v hkr hv + · simpa [hkr, hv] using hNRel param k r v hkr hv + · simpa using hverum param + · simpa using hfalsum param + · simpa [c.result_and hp₁ hp₂] using + hand param p₁ p₂ hp₁ hp₂ (ih p₁ (by simp) param (by simp [f]) hp₁) + (ih p₂ (by simp) param (by simp [f]) hp₂) + · simpa [c.result_or hp₁ hp₂] using + hor param p₁ p₂ hp₁ hp₂ (ih p₁ (by simp) param (by simp [f]) hp₁) + (ih p₂ (by simp) param (by simp [f]) hp₂) + · simpa [c.result_all hp₁] using + hall param p₁ hp₁ (ih p₁ (by simp) (c.allChanges param) (by simp [f]) hp₁) + · simpa [c.result_exs hp₁] using + hexs param p₁ hp₁ (ih p₁ (by simp) (c.exsChanges param) (by simp [f]) hp₁) + +end Construction + +end UformulaRec1 + +section bv + +namespace BV + +variable (L) + +/-- The blueprint construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.BV`. -/ +noncomputable def blueprint : UformulaRec1.Blueprint + where + rel := .mkSigma (“y param k R v. ∃ M, !(termBVVecGraph L)M k v ∧ !listMaxDef y M”) + nrel := .mkSigma (“y param k R v. ∃ M, !(termBVVecGraph L)M k v ∧ !listMaxDef y M”) + verum := .mkSigma (“y param. y = 0”) + falsum := .mkSigma (“y param. y = 0”) + and := .mkSigma (“y param p₁ p₂ y₁ y₂. !max.dfn y y₁ y₂”) + or := .mkSigma (“y param p₁ p₂ y₁ y₂. !max.dfn y y₁ y₂”) + all := .mkSigma (“y param p₁ y₁. !subDef y y₁ 1”) + exs := .mkSigma (“y param p₁ y₁. !subDef y y₁ 1”) + allChanges := .mkSigma (“param' param. param' = 0”) + exsChanges := .mkSigma (“param' param. param' = 0”) + +/-- The construction construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.BV`. -/ +noncomputable def construction : UformulaRec1.Construction V (blueprint L) + where + rel {_} := fun k _ v ↦ listMax (termBVVec L k v) + nrel {_} := fun k _ v ↦ listMax (termBVVec L k v) + verum {_} := 0 + falsum {_} := 0 + and {_} := fun _ _ y₁ y₂ ↦ Max.max y₁ y₂ + or {_} := fun _ _ y₁ y₂ ↦ Max.max y₁ y₂ + all {_} := fun _ y₁ ↦ y₁ - 1 + exs {_} := fun _ y₁ ↦ y₁ - 1 + allChanges := fun _ ↦ 0 + exsChanges := fun _ ↦ 0 + rel_defined := .mk fun v ↦ by simp [blueprint] + nrel_defined := .mk fun v ↦ by simp [blueprint] + verum_defined := .mk fun v ↦ by simp [blueprint] + falsum_defined := .mk fun v ↦ by simp [blueprint] + and_defined := .mk fun v ↦ by simp [blueprint] + or_defined := .mk fun v ↦ by simp [blueprint] + all_defined := .mk fun v ↦ by simp [blueprint] + exs_defined := .mk fun v ↦ by simp [blueprint] + allChanges_defined := .mk fun v ↦ by simp [blueprint] + exChanges_defined := .mk fun v ↦ by simp [blueprint] + +end BV + +open BV + +variable (L) + +/-- The bv construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def bv (p : V) : V := + (BV.construction L).result L 0 p + +/-- The bv Graph construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def bvGraph : Σ₁.Semisentence 2 := + ((BV.blueprint L).result L).rew (Rew.subst ![#0, ‘0’, #1]) + +variable {L} + +section + +instance bv.defined : Σ₁-Function₁ bv (V := V) L via bvGraph L := + .mk fun v ↦ by + simpa [bvGraph, Matrix.comp_vecCons', Matrix.constant_eq_singleton] using! + (BV.construction L).result_defined.defined ![v 0, 0, v 1] + +instance bv.definable : Σ₁-Function₁ bv (V := V) L := + bv.defined.to_definable + +instance bv.definable' : Γ-[m + 1]-Function₁ bv (V := V) L := + bv.definable.of_sigmaOne + +end + +@[simp] +lemma bv_rel {k R v : V} (hR : L.IsRel k R) (hv : IsUTermVec L k v) : + bv L (^rel k R v) = listMax (termBVVec L k v) := by simp [bv, hR, hv, BV.construction] + +@[simp] +lemma bv_nrel {k R v : V} (hR : L.IsRel k R) (hv : IsUTermVec L k v) : + bv L (^nrel k R v) = listMax (termBVVec L k v) := by simp [bv, hR, hv, BV.construction] + +@[simp] +lemma bv_verum : bv L (^⊤ : V) = 0 := by simp [bv, BV.construction] + +@[simp] +lemma bv_falsum : bv L (^⊥ : V) = 0 := by simp [bv, BV.construction] + +@[simp] +lemma bv_and {p q : V} (hp : IsUFormula L p) (hq : IsUFormula L q) : + bv L (p ^⋏ q) = Max.max (bv L p) (bv L q) := by simp [bv, hp, hq, BV.construction] + +@[simp] +lemma bv_or {p q : V} (hp : IsUFormula L p) (hq : IsUFormula L q) : + bv L (p ^⋎ q) = Max.max (bv L p) (bv L q) := by simp [bv, hp, hq, construction] + +@[simp] +lemma bv_all {p : V} (hp : IsUFormula L p) : bv L (^∀ p) = bv L p - 1 := by + simp [bv, hp, construction] + +@[simp] +lemma bv_ex {p : V} (hp : IsUFormula L p) : bv L (^∃ p) = bv L p - 1 := by + simp [bv, hp, construction] + +lemma bv_eq_of_not_isUFormula {p : V} (h : ¬IsUFormula L p) : bv L p = 0 := + (construction L).result_prop_not _ h + +end bv + +section isSemiformula + +variable (L) + +/-- Data and laws for Is Semiformula in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +structure IsSemiformula (n p : V) : Prop where + isUFormula : IsUFormula L p + bv_le : bv L p ≤ n + +/-- The Is Formula construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +abbrev IsFormula (p : V) : Prop := + IsSemiformula L 0 p + +/-- The is Semiformula construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def isSemiformula : ∆₁.Semisentence 2 := + .mkDelta (.mkSigma (“n p. !(isUFormula L).sigma p ∧ ∃ b, !(bvGraph L)b p ∧ b ≤ n”)) + (.mkPi (“n p. !(isUFormula L).pi p ∧ ∀ b, !(bvGraph L)b p → b ≤ n”)) + +variable {L} + +lemma isSemiformula_iff {n p : V} : IsSemiformula L n p ↔ IsUFormula L p ∧ bv L p ≤ n := + ⟨fun h ↦ ⟨h.isUFormula, h.bv_le⟩, by rintro ⟨hp, h⟩; exact ⟨hp, h⟩⟩ + +section + +instance IsSemiformula.defined : ∆₁-Relation IsSemiformula (V := V) L via isSemiformula L := + .mk <| by + constructor + · intro v; simp [isSemiformula, HierarchySymbol.Semiformula.val_sigma, bv.defined.iff] + · intro v; + simp [isSemiformula, HierarchySymbol.Semiformula.val_sigma, bv.defined.iff, + isSemiformula_iff] + +instance IsSemiformula.definable : ∆₁-Relation IsSemiformula (V := V) L := + IsSemiformula.defined.to_definable + +instance IsSemiformula.definable' : Γ-[m + 1]-Relation IsSemiformula (V := V) L := + IsSemiformula.definable.of_deltaOne + +end + +@[simp] +lemma IsUFormula.isSemiformula {p : V} (h : IsUFormula L p) : IsSemiformula L (bv L p) p + where + isUFormula := h + bv_le := by rfl + +@[simp] +lemma IsSemiformula.rel {n k r v : V} : + IsSemiformula L n (^rel k r v) ↔ L.IsRel k r ∧ IsSemitermVec L k n v := + by + constructor + · intro h + have hrv : L.IsRel k r ∧ IsUTermVec L k v := by simpa using h.isUFormula + exact + ⟨hrv.1, hrv.2, fun {i} hi ↦ + by + have : listMax (termBVVec L k v) ≤ n := by simpa [hrv] using h.bv_le + exact le_trans (le_trans (by simp_all) (nth_le_listMax (i := i) (by simp_all))) this⟩ + · rintro ⟨hr, hv⟩ + exact + ⟨by simp [hr, hv.isUTerm], by + rw [bv_rel hr hv.isUTerm] + apply listMaxss_le + intro i hi + have := hv.bv (i := i) (by simpa [hv.isUTerm] using hi) + rwa [nth_termBVVec hv.isUTerm (by simpa [hv.isUTerm] using hi)]⟩ + +@[simp] +lemma IsSemiformula.nrel {n k r v : V} : + IsSemiformula L n (^nrel k r v) ↔ L.IsRel k r ∧ IsSemitermVec L k n v := + by + constructor + · intro h + have hrv : L.IsRel k r ∧ IsUTermVec L k v := by simpa using h.isUFormula + exact + ⟨hrv.1, hrv.2, fun {i} hi ↦ + by + have : listMax (termBVVec L k v) ≤ n := by simpa [hrv] using h.bv_le + exact le_trans (le_trans (by simp_all) (nth_le_listMax (i := i) (by simp_all))) this⟩ + · rintro ⟨hr, hv⟩ + exact + ⟨by simp [hr, hv.isUTerm], by + rw [bv_nrel hr hv.isUTerm] + apply listMaxss_le + intro i hi + have := hv.bv (i := i) (by simpa [hv.isUTerm] using hi) + rwa [nth_termBVVec hv.isUTerm (by simpa [hv.isUTerm] using hi)]⟩ + +@[simp] +lemma IsSemiformula.verum {n : V} : IsSemiformula L n ^⊤ := + ⟨by simp, by simp⟩ + +@[simp] +lemma IsSemiformula.falsum {n : V} : IsSemiformula L n ^⊥ := + ⟨by simp, by simp⟩ + +@[simp] +lemma IsSemiformula.and {n p q : V} : + IsSemiformula L n (p ^⋏ q) ↔ IsSemiformula L n p ∧ IsSemiformula L n q := + by + constructor + · intro h + have hpq : IsUFormula L p ∧ IsUFormula L q := by simpa using h.isUFormula + have hbv : bv L p ≤ n ∧ bv L q ≤ n := by simpa [hpq] using h.bv_le + exact ⟨⟨hpq.1, hbv.1⟩, ⟨hpq.2, hbv.2⟩⟩ + · rintro ⟨hp, hq⟩ + exact + ⟨by simp [hp.isUFormula, hq.isUFormula], by + simp [hp.isUFormula, hq.isUFormula, hp.bv_le, hq.bv_le]⟩ + +@[simp] +lemma IsSemiformula.or {n p q : V} : + IsSemiformula L n (p ^⋎ q) ↔ IsSemiformula L n p ∧ IsSemiformula L n q := + by + constructor + · intro h + have hpq : IsUFormula L p ∧ IsUFormula L q := by simpa using h.isUFormula + have hbv : bv L p ≤ n ∧ bv L q ≤ n := by simpa [hpq] using h.bv_le + exact ⟨⟨hpq.1, hbv.1⟩, ⟨hpq.2, hbv.2⟩⟩ + · rintro ⟨hp, hq⟩ + exact + ⟨by simp [hp.isUFormula, hq.isUFormula], by + simp [hp.isUFormula, hq.isUFormula, hp.bv_le, hq.bv_le]⟩ + +@[simp] +lemma IsSemiformula.all {n p : V} : IsSemiformula L n (^∀ p) ↔ IsSemiformula L (n + 1) p := + by + constructor + · intro h + exact + ⟨by simpa using h.isUFormula, by + simpa [show IsUFormula L p by simpa using h.isUFormula] using h.bv_le⟩ + · intro h + exact ⟨by simp [h.isUFormula], by simp [h.isUFormula, h.bv_le]⟩ + +@[simp] +lemma IsSemiformula.exs {n p : V} : IsSemiformula L n (^∃ p) ↔ IsSemiformula L (n + 1) p := + by + constructor + · intro h + exact + ⟨by simpa using h.isUFormula, by + simpa [show IsUFormula L p by simpa using h.isUFormula] using h.bv_le⟩ + · intro h + exact ⟨by simp [h.isUFormula], by simp [h.isUFormula, h.bv_le]⟩ + +lemma IsSemiformula.case_iff {n p : V} : + IsSemiformula L n p ↔ + (∃ k R v, L.IsRel k R ∧ IsSemitermVec L k n v ∧ p = ^rel k R v) ∨ + (∃ k R v, L.IsRel k R ∧ IsSemitermVec L k n v ∧ p = ^nrel k R v) ∨ + (p = ^⊤) ∨ + (p = ^⊥) ∨ + (∃ p₁ p₂, IsSemiformula L n p₁ ∧ IsSemiformula L n p₂ ∧ p = p₁ ^⋏ p₂) ∨ + (∃ p₁ p₂, IsSemiformula L n p₁ ∧ IsSemiformula L n p₂ ∧ p = p₁ ^⋎ p₂) ∨ + (∃ p₁, IsSemiformula L (n + 1) p₁ ∧ p = ^∀ p₁) ∨ + (∃ p₁, IsSemiformula L (n + 1) p₁ ∧ p = ^∃ p₁) := + by + constructor + · intro h + rcases h.isUFormula.case with + (⟨k, r, v, _, _, rfl⟩ | ⟨k, r, v, _, _, rfl⟩ | rfl | rfl | ⟨p₁, p₂, _, _, rfl⟩ | + ⟨p₁, p₂, _, _, rfl⟩ | ⟨p₁, _, rfl⟩ | ⟨p₁, _, rfl⟩) + · have : L.IsRel k r ∧ IsSemitermVec L k n v := by simpa using h + exact Or.inl ⟨k, r, v, by simp [this]⟩ + · have : L.IsRel k r ∧ IsSemitermVec L k n v := by simpa using h + exact Or.inr <| Or.inl ⟨k, r, v, by simp [this]⟩ + · exact Or.inr <| Or.inr <| Or.inl rfl + · exact Or.inr <| Or.inr <| Or.inr <| Or.inl rfl + · have : IsSemiformula L n p₁ ∧ IsSemiformula L n p₂ := by simpa using h + exact Or.inr <| Or.inr <| Or.inr <| Or.inr <| Or.inl ⟨p₁, p₂, by simp [this]⟩ + · have : IsSemiformula L n p₁ ∧ IsSemiformula L n p₂ := by simpa using h + exact Or.inr <| Or.inr <| Or.inr <| Or.inr <| Or.inr <| Or.inl ⟨p₁, p₂, by simp [this]⟩ + · have : IsSemiformula L (n + 1) p₁ := by simpa using h + exact + Or.inr <| Or.inr <| Or.inr <| Or.inr <| Or.inr <| Or.inr <| Or.inl ⟨p₁, by simp [this]⟩ + · have : IsSemiformula L (n + 1) p₁ := by simpa using h + exact + Or.inr <| Or.inr <| Or.inr <| Or.inr <| Or.inr <| Or.inr <| Or.inr ⟨p₁, by simp [this]⟩ + · rintro + (⟨k, R, v, hR, hv, rfl⟩ | ⟨k, R, v, hR, hv, rfl⟩ | rfl | rfl | ⟨p₁, p₂, h₁, h₂, rfl⟩ | + ⟨p₁, p₂, h₁, h₂, rfl⟩ | ⟨p₁, h₁, rfl⟩ | ⟨p₁, h₁, rfl⟩) <;> + simp [*] + +lemma IsSemiformula.case {P : V → V → Prop} {n p} (hp : IsSemiformula L n p) + (hrel : ∀ n k r v, L.IsRel k r → IsSemitermVec L k n v → P n (^rel k r v)) + (hnrel : ∀ n k r v, L.IsRel k r → IsSemitermVec L k n v → P n (^nrel k r v)) + (hverum : ∀ n, P n ^⊤) (hfalsum : ∀ n, P n ^⊥) + (hand : ∀ n p q, IsSemiformula L n p → IsSemiformula L n q → P n (p ^⋏ q)) + (hor : ∀ n p q, IsSemiformula L n p → IsSemiformula L n q → P n (p ^⋎ q)) + (hall : ∀ n p, IsSemiformula L (n + 1) p → P n (^∀ p)) + (hexs : ∀ n p, IsSemiformula L (n + 1) p → P n (^∃ p)) : P n p := + by + rcases IsSemiformula.case_iff.mp hp with + (⟨k, R, v, hR, hv, rfl⟩ | ⟨k, R, v, hR, hv, rfl⟩ | rfl | rfl | ⟨p₁, p₂, h₁, h₂, rfl⟩ | + ⟨p₁, p₂, h₁, h₂, rfl⟩ | ⟨p₁, h₁, rfl⟩ | ⟨p₁, h₁, rfl⟩) + · exact hrel _ _ _ _ hR hv + · exact hnrel _ _ _ _ hR hv + · exact hverum n + · exact hfalsum n + · exact hand _ _ _ h₁ h₂ + · exact hor _ _ _ h₁ h₂ + · exact hall _ _ h₁ + · exact hexs _ _ h₁ + +lemma IsSemiformula.sigma1_structural_induction {P : V → V → Prop} (hP : Σ₁-Relation P) + (hrel : ∀ n k r v, L.IsRel k r → IsSemitermVec L k n v → P n (^rel k r v)) + (hnrel : ∀ n k r v, L.IsRel k r → IsSemitermVec L k n v → P n (^nrel k r v)) + (hverum : ∀ n, P n ^⊤) (hfalsum : ∀ n, P n ^⊥) + (hand : ∀ n p q, IsSemiformula L n p → IsSemiformula L n q → P n p → P n q → P n (p ^⋏ q)) + (hor : ∀ n p q, IsSemiformula L n p → IsSemiformula L n q → P n p → P n q → P n (p ^⋎ q)) + (hall : ∀ n p, IsSemiformula L (n + 1) p → P (n + 1) p → P n (^∀ p)) + (hexs : ∀ n p, IsSemiformula L (n + 1) p → P (n + 1) p → P n (^∃ p)) {n p} : + IsSemiformula L n p → P n p := + by + have : Σ₁-Function₂ (fun _ (n : V) ↦ n + 1) := by definability + apply bounded_all_sigma1_order_induction this ?_ ?_ p n + · apply HierarchySymbol.Definable.imp + · apply + HierarchySymbol.Definable.comp₂ (HierarchySymbol.DefinableFunction.var _) + (HierarchySymbol.DefinableFunction.var _) + · apply + HierarchySymbol.Definable.comp₂ (HierarchySymbol.DefinableFunction.var _) + (HierarchySymbol.DefinableFunction.var _) + intro p n ih hp + rcases IsSemiformula.case_iff.mp hp with + (⟨k, R, v, hR, hv, rfl⟩ | ⟨k, R, v, hR, hv, rfl⟩ | rfl | rfl | ⟨p₁, p₂, h₁, h₂, rfl⟩ | + ⟨p₁, p₂, h₁, h₂, rfl⟩ | ⟨p₁, h₁, rfl⟩ | ⟨p₁, h₁, rfl⟩) + · apply hrel _ _ _ _ hR hv + · apply hnrel _ _ _ _ hR hv + · apply hverum + · apply hfalsum + · apply hand _ _ _ h₁ h₂ (ih p₁ (by simp) n (by simp) h₁) (ih p₂ (by simp) n (by simp) h₂) + · apply hor _ _ _ h₁ h₂ (ih p₁ (by simp) n (by simp) h₁) (ih p₂ (by simp) n (by simp) h₂) + · apply hall _ _ h₁ (ih p₁ (by simp) (n + 1) (by simp) h₁) + · apply hexs _ _ h₁ (ih p₁ (by simp) (n + 1) (by simp) h₁) + +lemma IsSemiformula.pi1_structural_induction {P : V → V → Prop} (hP : Π₁-Relation P) + (hrel : ∀ n k r v, L.IsRel k r → IsSemitermVec L k n v → P n (^rel k r v)) + (hnrel : ∀ n k r v, L.IsRel k r → IsSemitermVec L k n v → P n (^nrel k r v)) + (hverum : ∀ n, P n ^⊤) (hfalsum : ∀ n, P n ^⊥) + (hand : ∀ n p q, IsSemiformula L n p → IsSemiformula L n q → P n p → P n q → P n (p ^⋏ q)) + (hor : ∀ n p q, IsSemiformula L n p → IsSemiformula L n q → P n p → P n q → P n (p ^⋎ q)) + (hall : ∀ n p, IsSemiformula L (n + 1) p → P (n + 1) p → P n (^∀ p)) + (hexs : ∀ n p, IsSemiformula L (n + 1) p → P (n + 1) p → P n (^∃ p)) {n p} : + IsSemiformula L n p → P n p := + by + suffices IsUFormula L p → ∀ n, IsSemiformula L n p → P n p + by + intro h + exact this h.isUFormula n h + apply IsUFormula.ISigma1.pi1_succ_induction (P := fun p ↦ ∀ n, IsSemiformula L n p → P n p) + · definability + · intro k R v hR _ n h + have : L.IsRel k R ∧ IsSemitermVec L k n v := by simpa using h + exact hrel _ _ _ _ hR this.2 + · intro k R v hR _ n h + have : L.IsRel k R ∧ IsSemitermVec L k n v := by simpa using h + exact hnrel _ _ _ _ hR this.2 + · intro n _; apply hverum + · intro n _; apply hfalsum + · intro p q _ _ ihp ihq n h + have : IsSemiformula L n p ∧ IsSemiformula L n q := by simpa using h + apply hand _ _ _ this.1 this.2 (ihp n this.1) (ihq n this.2) + · intro p q _ _ ihp ihq n h + have : IsSemiformula L n p ∧ IsSemiformula L n q := by simpa using h + apply hor _ _ _ this.1 this.2 (ihp n this.1) (ihq n this.2) + · intro p _ ihp n h + have : IsSemiformula L (n + 1) p := by simpa using h + apply hall _ _ this (ihp _ this) + · intro p _ ihp n h + have : IsSemiformula L (n + 1) p := by simpa using h + apply hexs _ _ this (ihp _ this) + +lemma IsSemiformula.induction1 (Γ) {P : V → V → Prop} (hP : Γ-[1]-Relation P) + (hrel : ∀ n k r v, L.IsRel k r → IsSemitermVec L k n v → P n (^rel k r v)) + (hnrel : ∀ n k r v, L.IsRel k r → IsSemitermVec L k n v → P n (^nrel k r v)) + (hverum : ∀ n, P n ^⊤) (hfalsum : ∀ n, P n ^⊥) + (hand : ∀ n p q, IsSemiformula L n p → IsSemiformula L n q → P n p → P n q → P n (p ^⋏ q)) + (hor : ∀ n p q, IsSemiformula L n p → IsSemiformula L n q → P n p → P n q → P n (p ^⋎ q)) + (hall : ∀ n p, IsSemiformula L (n + 1) p → P (n + 1) p → P n (^∀ p)) + (hexs : ∀ n p, IsSemiformula L (n + 1) p → P (n + 1) p → P n (^∃ p)) {n p} : + IsSemiformula L n p → P n p := + match Γ with + | Σ => + IsSemiformula.sigma1_structural_induction hP hrel hnrel hverum hfalsum hand hor hall hexs + | Π => IsSemiformula.pi1_structural_induction hP hrel hnrel hverum hfalsum hand hor hall hexs + | ∆ => + IsSemiformula.sigma1_structural_induction hP.of_delta hrel hnrel hverum hfalsum hand hor + hall hexs + +lemma IsSemiformula.pos {n p : V} (h : IsSemiformula L n p) : 0 < p := + h.isUFormula.pos + +@[simp] +lemma IsSemiformula.not_zero (m : V) : ¬IsSemiformula L m (0 : V) := by + intro h; + simpa using h.pos + +end isSemiformula + +namespace UformulaRec1 +namespace Construction + +variable {β : Blueprint} {c : Construction V β} {param : V} + +lemma semiformula_result_induction {P : V → V → V → V → Prop} (hP : Σ₁-Relation₄ P) + (hRel : + ∀ n param k R v, + L.IsRel k R → IsSemitermVec L k n v → P param n (^rel k R v) (c.rel param k R v)) + (hNRel : + ∀ n param k R v, + L.IsRel k R → IsSemitermVec L k n v → P param n (^nrel k R v) (c.nrel param k R v)) + (hverum : ∀ n param, P param n ^⊤ (c.verum param)) + (hfalsum : ∀ n param, P param n ^⊥ (c.falsum param)) + (hand : + ∀ n param p q, + IsSemiformula L n p → + IsSemiformula L n q → + P param n p (c.result L param p) → + P param n q (c.result L param q) → + P param n (p ^⋏ q) (c.and param p q (c.result L param p) (c.result L param q))) + (hor : + ∀ n param p q, + IsSemiformula L n p → + IsSemiformula L n q → + P param n p (c.result L param p) → + P param n q (c.result L param q) → + P param n (p ^⋎ q) (c.or param p q (c.result L param p) (c.result L param q))) + (hall : + ∀ n param p, + IsSemiformula L (n + 1) p → + P (c.allChanges param) (n + 1) p (c.result L (c.allChanges param) p) → + P param n (^∀ p) (c.all param p (c.result L (c.allChanges param) p))) + (hexs : + ∀ n param p, + IsSemiformula L (n + 1) p → + P (c.exsChanges param) (n + 1) p (c.result L (c.exsChanges param) p) → + P param n (^∃ p) (c.exs param p (c.result L (c.exsChanges param) p))) : + ∀ {param n p : V}, IsSemiformula L n p → P param n p (c.result L param p) := + by + have : Σ₁-Function₂ c.result L := c.result_definable + have : Σ₁-Function₁ c.allChanges := c.allChanges_defined.to_definable + have : Σ₁-Function₁ c.exsChanges := c.exChanges_defined.to_definable + let f : V → V → V → V := fun _ param _ ↦ + Max.max param (Max.max (c.allChanges param) (c.exsChanges param)) + have hf : Σ₁-Function₃ f := by definability + let g : V → V → V → V := fun _ _ n ↦ n + 1 + have hg : Σ₁-Function₃ g := by definability + intro param n p + apply bounded_all_sigma1_order_induction₂ hf hg ?_ ?_ p param n + · apply HierarchySymbol.Definable.imp + · apply + HierarchySymbol.Definable.comp₂ (HierarchySymbol.DefinableFunction.var _) + (HierarchySymbol.DefinableFunction.var _) + · apply + HierarchySymbol.Definable.comp₄ (HierarchySymbol.DefinableFunction.var _) + (HierarchySymbol.DefinableFunction.var _) (HierarchySymbol.DefinableFunction.var _) + apply + HierarchySymbol.DefinableFunction₂.comp (HierarchySymbol.DefinableFunction.var _) + (HierarchySymbol.DefinableFunction.var _) + intro p param n ih hp + rcases IsSemiformula.case_iff.mp hp with + (⟨k, R, v, hR, hv, rfl⟩ | ⟨k, R, v, hR, hv, rfl⟩ | rfl | rfl | ⟨p₁, p₂, h₁, h₂, rfl⟩ | + ⟨p₁, p₂, h₁, h₂, rfl⟩ | ⟨p₁, h₁, rfl⟩ | ⟨p₁, h₁, rfl⟩) + · simpa [hR, hv.isUTerm] using hRel n param k R v hR hv + · simpa [hR, hv.isUTerm] using hNRel n param k R v hR hv + · simpa using hverum n param + · simpa using hfalsum n param + · simpa [h₁.isUFormula, h₂.isUFormula] using + hand n param p₁ p₂ h₁ h₂ (ih p₁ (by simp) param (by simp [f]) n (by simp [g]) h₁) + (ih p₂ (by simp) param (by simp [f]) n (by simp [g]) h₂) + · simpa [h₁.isUFormula, h₂.isUFormula] using + hor n param p₁ p₂ h₁ h₂ (ih p₁ (by simp) param (by simp [f]) n (by simp [g]) h₁) + (ih p₂ (by simp) param (by simp [f]) n (by simp [g]) h₂) + · simpa [h₁.isUFormula] using + hall n param p₁ h₁ + (ih p₁ (by simp) (c.allChanges param) (by simp [f]) (n + 1) (by simp [g]) h₁) + · simpa [h₁.isUFormula] using + hexs n param p₁ h₁ + (ih p₁ (by simp) (c.exsChanges param) (by simp [f]) (n + 1) (by simp [g]) h₁) + +end Construction +end UformulaRec1 + +end Bootstrapping +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Formula/Coding.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Formula/Coding.lean new file mode 100644 index 000000000..cc856be12 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Formula/Coding.lean @@ -0,0 +1,524 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Syntax.Classical.PrimrecCoding +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Formula.Typed +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Term.Coding + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +open Encodable FFL FirstOrder Arithmetic Bootstrapping + +namespace FFL + +/-- Data and laws for LCWQIso Gödel Quote in `FFL`. -/ +class LCWQIsoGödelQuote (α β : ℕ → Type*) [LCWQ α] [LCWQ β] where + /-- The gq construction in `FFL.LCWQIsoGödelQuote`. -/ + gq : ∀ n, GödelQuote (α n) (β n) + top : ⌜(⊤ : α n)⌝ = (⊤ : β n) + bot : ⌜(⊥ : α n)⌝ = (⊥ : β n) + and (φ ψ : α n) : (⌜φ ⋏ ψ⌝ : β n) = ⌜φ⌝ ⋏ ⌜ψ⌝ + or (φ ψ : α n) : (⌜φ ⋎ ψ⌝ : β n) = ⌜φ⌝ ⋎ ⌜ψ⌝ + imply (φ ψ : α n) : (⌜φ ⇒ₗ ψ⌝ : β n) = ⌜φ⌝ ⇒ₗ ⌜ψ⌝ + neg (φ : α n) : (⌜∼φ⌝ : β n) = ∼⌜φ⌝ + all (φ : α (n + 1)) : (⌜∀¹ φ⌝ : β n) = ∀¹ ⌜φ⌝ + exs (φ : α (n + 1)) : (⌜∃¹ φ⌝ : β n) = ∃¹ ⌜φ⌝ + +namespace LCWQIsoGödelQuote + +attribute [simp] top bot and or imply neg all exs + +variable {α β : ℕ → Type*} [LCWQ α] [LCWQ β] [LCWQIsoGödelQuote α β] + +instance (n : ℕ) : GödelQuote (α n) (β n) := + gq n + +@[simp] +lemma iff (φ ψ : α n) : (⌜φ ⇔ₗ ψ⌝ : β n) = ⌜φ⌝ ⇔ₗ ⌜ψ⌝ := by simp [LogicalConnective.iff] + +@[simp] +lemma ball (φ : α (n + 1)) (ψ : α (n + 1)) : (⌜∀¹[φ] ψ⌝ : β n) = ∀¹[⌜φ⌝] ⌜ψ⌝ := by + simp [FFL.FirstOrder.ball] + +@[simp] +lemma bexs (φ : α (n + 1)) (ψ : α (n + 1)) : (⌜∃¹[φ] ψ⌝ : β n) = ∃¹[⌜φ⌝] ⌜ψ⌝ := by + simp [FFL.FirstOrder.bexs] + +end LCWQIsoGödelQuote + +end FFL + +namespace FFL + +variable {V : Type*} [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +variable {L : Language} [L.Encodable] [L.LORDefinable] + +namespace FirstOrder +namespace Semiformula + +variable (V) {n : ℕ} + +/-- The typed Quote construction in `FFL.FirstOrder.Semiformula`. -/ +noncomputable def typedQuote {n} : Semiproposition L n → Bootstrapping.Semiformula V L n + | rel R v => Bootstrapping.Semiformula.rel R fun i ↦ ⌜v i⌝ + | nrel R v => Bootstrapping.Semiformula.nrel R fun i ↦ ⌜v i⌝ + | ⊤ => ⊤ + | ⊥ => ⊥ + | φ ⋏ ψ => φ.typedQuote ⋏ ψ.typedQuote + | φ ⋎ ψ => φ.typedQuote ⋎ ψ.typedQuote + | ∀¹ φ => ∀¹ φ.typedQuote + | ∃¹ φ => ∃¹ φ.typedQuote + +variable {V} + +lemma typedQuote_neg {n} (φ : Semiproposition L n) : (∼φ).typedQuote V = ∼(φ.typedQuote V) := by + match φ with + | rel R v => simp [typedQuote] + | nrel R v => simp [typedQuote] + | ⊤ => simp [typedQuote] + | ⊥ => simp [typedQuote] + | φ ⋏ ψ => simp [typedQuote, typedQuote_neg φ, typedQuote_neg ψ] + | φ ⋎ ψ => simp [typedQuote, typedQuote_neg φ, typedQuote_neg ψ] + | ∀¹ φ => simp [typedQuote, typedQuote_neg φ] + | ∃¹ φ => simp [typedQuote, typedQuote_neg φ] + +noncomputable instance : LCWQIsoGödelQuote (Semiproposition L) (Bootstrapping.Semiformula V L) + where + gq _ := ⟨typedQuote V⟩ + top := rfl + bot := rfl + and _ _ := rfl + or _ _ := rfl + neg _ := by simpa [typedQuote] using! typedQuote_neg _ + imply _ + _ := by + simpa [Bootstrapping.Semiformula.imp_def, imp_eq, typedQuote] using! typedQuote_neg _ + all _ := rfl + exs _ := rfl + +@[simp] +lemma typed_quote_rel (R : L.Rel k) (v : Fin k → SyntacticSemiterm L n) : + (⌜rel R v⌝ : Bootstrapping.Semiformula V L n) = + Bootstrapping.Semiformula.rel R fun i ↦ ⌜v i⌝ := + rfl + +@[simp] +lemma typed_quote_nrel (R : L.Rel k) (v : Fin k → SyntacticSemiterm L n) : + (⌜nrel R v⌝ : Bootstrapping.Semiformula V L n) = + Bootstrapping.Semiformula.nrel R fun i ↦ ⌜v i⌝ := + rfl + +@[simp] +lemma typed_quote_shift (φ : Semiproposition L n) : + (⌜Rewriting.shift φ⌝ : Bootstrapping.Semiformula V L n) = + Bootstrapping.Semiformula.shift ⌜φ⌝ := + by + induction φ using Semiformula.rec' + case hrel => simp [*]; rfl + case hnrel => simp [*]; rfl + case hverum => simp + case hfalsum => simp + case hand => simp [*] + case hor => simp [*] + case hall φ ih => simp [*] + case hexs φ ih => simp [*] + +@[simp] +lemma typed_quote_substs {n m} (w : Fin n → SyntacticSemiterm L m) (φ : Semiproposition L n) : + (⌜φ ↜ w⌝ : Bootstrapping.Semiformula V L m) = + Bootstrapping.Semiformula.subst (fun i ↦ ⌜w i⌝) ⌜φ⌝ := + by + induction φ using Semiformula.rec' generalizing m + case hrel => simp [*]; rfl + case hnrel => simp [*]; rfl + case hverum => simp + case hfalsum => simp + case hand => simp [*] + case hor => simp [*] + case hall φ ih => simp [*, Rew.q_subst, Matrix.comp_vecCons']; rfl + case hexs φ ih => simp [*, Rew.q_subst, Matrix.comp_vecCons']; rfl + +@[simp] +lemma free_quote (φ : Semiproposition L 1) : + (⌜Rewriting.free φ⌝ : Bootstrapping.Formula V L) = Bootstrapping.Semiformula.free ⌜φ⌝ := + by + rw [← LawfulSyntacticRewriting.app_subst_fbar_zero_comp_shift_eq_free, typed_quote_substs, + typed_quote_shift] + simp [Bootstrapping.Semiformula.free, Matrix.constant_eq_singleton] + +open Bootstrapping.ObjectArithmetic + +@[simp] +lemma typed_quote_eq (t u : SyntacticSemiterm ℒₒᵣ n) : + (⌜(“!!t = !!u” : ArithmeticSemiproposition n)⌝ : Bootstrapping.Semiformula V ℒₒᵣ n) = + (⌜t⌝ ≐ ⌜u⌝) := + rfl + +@[simp] +lemma typed_quote_ne (t u : SyntacticSemiterm ℒₒᵣ n) : + (⌜(“!!t ≠ !!u” : ArithmeticSemiproposition n)⌝ : Bootstrapping.Semiformula V ℒₒᵣ n) = + (⌜t⌝ ≉ ⌜u⌝) := + rfl + +@[simp] +lemma typed_quote_lt (t u : SyntacticSemiterm ℒₒᵣ n) : + (⌜(“!!t < !!u” : ArithmeticSemiproposition n)⌝ : Bootstrapping.Semiformula V ℒₒᵣ n) = + (⌜t⌝ <' ⌜u⌝) := + rfl + +@[simp] +lemma typed_quote_nlt (t u : SyntacticSemiterm ℒₒᵣ n) : + (⌜(“!!t ≮ !!u” : ArithmeticSemiproposition n)⌝ : Bootstrapping.Semiformula V ℒₒᵣ n) = + (⌜t⌝ ≮' ⌜u⌝) := + rfl + +lemma ne_iff_val_ne (φ ψ : Bootstrapping.Semiformula V L n) : φ ≠ ψ ↔ φ.val ≠ ψ.val := + Iff.ne Semiformula.ext_iff + +lemma typed_quote_inj {n} {φ₁ φ₂ : Semiproposition L n} : + (⌜φ₁⌝ : Bootstrapping.Semiformula V L n) = ⌜φ₂⌝ → φ₁ = φ₂ := + match φ₁, φ₂ with + | rel R₁ v₁, rel R₂ v₂ => + by + simp only [typed_quote_rel, Bootstrapping.Semiformula.rel, Semiformula.mk.injEq, qqRel_inj, + Nat.cast_inj, rel.injEq, and_imp] + rintro rfl + simp only [quote_rel_inj, heq_eq_eq, true_and] + rintro rfl + suffices ((fun i ↦ ⌜v₁ i⌝) = fun i ↦ ⌜v₂ i⌝) → v₁ = v₂ by simpa [← SemitermVec.val_inj] + intro h + ext i + exact Semiterm.typed_quote_inj (congr_fun h i) + | nrel R₁ v₁, nrel R₂ v₂ => + by + simp only [typed_quote_nrel, Bootstrapping.Semiformula.nrel, Semiformula.mk.injEq, + qqNRel_inj, Nat.cast_inj, nrel.injEq, and_imp] + rintro rfl + simp only [quote_rel_inj, heq_eq_eq, true_and] + rintro rfl + suffices ((fun i ↦ ⌜v₁ i⌝) = fun i ↦ ⌜v₂ i⌝) → v₁ = v₂ by simpa [← SemitermVec.val_inj] + intro h + ext i + exact Semiterm.typed_quote_inj (congr_fun h i) + | ⊤, ⊤ => by simp + | ⊥, ⊥ => by simp + | φ₁ ⋏ ψ₁, φ₂ ⋏ ψ₂ => + by + simp only [LCWQIsoGödelQuote.and, Bootstrapping.Semiformula.and_inj, and_inj, and_imp] + intro hφ hψ + refine ⟨typed_quote_inj hφ, typed_quote_inj hψ⟩ + | φ₁ ⋎ ψ₁, φ₂ ⋎ ψ₂ => + by + simp only [LCWQIsoGödelQuote.or, Bootstrapping.Semiformula.or_inj, or_inj, and_imp] + intro hφ hψ + refine ⟨typed_quote_inj hφ, typed_quote_inj hψ⟩ + | ∀¹ φ₁, ∀¹ φ₂ => + by + simp only [LCWQIsoGödelQuote.all, Bootstrapping.Semiformula.all_inj, all_inj] + exact typed_quote_inj + | ∃¹ φ₁, ∃¹ φ₂ => + by + simp only [LCWQIsoGödelQuote.exs, Bootstrapping.Semiformula.exs_inj, exs_inj] + exact typed_quote_inj + | rel _ _, nrel _ _ | rel _ _, ⊤ | rel _ _, ⊥ | rel _ _, _ ⋏ _ | rel _ _, _ ⋎ _ | rel _ _, + ∀¹ _ | rel _ _, ∃¹ _ | nrel _ _, rel _ _ | nrel _ _, ⊤ | nrel _ _, ⊥ | nrel _ _, _ ⋏ _ | + nrel _ _, _ ⋎ _ | nrel _ _, ∀¹ _ | nrel _ _, ∃¹ _ | ⊤, rel _ _ | ⊤, nrel _ _ | ⊤, ⊥ | ⊤, + _ ⋏ _ | ⊤, _ ⋎ _ | ⊤, ∀¹ _ | ⊤, ∃¹ _ | ⊥, rel _ _ | ⊥, nrel _ _ | ⊥, ⊤ | ⊥, _ ⋏ _ | ⊥, + _ ⋎ _ | ⊥, ∀¹ _ | ⊥, ∃¹ _ | _ ⋏ _, rel _ _ | _ ⋏ _, nrel _ _ | _ ⋏ _, ⊤ | _ ⋏ _, ⊥ | _ ⋏ _, + _ ⋎ _ | _ ⋏ _, ∀¹ _ | _ ⋏ _, ∃¹ _ | _ ⋎ _, rel _ _ | _ ⋎ _, nrel _ _ | _ ⋎ _, ⊤ | _ ⋎ _, ⊥ | + _ ⋎ _, _ ⋏ _ | _ ⋎ _, ∀¹ _ | _ ⋎ _, ∃¹ _ | ∀¹ _, rel _ _ | ∀¹ _, nrel _ _ | ∀¹ _, ⊤ | ∀¹ _, + ⊥ | ∀¹ _, _ ⋏ _ | ∀¹ _, _ ⋎ _ | ∀¹ _, ∃¹ _ | ∃¹ _, rel _ _ | ∃¹ _, nrel _ _ | ∃¹ _, ⊤ | + ∃¹ _, ⊥ | ∃¹ _, _ ⋏ _ | ∃¹ _, _ ⋎ _ | ∃¹ _, ∀¹ _ => by + simp [ne_iff_val_ne, qqRel, qqNRel, qqVerum, qqFalsum, qqAnd, qqOr, qqAll, qqExs] + +@[simp] +lemma typed_quote_inj_iff {φ₁ φ₂ : Semiproposition L n} : + (⌜φ₁⌝ : Bootstrapping.Semiformula V L n) = ⌜φ₂⌝ ↔ φ₁ = φ₂ := + ⟨typed_quote_inj, by rintro rfl; rfl⟩ + +noncomputable instance : GödelQuote (Semiproposition L n) V where + quote φ := (⌜φ⌝ : Bootstrapping.Semiformula V L n).val + +lemma quote_def (φ : Semiproposition L n) : + (⌜φ⌝ : V) = (⌜φ⌝ : Bootstrapping.Semiformula V L n).val := + rfl + +@[simp] +lemma quote_isSemiformula (φ : Semiproposition L n) : IsSemiformula L ↑n (⌜φ⌝ : V) := by + simp [quote_def] + +@[simp] +lemma quote_isSemiformula₀ (φ : Proposition L) : IsSemiformula L 0 (⌜φ⌝ : V) := by + simp [quote_def] + +@[simp] +lemma quote_isSemiformul₁ (φ : Semiproposition L 1) : IsSemiformula L 1 (⌜φ⌝ : V) := by + simp [quote_def] + +@[simp] +lemma quote_rel (R : L.Rel k) (v : Fin k → SyntacticSemiterm L n) : + (⌜rel R v⌝ : V) = + ^rel ↑k ⌜R⌝ (SemitermVec.val fun i ↦ (⌜v i⌝ : Bootstrapping.Semiterm V L n)) := + rfl + +@[simp] +lemma quote_nrel (R : L.Rel k) (v : Fin k → SyntacticSemiterm L n) : + (⌜nrel R v⌝ : V) = + ^nrel ↑k ⌜R⌝ (SemitermVec.val fun i ↦ (⌜v i⌝ : Bootstrapping.Semiterm V L n)) := + rfl + +@[simp] +lemma quote_verum : (⌜(⊤ : Semiproposition L n)⌝ : V) = ^⊤ := + rfl + +@[simp] +lemma quote_falsum : (⌜(⊥ : Semiproposition L n)⌝ : V) = ^⊥ := + rfl + +@[simp] +lemma quote_and (φ ψ : Semiproposition L n) : (⌜φ ⋏ ψ⌝ : V) = ⌜φ⌝ ^⋏ ⌜ψ⌝ := + rfl + +@[simp] +lemma quote_or (φ ψ : Semiproposition L n) : (⌜φ ⋎ ψ⌝ : V) = ⌜φ⌝ ^⋎ ⌜ψ⌝ := + rfl + +@[simp] +lemma quote_all (φ : Semiproposition L (n + 1)) : (⌜∀¹ φ⌝ : V) = ^∀ ⌜φ⌝ := + rfl + +@[simp] +lemma quote_ex (φ : Semiproposition L (n + 1)) : (⌜∃¹ φ⌝ : V) = ^∃ ⌜φ⌝ := + rfl + +lemma quote_shift (φ : Semiproposition L n) : + (⌜Rewriting.shift φ⌝ : V) = Bootstrapping.shift L ⌜φ⌝ := by simp [quote_def] + +lemma quote_eq_encode (φ : Semiproposition L n) : (⌜φ⌝ : V) = ↑(encode φ) := + by + suffices (⌜φ⌝ : Bootstrapping.Semiformula V L n).val = ↑(encode φ) from this + induction φ using rec' + case hrel => simp [encode_rel, qqRel, coe_pair_eq_pair_coe, Semiterm.quote_eq_encode']; rfl + case hnrel => simp [encode_nrel, qqNRel, coe_pair_eq_pair_coe, Semiterm.quote_eq_encode']; rfl + case hverum => simp [encode_verum, qqVerum, coe_pair_eq_pair_coe] + case hfalsum => simp [encode_falsum, qqFalsum, coe_pair_eq_pair_coe] + case hand => simp [encode_and, qqAnd, coe_pair_eq_pair_coe, *]; simp [encode_eq_toNat] + case hor => simp [encode_or, qqOr, coe_pair_eq_pair_coe, *]; simp [encode_eq_toNat] + case hall => simp [encode_all, qqAll, coe_pair_eq_pair_coe, *]; simp [encode_eq_toNat] + case hexs => simp [encode_ex, qqExs, coe_pair_eq_pair_coe, *]; simp [encode_eq_toNat] + +lemma coe_quote_eq_quote (φ : Semiproposition L n) : (↑(⌜φ⌝ : ℕ) : V) = ⌜φ⌝ := by + simp [quote_eq_encode] + +lemma coe_quote_eq_quote' (φ : Semiproposition L n) : + (↑(⌜φ⌝ : Bootstrapping.Semiformula ℕ L n).val : V) = + (⌜φ⌝ : Bootstrapping.Semiformula V L n).val := + coe_quote_eq_quote φ + +lemma quote_eq_encode_nat (φ : Semiproposition L n) : (⌜φ⌝ : ℕ) = encode φ := by + simpa using quote_eq_encode (V := ℕ) φ + +lemma primrec_quote_natCast [L.Primcodable] : Primrec fun φ : Semiproposition L n ↦ (⌜φ⌝ : ℕ) := + Primrec.encode.of_eq fun φ ↦ (quote_eq_encode_nat φ).symm + +@[simp] +lemma quote_inj_iff {φ₁ φ₂ : Semiproposition L n} : (⌜φ₁⌝ : V) = ⌜φ₂⌝ ↔ φ₁ = φ₂ := by + simp [quote_eq_encode] + +noncomputable instance : LCWQIsoGödelQuote (Semisentence L) (Bootstrapping.Semiformula V L) + where + gq n := ⟨fun σ ↦ (⌜(Rewriting.emb σ : Semiproposition L n)⌝)⟩ + top := by simp + bot := by simp + and _ _ := by simp + or _ _ := by simp + neg _ := by simp + imply _ _ := by simp + all _ := by simp + exs _ := by simp + +@[simp] +lemma coe_quote {ξ n} (φ : Semiproposition L n) : ↑(⌜φ⌝ : ℕ) = (⌜φ⌝ : ArithmeticSemiterm ξ m) := + by simp [gödelNumber'_def, Semiformula.quote_eq_encode] + +@[simp] +lemma quote_quote_eq_numeral (φ : Semiproposition L n) : + (⌜(⌜φ⌝ : ArithmeticSemiterm ℕ m)⌝ : Bootstrapping.Semiterm V ℒₒᵣ m) = + Bootstrapping.ObjectArithmetic.typedNumeral ⌜φ⌝ := + by simp [← coe_quote, coe_quote_eq_quote] + +end Semiformula + +namespace Sentence + +theorem typed_quote_def (σ : Semisentence L n) : + (⌜σ⌝ : Bootstrapping.Semiformula V L n) = ⌜(Rewriting.emb σ : Semiproposition L n)⌝ := + rfl + +@[simp] +lemma typed_quote_eq (t u : ClosedSemiterm ℒₒᵣ n) : + (⌜(“!!t = !!u” : ArithmeticSemisentence n)⌝ : Bootstrapping.Semiformula V ℒₒᵣ n) = + (⌜t⌝ ≐ ⌜u⌝) := + rfl + +@[simp] +lemma typed_quote_ne (t u : ClosedSemiterm ℒₒᵣ n) : + (⌜(“!!t ≠ !!u” : ArithmeticSemisentence n)⌝ : Bootstrapping.Semiformula V ℒₒᵣ n) = + (⌜t⌝ ≉ ⌜u⌝) := + rfl + +@[simp] +lemma typed_quote_lt (t u : ClosedSemiterm ℒₒᵣ n) : + (⌜(“!!t < !!u” : ArithmeticSemisentence n)⌝ : Bootstrapping.Semiformula V ℒₒᵣ n) = + (⌜t⌝ <' ⌜u⌝) := + rfl + +@[simp] +lemma typed_quote_nlt (t u : ClosedSemiterm ℒₒᵣ n) : + (⌜(“!!t ≮ !!u” : ArithmeticSemisentence n)⌝ : Bootstrapping.Semiformula V ℒₒᵣ n) = + (⌜t⌝ ≮' ⌜u⌝) := + rfl + +noncomputable instance : GödelQuote (Semisentence L n) V where + quote σ := ⌜(Rewriting.emb σ : Semiproposition L n)⌝ + +lemma quote_def (σ : Semisentence L n) : + (⌜σ⌝ : V) = ⌜(Rewriting.emb σ : Semiproposition L n)⌝ := + rfl + +theorem quote_eq (σ : Semisentence L n) : + (⌜σ⌝ : V) = (⌜σ⌝ : Bootstrapping.Semiformula V L n).val := + rfl + +@[simp] +lemma quote_isSemiformula (φ : Semisentence L n) : IsSemiformula L ↑n (⌜φ⌝ : V) := by + simp [quote_def] + +@[simp] +lemma quote_isSemiformula₀ (φ : Sentence L) : IsSemiformula L 0 (⌜φ⌝ : V) := by simp [quote_def] + +@[simp] +lemma quote_isSemiformul₁ (φ : Semisentence L 1) : IsSemiformula L 1 (⌜φ⌝ : V) := by + simp [quote_def] + +lemma quote_eq_encode (σ : Semisentence L n) : (⌜σ⌝ : V) = ↑(encode σ) := by + simp [quote_def, Semiformula.quote_eq_encode] + +lemma coe_quote_eq_quote (σ : Semisentence L n) : (↑(⌜σ⌝ : ℕ) : V) = ⌜σ⌝ := by + simp [quote_eq_encode] + +lemma quote_eq_encode_nat (σ : Semisentence L n) : (⌜σ⌝ : ℕ) = encode σ := by + simpa using quote_eq_encode (V := ℕ) σ + +lemma primrec_quote_natCast [L.Primcodable] : Primrec fun σ : Semisentence L n ↦ (⌜σ⌝ : ℕ) := + Primrec.encode.of_eq fun σ ↦ (quote_eq_encode_nat σ).symm + +@[simp] +lemma val_quote {bv : Fin m → V} {fv : ξ → V} (σ : Semisentence L n) : + (⌜σ⌝ : ArithmeticSemiterm ξ m).val bv fv = ⌜σ⌝ := by + simp [gödelNumber'_def, quote_eq_encode, numeral_eq_natCast] + +@[simp] +lemma coe_quote {ξ n} (σ : Semisentence L n) : ↑(⌜σ⌝ : ℕ) = (⌜σ⌝ : ArithmeticSemiterm ξ m) := by + simp [gödelNumber'_def, quote_eq_encode] + +@[simp] +lemma quote_quote_eq_numeral (σ : Semisentence L n) : + (⌜(⌜σ⌝ : ArithmeticSemiterm ℕ m)⌝ : Bootstrapping.Semiterm V ℒₒᵣ m) = + Bootstrapping.ObjectArithmetic.typedNumeral ⌜σ⌝ := + by simp [← coe_quote, coe_quote_eq_quote] + +@[simp] +lemma quote_inj_iff {σ₁ σ₂ : Semisentence L n} : (⌜σ₁⌝ : V) = ⌜σ₂⌝ ↔ σ₁ = σ₂ := by + simp [quote_eq_encode] + +end Sentence + +end FirstOrder + +namespace FirstOrder +namespace Arithmetic +namespace Bootstrapping + +open Encodable FirstOrder + +lemma IsSemiformula.sound {n φ : ℕ} (h : IsSemiformula L n φ) : + ∃ F : FirstOrder.Semiproposition L n, ⌜F⌝ = φ := + by + induction φ using Nat.strongRec generalizing n + case ind φ + ih => + rcases IsSemiformula.case_iff.mp h with + (⟨k, r, v, hr, hv, rfl⟩ | ⟨k, r, v, hr, hv, rfl⟩ | rfl | rfl | ⟨φ, ψ, hp, hq, rfl⟩ | + ⟨φ, ψ, hp, hq, rfl⟩ | ⟨φ, hp, rfl⟩ | ⟨φ, hp, rfl⟩) + · have : ∀ i : Fin k, ∃ t : FirstOrder.SyntacticSemiterm L n, ⌜t⌝ = v.[i] := fun i ↦ + (hv.nth i.prop).sound + choose v' hv' using this + have : ∃ R, encode R = r := + isRel_quote_quote (V := ℕ) (L := L) (x := r) (k := k) |>.mp (by simp [hr]) + rcases this with ⟨R, rfl⟩ + refine ⟨FirstOrder.Semiformula.rel R v', ?_⟩ + suffices SemitermVec.val (fun i ↦ ⌜v' i⌝) = v by + simpa [Semiformula.quote_rel, quote_rel_def] + apply nth_ext' k (by simp) (by simp [hv.lh]) + intro i hik + let j : Fin k := ⟨i, hik⟩ + calc + (SemitermVec.val fun i ↦ ⌜v' i⌝).[i] = (SemitermVec.val fun i ↦ ⌜v' i⌝).[↑j] := rfl + _ = ⌜v' j⌝ := by + simpa [Semiterm.quote_def] using + SemitermVec.val_nth_eq (fun i ↦ (⌜v' i⌝ : Bootstrapping.Semiterm ℕ L n)) j + _ = v.[i] := hv' j + · have : ∀ i : Fin k, ∃ t : FirstOrder.SyntacticSemiterm L n, ⌜t⌝ = v.[i] := fun i ↦ + (hv.nth i.prop).sound + choose v' hv' using this + have : ∃ R, encode R = r := + isRel_quote_quote (V := ℕ) (L := L) (x := r) (k := k) |>.mp (by simp [hr]) + rcases this with ⟨R, rfl⟩ + refine ⟨FirstOrder.Semiformula.nrel R v', ?_⟩ + suffices SemitermVec.val (fun i ↦ ⌜v' i⌝) = v by + simpa [Semiformula.quote_nrel, quote_rel_def] + apply nth_ext' k (by simp) (by simp [hv.lh]) + intro i hik + let j : Fin k := ⟨i, hik⟩ + calc + (SemitermVec.val fun i ↦ ⌜v' i⌝).[i] = (SemitermVec.val fun i ↦ ⌜v' i⌝).[↑j] := rfl + _ = ⌜v' j⌝ := by + simpa [Semiterm.quote_def] using + SemitermVec.val_nth_eq (fun i ↦ (⌜v' i⌝ : Bootstrapping.Semiterm ℕ L n)) j + _ = v.[i] := hv' j + · exact ⟨⊤, by simp⟩ + · exact ⟨⊥, by simp⟩ + · rcases ih φ (by simp) hp with ⟨φ, rfl⟩ + rcases ih ψ (by simp) hq with ⟨ψ, rfl⟩ + exact ⟨φ ⋏ ψ, by simp⟩ + · rcases ih φ (by simp) hp with ⟨φ, rfl⟩ + rcases ih ψ (by simp) hq with ⟨ψ, rfl⟩ + exact ⟨φ ⋎ ψ, by simp⟩ + · rcases ih φ (by simp) hp with ⟨φ, rfl⟩ + exact ⟨∀¹ φ, by simp⟩ + · rcases ih φ (by simp) hp with ⟨φ, rfl⟩ + exact ⟨∃¹ φ, by simp⟩ + +end Bootstrapping +end Arithmetic +end FirstOrder + +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Formula/Functions.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Formula/Functions.lean new file mode 100644 index 000000000..b551cbb4a --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Formula/Functions.lean @@ -0,0 +1,1527 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Formula.Basic +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Term.Functions + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace FFL +namespace FirstOrder +namespace Arithmetic +namespace Bootstrapping + +variable {V : Type*} [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +variable {L : Language} [L.Encodable] [L.LORDefinable] + +/-! +### Negation function -/ + +section negation + +namespace Negation + +/-- The blueprint construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.Negation`. -/ +def blueprint : UformulaRec1.Blueprint + where + rel := .mkSigma (“y param k R v. !qqNRelDef y k R v”) + nrel := .mkSigma (“y param k R v. !qqRelDef y k R v”) + verum := .mkSigma (“y param. !qqFalsumDef y”) + falsum := .mkSigma (“y param. !qqVerumDef y”) + and := .mkSigma (“y param p₁ p₂ y₁ y₂. !qqOrDef y y₁ y₂”) + or := .mkSigma (“y param p₁ p₂ y₁ y₂. !qqAndDef y y₁ y₂”) + all := .mkSigma (“y param p₁ y₁. !qqExsDef y y₁”) + exs := .mkSigma (“y param p₁ y₁. !qqAllDef y y₁”) + allChanges := .mkSigma (“param' param. param' = 0”) + exsChanges := .mkSigma (“param' param. param' = 0”) + +/-- The construction construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.Negation`. -/ +noncomputable def construction : UformulaRec1.Construction V blueprint + where + rel {_} := fun k R v ↦ ^nrel k R v + nrel {_} := fun k R v ↦ ^rel k R v + verum {_} := ^⊥ + falsum {_} := ^⊤ + and {_} := fun _ _ y₁ y₂ ↦ y₁ ^⋎ y₂ + or {_} := fun _ _ y₁ y₂ ↦ y₁ ^⋏ y₂ + all {_} := fun _ y₁ ↦ ^∃ y₁ + exs {_} := fun _ y₁ ↦ ^∀ y₁ + allChanges := fun _ ↦ 0 + exsChanges := fun _ ↦ 0 + rel_defined := .mk fun v ↦ by simp [blueprint] + nrel_defined := .mk fun v ↦ by simp [blueprint] + verum_defined := .mk fun v ↦ by simp [blueprint] + falsum_defined := .mk fun v ↦ by simp [blueprint] + and_defined := .mk fun v ↦ by simp [blueprint] + or_defined := .mk fun v ↦ by simp [blueprint] + all_defined := .mk fun v ↦ by simp [blueprint] + exs_defined := .mk fun v ↦ by simp [blueprint] + allChanges_defined := .mk fun v ↦ by simp [blueprint] + exChanges_defined := .mk fun v ↦ by simp [blueprint] + +end Negation + +open Negation + +variable (L) + +/-- The neg construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def neg (p : V) : V := + construction.result L 0 p + +/-- The neg Graph construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def negGraph : Σ₁.Semisentence 2 := + (blueprint.result L).rew (Rew.subst ![#0, ‘0’, #1]) + +variable {L} + +section + +instance neg.defined : Σ₁-Function₁ neg (V := V) L via negGraph L := + .mk fun v ↦ by + simpa [negGraph, Matrix.comp_vecCons', Matrix.constant_eq_singleton] using! + construction.result_defined.defined ![v 0, 0, v 1] + +instance neg.definable : Σ₁-Function₁ neg (V := V) L := + neg.defined.to_definable + +instance neg.definable' : Γ-[m + 1]-Function₁ neg (V := V) L := + .of_sigmaOne neg.definable + +end + +@[simp] +lemma neg_rel {k R v : V} (hR : L.IsRel k R) (hv : IsUTermVec L k v) : + neg L (^rel k R v) = ^nrel k R v := by simp [neg, hR, hv, construction] + +@[simp] +lemma neg_nrel {k R v : V} (hR : L.IsRel k R) (hv : IsUTermVec L k v) : + neg L (^nrel k R v) = ^rel k R v := by simp [neg, hR, hv, construction] + +@[simp] +lemma neg_verum : neg L (^⊤ : V) = ^⊥ := by simp [neg, construction] + +@[simp] +lemma neg_falsum : neg L (^⊥ : V) = ^⊤ := by simp [neg, construction] + +@[simp] +lemma neg_and {p q : V} (hp : IsUFormula L p) (hq : IsUFormula L q) : + neg L (p ^⋏ q) = neg L p ^⋎ neg L q := by simp [neg, hp, hq, construction] + +@[simp] +lemma neg_or {p q : V} (hp : IsUFormula L p) (hq : IsUFormula L q) : + neg L (p ^⋎ q) = neg L p ^⋏ neg L q := by simp [neg, hp, hq, construction] + +@[simp] +lemma neg_all {p : V} (hp : IsUFormula L p) : neg L (^∀ p) = ^∃ (neg L p) := by + simp [neg, hp, construction] + +@[simp] +lemma neg_ex {p : V} (hp : IsUFormula L p) : neg L (^∃ p) = ^∀ (neg L p) := by + simp [neg, hp, construction] + +lemma neg_not_uformula {x : V} (h : ¬IsUFormula L x) : neg L x = 0 := + construction.result_prop_not _ h + +lemma IsUFormula.neg {p : V} : IsUFormula L p → IsUFormula L (neg L p) := + by + apply IsUFormula.ISigma1.sigma1_succ_induction + · definability + · intro k r v hr hv; simp [hr, hv] + · intro k r v hr hv; simp [hr, hv] + · simp + · simp + · intro p q hp hq ihp ihq; simp [hp, hq, ihp, ihq] + · intro p q hp hq ihp ihq; simp [hp, hq, ihp, ihq] + · intro p hp ihp; simp [hp, ihp] + · intro p hp ihp; simp [hp, ihp] + +@[simp] +lemma IsUFormula.bv_neg {p : V} : IsUFormula L p → bv L (Bootstrapping.neg L p) = bv L p := + by + apply IsUFormula.ISigma1.sigma1_succ_induction + · definability + · intro k R v hR hv; simp [*] + · intro k R v hR hv; simp [*] + · simp + · simp + · intro p q hp hq ihp ihq; simp [hp, hq, hp.neg, hq.neg, ihp, ihq] + · intro p q hp hq ihp ihq; simp [hp, hq, hp.neg, hq.neg, ihp, ihq] + · intro p hp ihp; simp [hp, hp.neg, ihp] + · intro p hp ihp; simp [hp, hp.neg, ihp] + +@[simp] +lemma IsUFormula.neg_neg {p : V} : + IsUFormula L p → Bootstrapping.neg L (Bootstrapping.neg L p) = p := + by + apply IsUFormula.ISigma1.sigma1_succ_induction + · definability + · intro k r v hr hv; simp [hr, hv] + · intro k r v hr hv; simp [hr, hv] + · simp + · simp + · intro p q hp hq ihp ihq; simp [hp, hq, hp.neg, hq.neg, ihp, ihq] + · intro p q hp hq ihp ihq; simp [hp, hq, hp.neg, hq.neg, ihp, ihq] + · intro p hp ihp; simp [hp, hp.neg, ihp] + · intro p hp ihp; simp [hp, hp.neg, ihp] + +@[simp] +lemma IsUFormula.neg_iff {p : V} : IsUFormula L (Bootstrapping.neg L p) ↔ IsUFormula L p := + by + constructor + · intro h; by_contra hp + have Hp : IsUFormula L p := by by_contra hp; simp [neg_not_uformula hp] at h + contradiction + · exact IsUFormula.neg + +@[simp] +lemma IsSemiformula.neg_iff {p : V} : IsSemiformula L n (neg L p) ↔ IsSemiformula L n p := + by + constructor + · intro h; by_contra hp + have Hp : IsUFormula L p := by by_contra hp; simp [neg_not_uformula hp] at h + have : IsSemiformula L n p := ⟨Hp, by simpa [Hp.bv_neg] using h.bv_le⟩ + contradiction + · intro h; exact ⟨by simp [h.isUFormula], by simpa [h.isUFormula] using h.bv_le⟩ + +alias ⟨IsSemiformula.elim_neg, IsSemiformula.neg⟩ := IsSemiformula.neg_iff + +@[simp] +lemma neg_inj_iff {p q : V} (hp : IsUFormula L p) (hq : IsUFormula L q) : + neg L p = neg L q ↔ p = q := by + constructor + · intro h; simpa [hp.neg_neg, hq.neg_neg] using congrArg (neg L) h + · rintro rfl; rfl + +end negation + +variable (L) + +/-- The imp construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def imp (p q : V) : V := + neg L p ^⋎ q + +/-- The «term ^→[ ] » construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +notation:60 p:61 " ^→[" L "] " q:60 => Language.imp L p q + +/-- The imp Graph construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def impGraph : Σ₁.Semisentence 3 := + .mkSigma (“r p q. ∃ np, !(negGraph L)np p ∧ !qqOrDef r np q”) + +/-- The iff construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def iff (p q : V) : V := + (imp L p q) ^⋏ (imp L q p) + +/-- The iff Graph construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def iffGraph : Σ₁.Semisentence 3 := + .mkSigma (“r p q. ∃ pq, !(impGraph L)pq p q ∧ ∃ qp, !(impGraph L)qp q p ∧ !qqAndDef r pq qp”) + +variable {L} + +section imp + +@[simp] +lemma IsUFormula.imp {p q : V} : IsUFormula L (imp L p q) ↔ IsUFormula L p ∧ IsUFormula L q := + by simp [Bootstrapping.imp] + +@[simp] +lemma IsSemiformula.imp {n p q : V} : + IsSemiformula L n (imp L p q) ↔ IsSemiformula L n p ∧ IsSemiformula L n q := by + simp [Bootstrapping.imp] + +section + +instance imp.defined : Σ₁-Function₂ imp (V := V) L via impGraph L := + .mk fun v ↦ by simp [impGraph]; rfl + +instance imp.definable : Σ₁-Function₂ imp (V := V) L := + imp.defined.to_definable + +instance imp.definable' : Γ-[m + 1]-Function₂ imp (V := V) L := + imp.definable.of_sigmaOne + +end + +end imp + +section iff + +@[simp] +lemma IsUFormula.iff {p q : V} : IsUFormula L (iff L p q) ↔ IsUFormula L p ∧ IsUFormula L q := + by + simp only [Bootstrapping.iff, and, imp, and_iff_left_iff_imp, and_imp] + intros; simp_all + +@[simp] +lemma IsSemiformula.iff {n p q : V} : + IsSemiformula L n (iff L p q) ↔ IsSemiformula L n p ∧ IsSemiformula L n q := + by + simp only [Bootstrapping.iff, and, imp, and_iff_left_iff_imp, and_imp] + intros; simp_all + +@[simp] +lemma lt_iff_left (p q : V) : p < iff L p q := + lt_trans (lt_or_right _ _) (lt_KProof_right _ _) + +@[simp] +lemma lt_iff_right (p q : V) : q < iff L p q := + lt_trans (lt_or_right _ _) (lt_KProof_left _ _) + +section + +instance iff.defined : Σ₁-Function₂ iff (V := V) L via iffGraph L := + .mk fun v ↦ by simp [iffGraph]; rfl + +instance iff.definable : Σ₁-Function₂ iff (V := V) L := + iff.defined.to_definable + +instance iff_definable' : Γ-[m + 1]-Function₂ iff (V := V) L := + iff.definable.of_sigmaOne + +end + +end iff + +/-! +### Shift function -/ + +section shift + +namespace Shift + +variable (L) + +/-- The blueprint construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.Shift`. -/ +noncomputable def blueprint : UformulaRec1.Blueprint + where + rel := .mkSigma (“y param k R v. ∃ v', !(termShiftVecGraph L)v' k v ∧ !qqRelDef y k R v'”) + nrel := .mkSigma (“y param k R v. ∃ v', !(termShiftVecGraph L)v' k v ∧ !qqNRelDef y k R v'”) + verum := .mkSigma (“y param. !qqVerumDef y”) + falsum := .mkSigma (“y param. !qqFalsumDef y”) + and := .mkSigma (“y param p₁ p₂ y₁ y₂. !qqAndDef y y₁ y₂”) + or := .mkSigma (“y param p₁ p₂ y₁ y₂. !qqOrDef y y₁ y₂”) + all := .mkSigma (“y param p₁ y₁. !qqAllDef y y₁”) + exs := .mkSigma (“y param p₁ y₁. !qqExsDef y y₁”) + allChanges := .mkSigma (“param' param. param' = 0”) + exsChanges := .mkSigma (“param' param. param' = 0”) + +/-- The construction construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.Shift`. -/ +noncomputable def construction : UformulaRec1.Construction V (blueprint L) + where + rel {_} := fun k R v ↦ ^rel k R (termShiftVec L k v) + nrel {_} := fun k R v ↦ ^nrel k R (termShiftVec L k v) + verum {_} := ^⊤ + falsum {_} := ^⊥ + and {_} := fun _ _ y₁ y₂ ↦ y₁ ^⋏ y₂ + or {_} := fun _ _ y₁ y₂ ↦ y₁ ^⋎ y₂ + all {_} := fun _ y₁ ↦ ^∀ y₁ + exs {_} := fun _ y₁ ↦ ^∃ y₁ + allChanges := fun _ ↦ 0 + exsChanges := fun _ ↦ 0 + rel_defined := .mk fun v ↦ by simp [blueprint] + nrel_defined := .mk fun v ↦ by simp [blueprint] + verum_defined := .mk fun v ↦ by simp [blueprint] + falsum_defined := .mk fun v ↦ by simp [blueprint] + and_defined := .mk fun v ↦ by simp [blueprint] + or_defined := .mk fun v ↦ by simp [blueprint] + all_defined := .mk fun v ↦ by simp [blueprint] + exs_defined := .mk fun v ↦ by simp [blueprint] + allChanges_defined := .mk fun v ↦ by simp [blueprint] + exChanges_defined := .mk fun v ↦ by simp [blueprint] + +end Shift + +open Shift + +variable (L) + +/-- The shift construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def shift (p : V) : V := + (construction L).result L 0 p + +/-- The shift Graph construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def shiftGraph : Σ₁.Semisentence 2 := + blueprint L |>.result L |>.rew (Rew.subst ![#0, ‘0’, #1]) + +variable {L} + +section + +instance shift.defined : Σ₁-Function₁[V] shift L via shiftGraph L := + .mk fun v ↦ by + simpa [shiftGraph, Matrix.comp_vecCons', Matrix.constant_eq_singleton] using! + (construction L).result_defined.defined ![v 0, 0, v 1] + +instance shift.definable : Σ₁-Function₁[V] shift L := + shift.defined.to_definable + +instance shift.definable' : Γ-[m + 1]-Function₁[V] shift L := + shift.definable.of_sigmaOne + +end + +@[simp] +lemma shift_rel {k R v : V} (hR : L.IsRel k R) (hv : IsUTermVec L k v) : + shift L (^rel k R v) = ^rel k R (termShiftVec L k v) := by + simp [shift, hR, hv, construction] + +@[simp] +lemma shift_nrel {k R v : V} (hR : L.IsRel k R) (hv : IsUTermVec L k v) : + shift L (^nrel k R v) = ^nrel k R (termShiftVec L k v) := by + simp [shift, hR, hv, construction] + +@[simp] +lemma shift_verum : shift L (^⊤ : V) = ^⊤ := by simp [shift, construction] + +@[simp] +lemma shift_falsum : shift L (^⊥ : V) = ^⊥ := by simp [shift, construction] + +@[simp] +lemma shift_and {p q : V} (hp : IsUFormula L p) (hq : IsUFormula L q) : + shift L (p ^⋏ q) = shift L p ^⋏ shift L q := by simp [shift, hp, hq, construction] + +@[simp] +lemma shift_or {p q : V} (hp : IsUFormula L p) (hq : IsUFormula L q) : + shift L (p ^⋎ q) = shift L p ^⋎ shift L q := by simp [shift, hp, hq, construction] + +@[simp] +lemma shift_all {p : V} (hp : IsUFormula L p) : shift L (^∀ p) = ^∀ (shift L p) := by + simp [shift, hp, construction] + +@[simp] +lemma shift_exs {p : V} (hp : IsUFormula L p) : shift L (^∃ p) = ^∃ (shift L p) := by + simp [shift, hp, construction] + +lemma shift_not_uformula {x : V} (h : ¬IsUFormula L x) : shift L x = 0 := + (construction L).result_prop_not _ h + +lemma IsUFormula.shift {p : V} : IsUFormula L p → IsUFormula L (shift L p) := + by + apply IsUFormula.ISigma1.sigma1_succ_induction + · definability + · intro k r v hr hv; simp [hr, hv] + · intro k r v hr hv; simp [hr, hv] + · simp + · simp + · intro p q hp hq ihp ihq; simp [hp, hq, ihp, ihq] + · intro p q hp hq ihp ihq; simp [hp, hq, ihp, ihq] + · intro p hp ihp; simp [hp, ihp] + · intro p hp ihp; simp [hp, ihp] + +lemma IsUFormula.bv_shift {p : V} : IsUFormula L p → bv L (Bootstrapping.shift L p) = bv L p := + by + apply IsUFormula.ISigma1.sigma1_succ_induction + · definability + · intro k r v hr hv; simp [hr, hv] + · intro k r v hr hv; simp [hr, hv] + · simp + · simp + · intro p q hp hq ihp ihq; simp [hp, hq, ihp, ihq, hp.shift, hq.shift] + · intro p q hp hq ihp ihq; simp [hp, hq, ihp, ihq, hp.shift, hq.shift] + · intro p hp ihp; simp [hp, ihp, hp.shift] + · intro p hp ihp; simp [hp, ihp, hp.shift] + +lemma IsSemiformula.shift {p : V} : IsSemiformula L n p → IsSemiformula L n (shift L p) := + by + apply IsSemiformula.sigma1_structural_induction + · definability + · intro n k r v hr hv; simp [hr, hv.isUTerm] + · intro n k r v hr hv; simp [hr, hv.isUTerm] + · simp + · simp + · intro n p q hp hq ihp ihq; simp [hp.isUFormula, hq.isUFormula, ihp, ihq] + · intro n p q hp hq ihp ihq; simp [hp.isUFormula, hq.isUFormula, ihp, ihq] + · intro n p hp ihp; simp [hp.isUFormula, ihp] + · intro n p hp ihp; simp [hp.isUFormula, ihp] + +@[simp] +lemma IsUFormula.shift_iff {p : V} : IsUFormula L (Bootstrapping.shift L p) ↔ IsUFormula L p := + by + constructor + · intro h; by_contra hp + have Hp : IsUFormula L p := by by_contra hp; simp [shift_not_uformula hp] at h + contradiction + · exact IsUFormula.shift + +@[simp] +lemma IsSemiformula.shift_iff {p : V} : + IsSemiformula L n (Bootstrapping.shift L p) ↔ IsSemiformula L n p := + ⟨fun h ↦ by + have : IsUFormula L p := by by_contra hp; simp [shift_not_uformula hp] at h + exact ⟨this, by simpa [this.bv_shift] using h.bv_le⟩, IsSemiformula.shift⟩ + +lemma shift_neg {p : V} (hp : IsSemiformula L n p) : shift L (neg L p) = neg L (shift L p) := + by + apply IsSemiformula.sigma1_structural_induction ?_ ?_ ?_ ?_ ?_ ?_ ?_ ?_ ?_ hp + · definability + · intro n k R v hR hv; simp [hR, hv.isUTerm, hv.termShiftVec.isUTerm] + · intro n k R v hR hv; simp [hR, hv.isUTerm, hv.termShiftVec.isUTerm] + · simp + · simp + · intro n p q hp hq ihp ihq; + simp [hp.isUFormula, hq.isUFormula, hp.shift.isUFormula, hq.shift.isUFormula, ihp, ihq] + · intro n p q hp hq ihp ihq; + simp [hp.isUFormula, hq.isUFormula, hp.shift.isUFormula, hq.shift.isUFormula, ihp, ihq] + · intro n p hp ih; simp [hp.isUFormula, hp.shift.isUFormula, ih] + · intro n p hp ih; simp [hp.isUFormula, hp.shift.isUFormula, ih] + +end shift + +/-! +### Substitution function -/ + +section subst + +namespace Substs + +variable (L) + +/-- The blueprint construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.Substs`. -/ +noncomputable def blueprint : UformulaRec1.Blueprint + where + rel := + .mkSigma (“y param k R v. ∃ v', !(termSubstVecGraph L)v' k param v ∧ !qqRelDef y k R v'”) + nrel := + .mkSigma (“y param k R v. ∃ v', !(termSubstVecGraph L)v' k param v ∧ !qqNRelDef y k R v'”) + verum := .mkSigma (“y param. !qqVerumDef y”) + falsum := .mkSigma (“y param. !qqFalsumDef y”) + and := .mkSigma (“y param p₁ p₂ y₁ y₂. !qqAndDef y y₁ y₂”) + or := .mkSigma (“y param p₁ p₂ y₁ y₂. !qqOrDef y y₁ y₂”) + all := .mkSigma (“y param p₁ y₁. !qqAllDef y y₁”) + exs := .mkSigma (“y param p₁ y₁. !qqExsDef y y₁”) + allChanges := .mkSigma (“param' param. !(qVecGraph L)param' param”) + exsChanges := .mkSigma (“param' param. !(qVecGraph L)param' param”) + +/-- The construction construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.Substs`. -/ +noncomputable def construction : UformulaRec1.Construction V (blueprint L) + where + rel (param) := fun k R v ↦ ^rel k R (termSubstVec L k param v) + nrel (param) := fun k R v ↦ ^nrel k R (termSubstVec L k param v) + verum _ := ^⊤ + falsum _ := ^⊥ + and _ := fun _ _ y₁ y₂ ↦ y₁ ^⋏ y₂ + or _ := fun _ _ y₁ y₂ ↦ y₁ ^⋎ y₂ + all _ := fun _ y₁ ↦ ^∀ y₁ + exs _ := fun _ y₁ ↦ ^∃ y₁ + allChanges (param) := qVec L param + exsChanges (param) := qVec L param + rel_defined := .mk fun v ↦ by simp [blueprint] + nrel_defined := .mk fun v ↦ by simp [blueprint] + verum_defined := .mk fun v ↦ by simp [blueprint] + falsum_defined := .mk fun v ↦ by simp [blueprint] + and_defined := .mk fun v ↦ by simp [blueprint] + or_defined := .mk fun v ↦ by simp [blueprint] + all_defined := .mk fun v ↦ by simp [blueprint] + exs_defined := + .mk fun v ↦ by + simp [blueprint] + -- Letting `simp` apply `Semiformula.eval_substs` here overflows memory on Lean v4.33.1. + + allChanges_defined := + .mk fun v ↦ by + simp only [blueprint, HierarchySymbol.Semiformula.val_mkSigma] + rw [Semiformula.eval_substs] + simp [qVec.defined.df] + exChanges_defined := + .mk fun v ↦ by + simp only [blueprint, HierarchySymbol.Semiformula.val_mkSigma] + rw [Semiformula.eval_substs] + simp [qVec.defined.df] + +end Substs + +open Substs + +variable (L) + +/-- The subst construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def subst (w p : V) : V := + (construction L).result L w p + +/-- The substs Graph construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def substsGraph : Σ₁.Semisentence 3 := + (blueprint L).result L + +variable {L} + +section + +instance subst.defined : Σ₁-Function₂[V] subst L via substsGraph L := + (construction L).result_defined + +instance subst.definable : Σ₁-Function₂[V] subst L := + subst.defined.to_definable + +instance subst.definable' : Γ-[m + 1]-Function₂[V] subst L := + subst.definable.of_sigmaOne + +attribute [irreducible] substsGraph + +end + +variable {m w : V} + +@[simp] +lemma substs_rel {k R v : V} (hR : L.IsRel k R) (hv : IsUTermVec L k v) : + subst L w (^rel k R v) = ^rel k R (termSubstVec L k w v) := by + simp [subst, hR, hv, construction] + +@[simp] +lemma substs_nrel {k R v : V} (hR : L.IsRel k R) (hv : IsUTermVec L k v) : + subst L w (^nrel k R v) = ^nrel k R (termSubstVec L k w v) := by + simp [subst, hR, hv, construction] + +@[simp] +lemma substs_verum (w : V) : subst L w ^⊤ = ^⊤ := by simp [subst, construction] + +@[simp] +lemma substs_falsum (w : V) : subst L w ^⊥ = ^⊥ := by simp [subst, construction] + +@[simp] +lemma substs_and {p q : V} (hp : IsUFormula L p) (hq : IsUFormula L q) : + subst L w (p ^⋏ q) = subst L w p ^⋏ subst L w q := by simp [subst, hp, hq, construction] + +@[simp] +lemma substs_or {p q : V} (hp : IsUFormula L p) (hq : IsUFormula L q) : + subst L w (p ^⋎ q) = subst L w p ^⋎ subst L w q := by simp [subst, hp, hq, construction] + +@[simp] +lemma substs_all {p} (hp : IsUFormula L p) : subst L w (^∀ p) = ^∀ (subst L (qVec L w) p) := by + simp [subst, hp, construction] + +@[simp] +lemma substs_ex {p} (hp : IsUFormula L p) : subst L w (^∃ p) = ^∃ (subst L (qVec L w) p) := by + simp [subst, hp, construction] + +lemma isUFormula_subst_ISigma1.sigma1_succ_induction {P : V → V → V → Prop} + (hP : Σ₁-Relation₃ P) + (hRel : + ∀ w k R v, + L.IsRel k R → IsUTermVec L k v → P w (^rel k R v) (^rel k R (termSubstVec L k w v))) + (hNRel : + ∀ w k R v, + L.IsRel k R → IsUTermVec L k v → P w (^nrel k R v) (^nrel k R (termSubstVec L k w v))) + (hverum : ∀ w, P w ^⊤ ^⊤) (hfalsum : ∀ w, P w ^⊥ ^⊥) + (hand : + ∀ w p q, + IsUFormula L p → + IsUFormula L q → + P w p (subst L w p) → + P w q (subst L w q) → P w (p ^⋏ q) (subst L w p ^⋏ subst L w q)) + (hor : + ∀ w p q, + IsUFormula L p → + IsUFormula L q → + P w p (subst L w p) → + P w q (subst L w q) → P w (p ^⋎ q) (subst L w p ^⋎ subst L w q)) + (hall : + ∀ w p, + IsUFormula L p → + P (qVec L w) p (subst L (qVec L w) p) → P w (^∀ p) (^∀ (subst L (qVec L w) p))) + (hexs : + ∀ w p, + IsUFormula L p → + P (qVec L w) p (subst L (qVec L w) p) → P w (^∃ p) (^∃ (subst L (qVec L w) p))) : + ∀ {w p}, IsUFormula L p → P w p (subst L w p) := + by + suffices ∀ param p, IsUFormula L p → P param p ((construction L).result L param p) by + intro w p hp; simpa using! this w p hp + apply (construction L).uformula_result_induction (P := fun param p y ↦ P param p y) + · definability + · intro param k R v hkR hv; simpa using! hRel param k R v hkR hv + · intro param k R v hkR hv; simpa using! hNRel param k R v hkR hv + · intro param; simpa using! hverum param + · intro param; simpa using! hfalsum param + · intro param p q hp hq ihp ihq + simpa [subst] using! + hand param p q hp hq (by simpa [subst] using ihp) (by simpa [subst] using ihq) + · intro param p q hp hq ihp ihq + simpa [subst] using! + hor param p q hp hq (by simpa [subst] using ihp) (by simpa [subst] using ihq) + · intro param p hp ihp + simpa using! hall param p hp (by simpa [construction] using! ihp) + · intro param p hp ihp + simpa using! hexs param p hp (by simpa [construction] using! ihp) + +lemma semiformula_subst_induction {P : V → V → V → V → Prop} (hP : Σ₁-Relation₄ P) + (hRel : + ∀ n w k R v, + L.IsRel k R → + IsSemitermVec L k n v → P n w (^rel k R v) (^rel k R (termSubstVec L k w v))) + (hNRel : + ∀ n w k R v, + L.IsRel k R → + IsSemitermVec L k n v → P n w (^nrel k R v) (^nrel k R (termSubstVec L k w v))) + (hverum : ∀ n w, P n w ^⊤ ^⊤) (hfalsum : ∀ n w, P n w ^⊥ ^⊥) + (hand : + ∀ n w p q, + IsSemiformula L n p → + IsSemiformula L n q → + P n w p (subst L w p) → + P n w q (subst L w q) → P n w (p ^⋏ q) (subst L w p ^⋏ subst L w q)) + (hor : + ∀ n w p q, + IsSemiformula L n p → + IsSemiformula L n q → + P n w p (subst L w p) → + P n w q (subst L w q) → P n w (p ^⋎ q) (subst L w p ^⋎ subst L w q)) + (hall : + ∀ n w p, + IsSemiformula L (n + 1) p → + P (n + 1) (qVec L w) p (subst L (qVec L w) p) → + P n w (^∀ p) (^∀ (subst L (qVec L w) p))) + (hexs : + ∀ n w p, + IsSemiformula L (n + 1) p → + P (n + 1) (qVec L w) p (subst L (qVec L w) p) → + P n w (^∃ p) (^∃ (subst L (qVec L w) p))) : + ∀ {n p w}, IsSemiformula L n p → P n w p (subst L w p) := + by + suffices ∀ param n p, IsSemiformula L n p → P n param p ((construction L).result L param p) by + intro n p w hp; simpa using! this w n p hp + apply (construction L).semiformula_result_induction (P := fun param n p y ↦ P n param p y) + · definability + · intro n param k R v hkR hv; simpa using! hRel n param k R v hkR hv + · intro n param k R v hkR hv; simpa using! hNRel n param k R v hkR hv + · intro n param; simpa using! hverum n param + · intro n param; simpa using! hfalsum n param + · intro n param p q hp hq ihp ihq + simpa [subst] using! + hand n param p q hp hq (by simpa [subst] using ihp) (by simpa [subst] using ihq) + · intro n param p q hp hq ihp ihq + simpa [subst] using! + hor n param p q hp hq (by simpa [subst] using ihp) (by simpa [subst] using ihq) + · intro n param p hp ihp + simpa using! hall n param p hp (by simpa [construction] using! ihp) + · intro n param p hp ihp + simpa using! hexs n param p hp (by simpa [construction] using! ihp) + +lemma IsSemiformula.subst {n p m w : V} : + IsSemiformula L n p → IsSemitermVec L n m w → IsSemiformula L m (subst L w p) := + by + let fw : V → V → V → V → V := fun _ w _ _ ↦ Max.max w (qVec L w) + have hfw : Σ₁-Function₄ fw := by definability + let fn : V → V → V → V → V := fun _ _ n _ ↦ n + 1 + have hfn : Σ₁-Function₄ fn := by definability + let fm : V → V → V → V → V := fun _ _ _ m ↦ m + 1 + have hfm : Σ₁-Function₄ fm := by definability + apply bounded_all_sigma1_order_induction₃ hfw hfn hfm ?_ ?_ p w n m + · definability + intro p w n m ih hp hw + rcases IsSemiformula.case_iff.mp hp with + (⟨k, R, v, hR, hv, rfl⟩ | ⟨k, R, v, hR, hv, rfl⟩ | rfl | rfl | ⟨p₁, p₂, h₁, h₂, rfl⟩ | + ⟨p₁, p₂, h₁, h₂, rfl⟩ | ⟨p₁, h₁, rfl⟩ | ⟨p₁, h₁, rfl⟩) + · simp [hR, hv.isUTerm, hw.termSubstVec hv] + · simp [hR, hv.isUTerm, hw.termSubstVec hv] + · simp + · simp + · have ih₁ : IsSemiformula L m (Bootstrapping.subst L w p₁) := + ih p₁ (by simp) w (by simp [fw]) n (by simp [fn]) m (by simp [fm]) h₁ hw + have ih₂ : IsSemiformula L m (Bootstrapping.subst L w p₂) := + ih p₂ (by simp) w (by simp [fw]) n (by simp [fn]) m (by simp [fm]) h₂ hw + simp [h₁.isUFormula, h₂.isUFormula, ih₁, ih₂] + · have ih₁ : IsSemiformula L m (Bootstrapping.subst L w p₁) := + ih p₁ (by simp) w (by simp [fw]) n (by simp [fn]) m (by simp [fm]) h₁ hw + have ih₂ : IsSemiformula L m (Bootstrapping.subst L w p₂) := + ih p₂ (by simp) w (by simp [fw]) n (by simp [fn]) m (by simp [fm]) h₂ hw + simp [h₁.isUFormula, h₂.isUFormula, ih₁, ih₂] + · simpa [h₁.isUFormula] using + ih p₁ (by simp) (qVec L w) (by simp [fw]) (n + 1) (by simp [fn]) (m + 1) (by simp [fm]) h₁ + hw.qVec + · simpa [h₁.isUFormula] using + ih p₁ (by simp) (qVec L w) (by simp [fw]) (n + 1) (by simp [fn]) (m + 1) (by simp [fm]) h₁ + hw.qVec + +lemma substs_not_uformula {w x : V} (h : ¬IsUFormula L x) : subst L w x = 0 := + (construction L).result_prop_not _ h + +lemma substs_neg {p} (hp : IsSemiformula L n p) : + IsSemitermVec L n m w → subst L w (neg L p) = neg L (subst L w p) := + by + revert m w + apply IsSemiformula.pi1_structural_induction ?_ ?_ ?_ ?_ ?_ ?_ ?_ ?_ ?_ hp + · definability + · intros n k R v hR hv m w hw + rw [neg_rel hR hv.isUTerm, substs_nrel hR hv.isUTerm, substs_rel hR hv.isUTerm, + neg_rel hR (hw.termSubstVec hv).isUTerm] + · intros n k R v hR hv m w hw + rw [neg_nrel hR hv.isUTerm, substs_rel hR hv.isUTerm, substs_nrel hR hv.isUTerm, + neg_nrel hR (hw.termSubstVec hv).isUTerm] + · intros; simp [*] + · intros; simp [*] + · intro n p q hp hq ihp ihq m w hw + rw [neg_and hp.isUFormula hq.isUFormula, substs_or hp.neg.isUFormula hq.neg.isUFormula, + substs_and hp.isUFormula hq.isUFormula, + neg_and (hp.subst hw).isUFormula (hq.subst hw).isUFormula, ihp hw, ihq hw] + · intro n p q hp hq ihp ihq m w hw + rw [neg_or hp.isUFormula hq.isUFormula, substs_and hp.neg.isUFormula hq.neg.isUFormula, + substs_or hp.isUFormula hq.isUFormula, + neg_or (hp.subst hw).isUFormula (hq.subst hw).isUFormula, ihp hw, ihq hw] + · intro n p hp ih m w hw + rw [neg_all hp.isUFormula, substs_ex hp.neg.isUFormula, substs_all hp.isUFormula, + neg_all (hp.subst hw.qVec).isUFormula, ih hw.qVec] + · intro n p hp ih m w hw + rw [neg_ex hp.isUFormula, substs_all hp.neg.isUFormula, substs_ex hp.isUFormula, + neg_ex (hp.subst hw.qVec).isUFormula, ih hw.qVec] + +lemma shift_substs {p} (hp : IsSemiformula L n p) : + IsSemitermVec L n m w → shift L (subst L w p) = subst L (termShiftVec L n w) (shift L p) := + by + revert m w + apply IsSemiformula.pi1_structural_induction ?_ ?_ ?_ ?_ ?_ ?_ ?_ ?_ ?_ hp + · definability + · intro n k R v hR hv m w hw + rw [substs_rel hR hv.isUTerm, shift_rel hR (hw.termSubstVec hv).isUTerm, + shift_rel hR hv.isUTerm, substs_rel hR hv.termShiftVec.isUTerm] + simp only [qqRel_inj, true_and] + apply + nth_ext' k (by rw [len_termShiftVec (hw.termSubstVec hv).isUTerm]) + (by rw [len_termSubstVec hv.termShiftVec.isUTerm]) + intro i hi + rw [nth_termShiftVec (hw.termSubstVec hv).isUTerm hi, nth_termSubstVec hv.isUTerm hi, + nth_termSubstVec hv.termShiftVec.isUTerm hi, nth_termShiftVec hv.isUTerm hi, + termShift_termSubsts (hv.nth hi) hw] + · intro n k R v hR hv m w hw + rw [substs_nrel hR hv.isUTerm, shift_nrel hR (hw.termSubstVec hv).isUTerm, + shift_nrel hR hv.isUTerm, substs_nrel hR hv.termShiftVec.isUTerm] + simp only [qqNRel_inj, true_and] + apply + nth_ext' k (by rw [len_termShiftVec (hw.termSubstVec hv).isUTerm]) + (by rw [len_termSubstVec hv.termShiftVec.isUTerm]) + intro i hi + rw [nth_termShiftVec (hw.termSubstVec hv).isUTerm hi, nth_termSubstVec hv.isUTerm hi, + nth_termSubstVec hv.termShiftVec.isUTerm hi, nth_termShiftVec hv.isUTerm hi, + termShift_termSubsts (hv.nth hi) hw] + · intro n w hw; simp + · intro n w hw; simp + · intro n p q hp hq ihp ihq m w hw + rw [substs_and hp.isUFormula hq.isUFormula, + shift_and (hp.subst hw).isUFormula (hq.subst hw).isUFormula, + shift_and hp.isUFormula hq.isUFormula, substs_and hp.shift.isUFormula hq.shift.isUFormula, + ihp hw, ihq hw] + · intro n p q hp hq ihp ihq m w hw + rw [substs_or hp.isUFormula hq.isUFormula, + shift_or (hp.subst hw).isUFormula (hq.subst hw).isUFormula, + shift_or hp.isUFormula hq.isUFormula, substs_or hp.shift.isUFormula hq.shift.isUFormula, + ihp hw, ihq hw] + · intro n p hp ih m w hw + rw [substs_all hp.isUFormula, shift_all (hp.subst hw.qVec).isUFormula, + shift_all hp.isUFormula, substs_all hp.shift.isUFormula, ih hw.qVec, termShift_qVec hw] + · intro n p hp ih m w hw + rw [substs_ex hp.isUFormula, shift_exs (hp.subst hw.qVec).isUFormula, + shift_exs hp.isUFormula, substs_ex hp.shift.isUFormula, ih hw.qVec, termShift_qVec hw] + +lemma substs_substs {p} (hp : IsSemiformula L l p) : + IsSemitermVec L n m w → + IsSemitermVec L l n v → subst L w (subst L v p) = subst L (termSubstVec L l w v) p := + by + revert m w n v + apply IsSemiformula.pi1_structural_induction ?_ ?_ ?_ ?_ ?_ ?_ ?_ ?_ ?_ hp + · definability + · intro l k R ts hR hts m w n v _ hv + rw [substs_rel hR hts.isUTerm, substs_rel hR (hv.termSubstVec hts).isUTerm, + substs_rel hR hts.isUTerm] + simp only [qqRel_inj, true_and] + apply + nth_ext' k (by rw [len_termSubstVec (hv.termSubstVec hts).isUTerm]) + (by rw [len_termSubstVec hts.isUTerm]) + intro i hi + rw [nth_termSubstVec (hv.termSubstVec hts).isUTerm hi, nth_termSubstVec hts.isUTerm hi, + nth_termSubstVec hts.isUTerm hi, termSubst_termSubst hv (hts.nth hi)] + · intro l k R ts hR hts m w n v _ hv + rw [substs_nrel hR hts.isUTerm, substs_nrel hR (hv.termSubstVec hts).isUTerm, + substs_nrel hR hts.isUTerm] + simp only [qqNRel_inj, true_and] + apply + nth_ext' k (by rw [len_termSubstVec (hv.termSubstVec hts).isUTerm]) + (by rw [len_termSubstVec hts.isUTerm]) + intro i hi + rw [nth_termSubstVec (hv.termSubstVec hts).isUTerm hi, nth_termSubstVec hts.isUTerm hi, + nth_termSubstVec hts.isUTerm hi, termSubst_termSubst hv (hts.nth hi)] + · intros; simp + · intros; simp + · intro l p q hp hq ihp ihq m w n v hw hv + rw [substs_and hp.isUFormula hq.isUFormula, + substs_and (hp.subst hv).isUFormula (hq.subst hv).isUFormula, + substs_and hp.isUFormula hq.isUFormula, ihp hw hv, ihq hw hv] + · intro l p q hp hq ihp ihq m w n v hw hv + rw [substs_or hp.isUFormula hq.isUFormula, + substs_or (hp.subst hv).isUFormula (hq.subst hv).isUFormula, + substs_or hp.isUFormula hq.isUFormula, ihp hw hv, ihq hw hv] + · intro l p hp ih m w n v hw hv + rw [substs_all hp.isUFormula, substs_all (hp.subst hv.qVec).isUFormula, + substs_all hp.isUFormula, ih hw.qVec hv.qVec, termSubstVec_qVec_qVec hv hw] + · intro l p hp ih m w n v hw hv + rw [substs_ex hp.isUFormula, substs_ex (hp.subst hv.qVec).isUFormula, + substs_ex hp.isUFormula, ih hw.qVec hv.qVec, termSubstVec_qVec_qVec hv hw] + +lemma subst_eq_self {n w : V} (hp : IsSemiformula L n p) (hw : IsSemitermVec L n n w) + (H : ∀ i < n, w.[i] = ^#i) : subst L w p = p := + by + revert w + apply IsSemiformula.pi1_structural_induction ?_ ?_ ?_ ?_ ?_ ?_ ?_ ?_ ?_ hp + · definability + · intro n k R v hR hv w _ H + simp only [substs_rel, qqRel_inj, true_and, hR, hv.isUTerm] + apply nth_ext' k (by simp [*, hv.isUTerm]) (by simp [hv.lh]) + intro i hi + rw [nth_termSubstVec hv.isUTerm hi, termSubst_eq_self (hv.nth hi) H] + · intro n k R v hR hv w _ H + simp only [substs_nrel, qqNRel_inj, true_and, hR, hv.isUTerm] + apply nth_ext' k (by simp [*, hv.isUTerm]) (by simp [hv.lh]) + intro i hi + rw [nth_termSubstVec hv.isUTerm hi, termSubst_eq_self (hv.nth hi) H] + · intro n w _ _; simp + · intro n w _ _; simp + · intro n p q hp hq ihp ihq w hw H + simp [*, hp.isUFormula, hq.isUFormula, ihp hw H, ihq hw H] + · intro n p q hp hq ihp ihq w hw H + simp [*, hp.isUFormula, hq.isUFormula, ihp hw H, ihq hw H] + · intro n p hp ih w hw H + have H : ∀ i < n + 1, (qVec L w).[i] = ^#i := + by + intro i hi + rcases zero_or_succ i with (rfl | ⟨i, rfl⟩) + · simp [qVec] + · have hi : i < n := by simpa using hi + simp only [qVec, nth_adjoin_succ] + rw [nth_termBShiftVec (by simpa [hw.lh] using hw.isUTerm) (by simp [hw.lh, hi])] + simp [H i hi] + simp [*, hp.isUFormula, ih hw.qVec H] + · intro n p hp ih w hw H + have H : ∀ i < n + 1, (qVec L w).[i] = ^#i := + by + intro i hi + rcases zero_or_succ i with (rfl | ⟨i, rfl⟩) + · simp [qVec] + · have hi : i < n := by simpa using hi + simp only [qVec, nth_adjoin_succ] + rw [nth_termBShiftVec (by simpa [hw.lh] using hw.isUTerm) (by simp [hw.lh, hi])] + simp [H i hi] + simp [*, hp.isUFormula, ih hw.qVec H] + +lemma subst_eq_self₁ (hp : IsSemiformula L 1 p) : subst L (^#0 ∷ 0) p = p := + subst_eq_self hp (by simp) (by simp) + +end subst + +variable (L) + +/-- The substs1 construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def substs1 (t u : V) : V := + subst L ?[t] u + +/-- The substs1Graph construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def substs1Graph : Σ₁.Semisentence 3 := + .mkSigma (“z t p. ∃ v, !adjoinDef v t 0 ∧ !(substsGraph L)z v p”) + +variable {L} + +section substs1 + +section + +instance substs1.defined : Σ₁-Function₂[V] substs1 L via substs1Graph L := + .mk fun v ↦ by simp [substs1Graph]; rfl + +instance substs1.definable : Σ₁-Function₂[V] substs1 L := + substs1.defined.to_definable + +instance substs1.definable' : Γ-[m + 1]-Function₂[V] substs1 L := + substs1.definable.of_sigmaOne + +end + +lemma IsSemiformula.substs1 {n t p : V} (ht : IsSemiterm L n t) (hp : IsSemiformula L 1 p) : + IsSemiformula L n (substs1 L t p) := + IsSemiformula.subst hp (by simp [ht]) + +end substs1 + +variable (L) + +/-- The free construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def free (p : V) : V := + substs1 L ^&0 (shift L p) + +/-- The free Graph construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def freeGraph : Σ₁.Semisentence 2 := + .mkSigma (“q p. ∃ fz, !qqFvarDef fz 0 ∧ ∃ sp, !(shiftGraph L)sp p ∧ !(substs1Graph L)q fz sp”) + +variable {L} + +/-! +### free function -/ + +section free + +section + +instance free.defined : Σ₁-Function₁[V] free L via freeGraph L := + .mk fun v ↦ by simp [freeGraph, free] + +instance free.definable : Σ₁-Function₁[V] free L := + free.defined.to_definable + +instance free.definable' : Γ-[m + 1]-Function₁[V] free L := + free.definable.of_sigmaOne + +end + +@[simp] +lemma IsSemiformula.free {p : V} (hp : IsSemiformula L 1 p) : IsFormula L (free L p) := + IsSemiformula.substs1 (by simp) hp.shift + +end free + +section free1 + +variable (L) + +/-- The free1 construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def free1 (p : V) : V := + subst L ?[^&0, ^#0] (shift L p) + +variable {L} + +@[simp] +lemma IsSemiformula.free1 {p : V} (hp : IsSemiformula L 2 p) : IsSemiformula L 1 (free1 L p) := + IsSemiformula.subst (m := 1) hp.shift + (SemitermVec.adjoin (SemitermVec.adjoin (IsSemitermVec.empty _) (by simp)) (by simp)) + +end free1 + +/-! +### Complexity of formula -/ + +section complexity + +namespace FormulaComplexity + +/-- +The blueprint construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.FormulaComplexity`. -/ +def blueprint : UformulaRec1.Blueprint + where + rel := .mkSigma (“y param k R v. y = 0”) + nrel := .mkSigma (“y param k R v. y = 0”) + verum := .mkSigma (“y param. y = 0”) + falsum := .mkSigma (“y param. y = 0”) + and := .mkSigma (“y param p₁ p₂ y₁ y₂. !max.dfn y(y₁ + 1)(y₂ + 1)”) + or := .mkSigma (“y param p₁ p₂ y₁ y₂. !max.dfn y(y₁ + 1)(y₂ + 1)”) + all := .mkSigma (“y param p₁ y₁. y = y₁ + 1”) + exs := .mkSigma (“y param p₁ y₁. y = y₁ + 1”) + allChanges := .mkSigma (“param' param. param' = 0”) + exsChanges := .mkSigma (“param' param. param' = 0”) + +/-- The construction construction in +`FFL.FirstOrder.Arithmetic.Bootstrapping.FormulaComplexity`. -/ +noncomputable def construction : UformulaRec1.Construction V blueprint + where + rel {_} := fun k R v ↦ 0 + nrel {_} := fun k R v ↦ 0 + verum {_} := 0 + falsum {_} := 0 + and {_} := fun _ _ y₁ y₂ ↦ max y₁ y₂ + 1 + or {_} := fun _ _ y₁ y₂ ↦ max y₁ y₂ + 1 + all {_} := fun _ y₁ ↦ y₁ + 1 + exs {_} := fun _ y₁ ↦ y₁ + 1 + allChanges := fun _ ↦ 0 + exsChanges := fun _ ↦ 0 + rel_defined := .mk fun v ↦ by simp [blueprint] + nrel_defined := .mk fun v ↦ by simp [blueprint] + verum_defined := .mk fun v ↦ by simp [blueprint] + falsum_defined := .mk fun v ↦ by simp [blueprint] + and_defined := .mk fun v ↦ by simp [blueprint, max_add_add_right] + or_defined := .mk fun v ↦ by simp [blueprint, max_add_add_right] + all_defined := .mk fun v ↦ by simp [blueprint] + exs_defined := .mk fun v ↦ by simp [blueprint] + allChanges_defined := .mk fun v ↦ by simp [blueprint] + exChanges_defined := .mk fun v ↦ by simp [blueprint] + +end FormulaComplexity + +open FormulaComplexity + +variable (L) + +/-- The formula Complexity construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def formulaComplexity (p : V) : V := + construction.result L 0 p + +/-- The formula Complexity Graph construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def formulaComplexityGraph : Σ₁.Semisentence 2 := + (blueprint.result L).rew (Rew.subst ![#0, ‘0’, #1]) + +variable {L} + +section + +instance formulaComplexity.defined : + Σ₁-Function₁[V] formulaComplexity L via formulaComplexityGraph L := + .mk fun v ↦ by + simpa [formulaComplexityGraph, Matrix.comp_vecCons', Matrix.constant_eq_singleton] using! + construction.result_defined.defined ![v 0, 0, v 1] + +instance formulaComplexity.definable : Σ₁-Function₁[V] formulaComplexity L := + formulaComplexity.defined.to_definable + +instance formulaComplexity.definable' : Γ-[m + 1]-Function₁[V] formulaComplexity L := + .of_sigmaOne formulaComplexity.definable + +end + +@[simp] +lemma formulaComplexity_rel {k R v : V} (hR : L.IsRel k R) (hv : IsUTermVec L k v) : + formulaComplexity L (^rel k R v) = 0 := by simp [formulaComplexity, hR, hv, construction] + +@[simp] +lemma formulaComplexity_nrel {k R v : V} (hR : L.IsRel k R) (hv : IsUTermVec L k v) : + formulaComplexity L (^nrel k R v) = 0 := by simp [formulaComplexity, hR, hv, construction] + +@[simp] +lemma formulaComplexity_verum : formulaComplexity L (^⊤ : V) = 0 := by + simp [formulaComplexity, construction] + +@[simp] +lemma formulaComplexity_falsum : formulaComplexity L (^⊥ : V) = 0 := by + simp [formulaComplexity, construction] + +@[simp] +lemma formulaComplexity_and {p q : V} (hp : IsUFormula L p) (hq : IsUFormula L q) : + formulaComplexity L (p ^⋏ q) = max (formulaComplexity L p) (formulaComplexity L q) + 1 := by + simp [formulaComplexity, hp, hq, construction] + +@[simp] +lemma formulaComplexity_or {p q : V} (hp : IsUFormula L p) (hq : IsUFormula L q) : + formulaComplexity L (p ^⋎ q) = max (formulaComplexity L p) (formulaComplexity L q) + 1 := by + simp [formulaComplexity, hp, hq, construction] + +@[simp] +lemma formulaComplexity_all {p : V} (hp : IsUFormula L p) : + formulaComplexity L (^∀ p) = formulaComplexity L p + 1 := by + simp [formulaComplexity, hp, construction] + +@[simp] +lemma formulaComplexity_ex {p : V} (hp : IsUFormula L p) : + formulaComplexity L (^∃ p) = formulaComplexity L p + 1 := by + simp [formulaComplexity, hp, construction] + +lemma formulaComplexity_not_uformula {x : V} (h : ¬IsUFormula L x) : + formulaComplexity L x = 0 := + construction.result_prop_not _ h + +@[simp] +lemma formulaComplexity_neg {p : V} : + IsUFormula L p → formulaComplexity L (neg L p) = formulaComplexity L p := + by + apply IsUFormula.ISigma1.sigma1_succ_induction + · definability + · intro k r v hr hv; simp [hr, hv] + · intro k r v hr hv; simp [hr, hv] + · simp + · simp + · intro p q hp hq ihp ihq; simp [hp, hq, ihp, ihq] + · intro p q hp hq ihp ihq; simp [hp, hq, ihp, ihq] + · intro p hp ihp; simp [hp, ihp] + · intro p hp ihp; simp [hp, ihp] + +@[simp] +lemma formulaComplexity_shift {p : V} : + IsUFormula L p → formulaComplexity L (shift L p) = formulaComplexity L p := + by + apply IsUFormula.ISigma1.sigma1_succ_induction + · definability + · intro k r v hr hv; simp [hr, hv] + · intro k r v hr hv; simp [hr, hv] + · simp + · simp + · intro p q hp hq ihp ihq + simp [hp, hq, ihp, ihq] + · intro p q hp hq ihp ihq; simp [hp, hq, ihp, ihq] + · intro p hp ihp; simp [hp, ihp] + · intro p hp ihp; simp [hp, ihp] + +lemma fomulaComplexity_substs {p : V} (hp : IsSemiformula L n p) : + IsSemitermVec L n m w → formulaComplexity L (subst L w p) = formulaComplexity L p := + by + revert m w + apply IsSemiformula.pi1_structural_induction ?_ ?_ ?_ ?_ ?_ ?_ ?_ ?_ ?_ hp + · definability + · intro n k R v hR hv m w hw + rw [formulaComplexity_rel hR hv.isUTerm, substs_rel hR hv.isUTerm, + formulaComplexity_rel hR (hw.termSubstVec hv).isUTerm] + · intro n k R v hR hv m w hw + rw [formulaComplexity_nrel hR hv.isUTerm, substs_nrel hR hv.isUTerm, + formulaComplexity_nrel hR (hw.termSubstVec hv).isUTerm] + · intro n m w hw + rw [substs_verum] + · intro n m w hw + rw [substs_falsum] + · intro n p q hp hq ihp ihq m w hw + rw [substs_and hp.isUFormula hq.isUFormula, + formulaComplexity_and (hp.subst hw).isUFormula (hq.subst hw).isUFormula, ihp hw, ihq hw, + formulaComplexity_and hp.isUFormula hq.isUFormula] + · intro n p q hp hq ihp ihq m w hw + rw [substs_or hp.isUFormula hq.isUFormula, + formulaComplexity_or (hp.subst hw).isUFormula (hq.subst hw).isUFormula, ihp hw, ihq hw, + formulaComplexity_or hp.isUFormula hq.isUFormula] + · intro n p hp ihp m w hw + rw [substs_all hp.isUFormula, formulaComplexity_all (hp.subst hw.qVec).isUFormula, + ihp (hw.qVec), formulaComplexity_all hp.isUFormula] + · intro n p hp ihp m w hw + rw [substs_ex hp.isUFormula, formulaComplexity_ex (hp.subst hw.qVec).isUFormula, + ihp (hw.qVec), formulaComplexity_ex hp.isUFormula] + +lemma fomulaComplexity_substs1 {p : V} (hp : IsSemiformula L 1 p) (ht : IsSemiterm L m t) : + formulaComplexity L (substs1 L t p) = formulaComplexity L p := + by + unfold substs1 + rw [fomulaComplexity_substs hp (IsSemitermVec.singleton.mpr ht)] + +lemma fomulaComplexity_free {p : V} (hp : IsSemiformula L 1 p) : + formulaComplexity L (free L p) = formulaComplexity L p := + by + unfold free + have : IsSemiterm (V := V) L 0 ^&0 := by simp + rw [fomulaComplexity_substs1 hp.shift this, formulaComplexity_shift hp.isUFormula] + +lemma fomulaComplexity_free1 {p : V} (hp : IsSemiformula L 2 p) : + formulaComplexity L (free1 L p) = formulaComplexity L p := + by + unfold free1 + have : IsSemiterm (V := V) L 0 ^&0 := by simp + rw [fomulaComplexity_substs (m := 1) (V := V) hp.shift] + · rw [formulaComplexity_shift hp.isUFormula] + · apply IsSemitermVec.adjoin ?_ (by simp) + apply IsSemitermVec.adjoin ?_ (by simp) + exact IsSemitermVec.nil _ + +end complexity + +@[simp] +lemma lt_max_succ_left (a b : V) : a < max a b + 1 := + lt_succ_iff_le.mpr <| by simp + +@[simp] +lemma lt_max_succ_right (a b : V) : b < max a b + 1 := + lt_succ_iff_le.mpr <| by simp + +/-! +A structural induction correspondence to `FFL.FirstOrder.Semiformula.formulaRec`. -/ + +lemma IsFormula.sigma1_structural_induction {P : V → Prop} (hP : Σ₁-Predicate P) + (hrel : ∀ k r v, L.IsRel k r → IsTermVec L k v → P (^rel k r v)) + (hnrel : ∀ k r v, L.IsRel k r → IsTermVec L k v → P (^nrel k r v)) (hverum : P ^⊤) + (hfalsum : P ^⊥) (hand : ∀ p q, IsFormula L p → IsFormula L q → P p → P q → P (p ^⋏ q)) + (hor : ∀ p q, IsFormula L p → IsFormula L q → P p → P q → P (p ^⋎ q)) + (hall : ∀ p, IsSemiformula L 1 p → P (free L p) → P (^∀ p)) + (hexs : ∀ p, IsSemiformula L 1 p → P (free L p) → P (^∃ p)) {p} : IsFormula L p → P p := + by + have hm : Σ₁-Function₁[V] formulaComplexity L := inferInstance + let f : V → V := fun p ↦ max p (free L (π₂(p - 1))) + have hf : Σ₁-Function₁ f := by unfold f; definability + apply measured_bounded_sigma1_order_induction hm hf ?_ ?_ p + · definability + intro p ih hp + rcases IsSemiformula.case_iff.mp hp with + (⟨k, R, v, hR, hv, rfl⟩ | ⟨k, R, v, hR, hv, rfl⟩ | rfl | rfl | ⟨p₁, p₂, h₁, h₂, rfl⟩ | + ⟨p₁, p₂, h₁, h₂, rfl⟩ | ⟨p₁, h₁, rfl⟩ | ⟨p₁, h₁, rfl⟩) + · exact hrel _ _ _ hR hv + · exact hnrel _ _ _ hR hv + · exact hverum + · exact hfalsum + · have ih₁ : P p₁ := + ih p₁ (by simp only [le_sup_iff, f]; left; exact le_of_lt <| by simp) + (by simp [h₁.isUFormula, h₂.isUFormula]) h₁ + have ih₂ : P p₂ := + ih p₂ (by simp only [le_sup_iff, f]; left; exact le_of_lt <| by simp) + (by simp [h₁.isUFormula, h₂.isUFormula]) h₂ + exact hand _ _ h₁ h₂ ih₁ ih₂ + · have ih₁ : P p₁ := + ih p₁ (by simp only [le_sup_iff, f]; left; exact le_of_lt <| by simp) + (by simp [h₁.isUFormula, h₂.isUFormula]) h₁ + have ih₂ : P p₂ := + ih p₂ (by simp only [le_sup_iff, f]; left; exact le_of_lt <| by simp) + (by simp [h₁.isUFormula, h₂.isUFormula]) h₂ + exact hor _ _ h₁ h₂ ih₁ ih₂ + · have h₁ : IsSemiformula L 1 p₁ := by simpa using h₁ + have : P (free L p₁) := + ih (free L p₁) (by simp only [le_sup_iff, f]; right; simp [qqAll]) + (by simp [fomulaComplexity_free h₁, h₁.isUFormula]) (h₁.free) + exact hall _ h₁ this + · have h₁ : IsSemiformula L 1 p₁ := by simpa using h₁ + have : P (free L p₁) := + ih (free L p₁) (by simp only [le_sup_iff, f]; right; simp [qqExs]) + (by simp [fomulaComplexity_free h₁, h₁.isUFormula]) (h₁.free) + exact hexs _ h₁ this + +lemma IsFormula.sigma1_structural_induction₂ {P : V → Prop} (hP : Σ₁-Predicate P) + (hrel : ∀ k r v, L.IsRel k r → IsSemitermVec L k 1 v → P (^rel k r v)) + (hnrel : ∀ k r v, L.IsRel k r → IsSemitermVec L k 1 v → P (^nrel k r v)) (hverum : P ^⊤) + (hfalsum : P ^⊥) + (hand : ∀ p q, IsSemiformula L 1 p → IsSemiformula L 1 q → P p → P q → P (p ^⋏ q)) + (hor : ∀ p q, IsSemiformula L 1 p → IsSemiformula L 1 q → P p → P q → P (p ^⋎ q)) + (hall : ∀ p, IsSemiformula L 2 p → P (free1 L p) → P (^∀ p)) + (hexs : ∀ p, IsSemiformula L 2 p → P (free1 L p) → P (^∃ p)) {p} : + IsSemiformula L 1 p → P p := + by + have hm : Σ₁-Function₁[V] formulaComplexity L := inferInstance + let f : V → V := fun p ↦ max p (free1 L (π₂(p - 1))) + have hf : Σ₁-Function₁ f := by unfold f; definability + apply measured_bounded_sigma1_order_induction hm hf ?_ ?_ p + · definability + intro p ih hp + rcases IsSemiformula.case_iff.mp hp with + (⟨k, R, v, hR, hv, rfl⟩ | ⟨k, R, v, hR, hv, rfl⟩ | rfl | rfl | ⟨p₁, p₂, h₁, h₂, rfl⟩ | + ⟨p₁, p₂, h₁, h₂, rfl⟩ | ⟨p₁, h₁, rfl⟩ | ⟨p₁, h₁, rfl⟩) + · exact hrel _ _ _ hR hv + · exact hnrel _ _ _ hR hv + · exact hverum + · exact hfalsum + · have ih₁ : P p₁ := + ih p₁ (by simp only [le_sup_iff, f]; left; exact le_of_lt <| by simp) + (by simp [h₁.isUFormula, h₂.isUFormula]) h₁ + have ih₂ : P p₂ := + ih p₂ (by simp only [le_sup_iff, f]; left; exact le_of_lt <| by simp) + (by simp [h₁.isUFormula, h₂.isUFormula]) h₂ + exact hand _ _ h₁ h₂ ih₁ ih₂ + · have ih₁ : P p₁ := + ih p₁ (by simp only [le_sup_iff, f]; left; exact le_of_lt <| by simp) + (by simp [h₁.isUFormula, h₂.isUFormula]) h₁ + have ih₂ : P p₂ := + ih p₂ (by simp only [le_sup_iff, f]; left; exact le_of_lt <| by simp) + (by simp [h₁.isUFormula, h₂.isUFormula]) h₂ + exact hor _ _ h₁ h₂ ih₁ ih₂ + · have h₁ : IsSemiformula L 2 p₁ := by simpa [one_add_one_eq_two] using h₁ + have : P (free1 L p₁) := + ih (free1 L p₁) (by simp only [le_sup_iff, f]; right; simp [qqAll]) + (by simp [fomulaComplexity_free1 h₁, h₁.isUFormula]) h₁.free1 + exact hall _ h₁ this + · have h₁ : IsSemiformula L 2 p₁ := by simpa [one_add_one_eq_two] using h₁ + have : P (free1 L p₁) := + ih (free1 L p₁) (by simp only [le_sup_iff, f]; right; simp [qqExs]) + (by simp [fomulaComplexity_free1 h₁, h₁.isUFormula]) h₁.free1 + exact hexs _ h₁ this + +lemma IsFormula.sigma1_structural_induction₂_ss {P : V → Prop} (hP : Σ₁-Predicate P) + (hrel : ∀ k r v, L.IsRel k r → IsSemitermVec L k 1 v → P (^rel k r v)) + (hnrel : ∀ k r v, L.IsRel k r → IsSemitermVec L k 1 v → P (^nrel k r v)) (hverum : P ^⊤) + (hfalsum : P ^⊥) + (hand : ∀ p q, IsSemiformula L 1 p → IsSemiformula L 1 q → P p → P q → P (p ^⋏ q)) + (hor : ∀ p q, IsSemiformula L 1 p → IsSemiformula L 1 q → P p → P q → P (p ^⋎ q)) + (hall : ∀ p, IsSemiformula L 2 p → P (free1 L <| shift L <| shift L <| p) → P (^∀ p)) + (hexs : ∀ p, IsSemiformula L 2 p → P (free1 L <| shift L <| shift L <| p) → P (^∃ p)) {p} : + IsSemiformula L 1 p → P p := + by + have hm : Σ₁-Function₁[V] formulaComplexity L := inferInstance + let f : V → V := fun p ↦ max p (free1 L <| shift L <| shift L <| (π₂(p - 1))) + have hf : Σ₁-Function₁ f := by unfold f; definability + apply measured_bounded_sigma1_order_induction hm hf ?_ ?_ p + · definability + intro p ih hp + rcases IsSemiformula.case_iff.mp hp with + (⟨k, R, v, hR, hv, rfl⟩ | ⟨k, R, v, hR, hv, rfl⟩ | rfl | rfl | ⟨p₁, p₂, h₁, h₂, rfl⟩ | + ⟨p₁, p₂, h₁, h₂, rfl⟩ | ⟨p₁, h₁, rfl⟩ | ⟨p₁, h₁, rfl⟩) + · exact hrel _ _ _ hR hv + · exact hnrel _ _ _ hR hv + · exact hverum + · exact hfalsum + · have ih₁ : P p₁ := + ih p₁ (by simp only [le_sup_iff, f]; left; exact le_of_lt <| by simp) + (by simp [h₁.isUFormula, h₂.isUFormula]) h₁ + have ih₂ : P p₂ := + ih p₂ (by simp only [le_sup_iff, f]; left; exact le_of_lt <| by simp) + (by simp [h₁.isUFormula, h₂.isUFormula]) h₂ + exact hand _ _ h₁ h₂ ih₁ ih₂ + · have ih₁ : P p₁ := + ih p₁ (by simp only [le_sup_iff, f]; left; exact le_of_lt <| by simp) + (by simp [h₁.isUFormula, h₂.isUFormula]) h₁ + have ih₂ : P p₂ := + ih p₂ (by simp only [le_sup_iff, f]; left; exact le_of_lt <| by simp) + (by simp [h₁.isUFormula, h₂.isUFormula]) h₂ + exact hor _ _ h₁ h₂ ih₁ ih₂ + · have h₁ : IsSemiformula L 2 p₁ := by simpa [one_add_one_eq_two] using h₁ + have : P (free1 L <| shift L <| shift L <| p₁) := + ih (free1 L <| shift L <| shift L <| p₁) + (by simp only [le_sup_iff, f]; right; simp [qqAll]) + (by + rw [fomulaComplexity_free1 h₁.shift.shift, + formulaComplexity_shift h₁.shift.isUFormula, formulaComplexity_shift h₁.isUFormula]; + simp [h₁.isUFormula]) + h₁.shift.shift.free1 + exact hall _ h₁ this + · have h₁ : IsSemiformula L 2 p₁ := by simpa [one_add_one_eq_two] using h₁ + have : P (free1 L <| shift L <| shift L <| p₁) := + ih (free1 L <| shift L <| shift L <| p₁) + (by simp only [le_sup_iff, f]; right; simp [qqExs]) + (by + rw [fomulaComplexity_free1 h₁.shift.shift, + formulaComplexity_shift h₁.shift.isUFormula, formulaComplexity_shift h₁.isUFormula]; + simp [h₁.isUFormula]) + h₁.shift.shift.free1 + exact hexs _ h₁ this + +namespace ObjectArithmetic + +/-- The qq EQ construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic`. -/ +noncomputable def qqEQ (x y : V) : V := + ^rel 2 (eqIndex : V) ?[x, y] + +/-- The qq NEQ construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic`. -/ +noncomputable def qqNEQ (x y : V) : V := + ^nrel 2 (eqIndex : V) ?[x, y] + +/-- The qq LT construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic`. -/ +noncomputable def qqLT (x y : V) : V := + ^rel 2 (ltIndex : V) ?[x, y] + +/-- The qq NLT construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic`. -/ +noncomputable def qqNLT (x y : V) : V := + ^nrel 2 (ltIndex : V) ?[x, y] + +/-- +The «term ^= » construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic`. -/ +notation:75 x:75 " ^= " y:76 => qqEQ x y + +/-- +The «term ^≠ » construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic`. -/ +notation:75 x:75 " ^≠ " y:76 => qqNEQ x y + +/-- +The «term ^< » construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic`. -/ +notation:78 x:78 " ^< " y:79 => qqLT x y + +/-- +The «term ^≮ » construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic`. -/ +notation:78 x:78 " ^≮ " y:79 => qqNLT x y + +@[simp] +lemma lt_qqEQ_left (x y : V) : x < x ^= y := by + simpa using! + nth_lt_qqRel_of_lt (i := 0) (k := 2) (r := (eqIndex : V)) (v := ?[x, y]) (by simp) + +@[simp] +lemma lt_qqEQ_right (x y : V) : y < x ^= y := by + simpa using! + nth_lt_qqRel_of_lt (i := 1) (k := 2) (r := (eqIndex : V)) (v := ?[x, y]) (by simp) + +@[simp] +lemma lt_qqLT_left (x y : V) : x < x ^< y := by + simpa using! + nth_lt_qqRel_of_lt (i := 0) (k := 2) (r := (ltIndex : V)) (v := ?[x, y]) (by simp) + +@[simp] +lemma lt_qqLT_right (x y : V) : y < x ^< y := by + simpa using! + nth_lt_qqRel_of_lt (i := 1) (k := 2) (r := (ltIndex : V)) (v := ?[x, y]) (by simp) + +@[simp] +lemma lt_qqNEQ_left (x y : V) : x < x ^≠ y := by + simpa using! + nth_lt_qqNRel_of_lt (i := 0) (k := 2) (r := (eqIndex : V)) (v := ?[x, y]) (by simp) + +@[simp] +lemma lt_qqNEQ_right (x y : V) : y < x ^≠ y := by + simpa using! + nth_lt_qqNRel_of_lt (i := 1) (k := 2) (r := (eqIndex : V)) (v := ?[x, y]) (by simp) + +@[simp] +lemma lt_qqNLT_left (x y : V) : x < x ^≮ y := by + simpa using! + nth_lt_qqNRel_of_lt (i := 0) (k := 2) (r := (ltIndex : V)) (v := ?[x, y]) (by simp) + +@[simp] +lemma lt_qqNLT_right (x y : V) : y < x ^≮ y := by + simpa using! + nth_lt_qqNRel_of_lt (i := 1) (k := 2) (r := (ltIndex : V)) (v := ?[x, y]) (by simp) + +/-- The qq EQDef construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.qqEQDef : Σ₁.Semisentence 3 := + .mkSigma (“p x y. ∃ v, !mkVec₂Def v x y ∧ !qqRelDef p 2↑eqIndex v”) + +/-- The qq NEQDef construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.qqNEQDef : Σ₁.Semisentence 3 := + .mkSigma (“p x y. ∃ v, !mkVec₂Def v x y ∧ !qqNRelDef p 2↑eqIndex v”) + +/-- The qq LTDef construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.qqLTDef : Σ₁.Semisentence 3 := + .mkSigma (“p x y. ∃ v, !mkVec₂Def v x y ∧ !qqRelDef p 2↑ltIndex v”) + +/-- The qq NLTDef construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.qqNLTDef : Σ₁.Semisentence 3 := + .mkSigma (“p x y. ∃ v, !mkVec₂Def v x y ∧ !qqNRelDef p 2↑ltIndex v”) + +instance qqEQ_defined : Σ₁-Function₂ (qqEQ : V → V → V) via qqEQDef := + .mk fun v ↦ by simp [qqEQDef, numeral_eq_natCast, qqEQ] + +instance qqNEQ_defined : Σ₁-Function₂ (qqNEQ : V → V → V) via qqNEQDef := + .mk fun v ↦ by simp [qqNEQDef, numeral_eq_natCast, qqNEQ] + +instance qqLT_defined : Σ₁-Function₂ (qqLT : V → V → V) via qqLTDef := + .mk fun v ↦ by simp [qqLTDef, numeral_eq_natCast, qqLT] + +instance qqNLT_defined : Σ₁-Function₂ (qqNLT : V → V → V) via qqNLTDef := + .mk fun v ↦ by simp [qqNLTDef, numeral_eq_natCast, qqNLT] + +instance (Γ m) : Γ-[m + 1]-Function₂ (qqEQ : V → V → V) := + .of_sigmaOne qqEQ_defined.to_definable + +instance (Γ m) : Γ-[m + 1]-Function₂ (qqNEQ : V → V → V) := + .of_sigmaOne qqNEQ_defined.to_definable + +instance (Γ m) : Γ-[m + 1]-Function₂ (qqLT : V → V → V) := + .of_sigmaOne qqLT_defined.to_definable + +instance (Γ m) : Γ-[m + 1]-Function₂ (qqNLT : V → V → V) := + .of_sigmaOne qqNLT_defined.to_definable + +lemma neg_eq {t u : V} (ht : IsUTerm ℒₒᵣ t) (hu : IsUTerm ℒₒᵣ u) : neg ℒₒᵣ (t ^= u) = t ^≠ u := + by + simp only [qqEQ, qqNEQ] + rw [neg_rel (L := ℒₒᵣ) (by simp) (by simp [ht, hu])] + +lemma neg_neq {t u : V} (ht : IsUTerm ℒₒᵣ t) (hu : IsUTerm ℒₒᵣ u) : neg ℒₒᵣ (t ^≠ u) = t ^= u := + by + simp only [qqNEQ, qqEQ] + rw [neg_nrel (L := ℒₒᵣ) (by simp) (by simp [ht, hu])] + +lemma neg_lt {t u : V} (ht : IsUTerm ℒₒᵣ t) (hu : IsUTerm ℒₒᵣ u) : neg ℒₒᵣ (t ^< u) = t ^≮ u := + by + simp only [qqLT, qqNLT] + rw [neg_rel (L := ℒₒᵣ) (by simp) (by simp [ht, hu])] + +lemma neg_nlt {t u : V} (ht : IsUTerm ℒₒᵣ t) (hu : IsUTerm ℒₒᵣ u) : neg ℒₒᵣ (t ^≮ u) = t ^< u := + by + simp only [qqNLT, qqLT] + rw [neg_nrel (L := ℒₒᵣ) (by simp) (by simp [ht, hu])] + +lemma substs_eq {t u : V} (ht : IsUTerm ℒₒᵣ t) (hu : IsUTerm ℒₒᵣ u) : + subst ℒₒᵣ w (t ^= u) = (termSubst ℒₒᵣ w t) ^= (termSubst ℒₒᵣ w u) := + by + simp only [qqEQ] + rw [substs_rel (L := ℒₒᵣ) (by simp) (by simp [ht, hu])] + simp [termSubstVec_cons₂ ht hu] + +end ObjectArithmetic + +end Bootstrapping +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Formula/Iteration.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Formula/Iteration.lean new file mode 100644 index 000000000..a5087055f --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Formula/Iteration.lean @@ -0,0 +1,560 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Formula.Functions + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace FFL +namespace FirstOrder +namespace Semiformula + +variable {L : Language} {ξ : Type*} {n : ℕ} + +/-- The replicate construction in `FFL.FirstOrder.Semiformula`. -/ +def replicate (p : Semiformula L ξ n) : ℕ → Semiformula L ξ n + | 0 => p + | k + 1 => p ⋏ p.replicate k + +lemma replicate_zero (p : Semiformula L ξ n) : p.replicate 0 = p := by simp [replicate] + +lemma replicate_succ (p : Semiformula L ξ n) (k : ℕ) : + p.replicate (k + 1) = p ⋏ p.replicate k := by simp [replicate] + +/-- The weight construction in `FFL.FirstOrder.Semiformula`. -/ +def weight (k : ℕ) : Semiformula L ξ n := + (PointwiseComposition.List.conj (List.replicate k ⊤)) + +end Semiformula +end FirstOrder +end FFL + +namespace FFL +namespace FirstOrder +namespace Arithmetic +namespace Bootstrapping + +variable {V : Type*} [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +variable {L : Language} [L.Encodable] [L.LORDefinable] + +namespace QQConj + +/-- The blueprint construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.QQConj`. -/ +def blueprint : VecRec.Blueprint 0 + where + nil := .mkSigma (“y. !qqVerumDef y”) + adjoin := .mkSigma (“y p ps ih. !qqAndDef y p ih”) + +/-- The construction construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.QQConj`. -/ +noncomputable def construction : VecRec.Construction V blueprint + where + nil _ := ^⊤ + adjoin _ p _ ih := p ^⋏ ih + nil_defined := .mk fun v ↦ by simp [blueprint] + adjoin_defined := .mk fun v ↦ by simp [blueprint] + +end QQConj + +section qqConj + +open QQConj + +/-- The qq Conj construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def qqConj (ps : V) : V := + construction.result ![] ps + +/-- The qq Conj Graph construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +def qqConjGraph : Σ₁.Semisentence 2 := + blueprint.resultDef + +/-- The «term^⋀ » construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +scoped notation:65 "^⋀ " ps:66 => qqConj ps + +@[simp] +lemma qqConj_nil : ^⋀ (0 : V) = ^⊤ := by simp [qqConj, construction] + +@[simp] +lemma qqConj_cons (p ps : V) : ^⋀ (p ∷ ps) = p ^⋏ (^⋀ ps) := by simp [qqConj, construction] + +section + +instance qqConj.defined : Σ₁-Function₁[V] qqConj via qqConjGraph := + construction.result_defined + +instance qqConj.definable : Σ₁-Function₁ (qqConj : V → V) := + qqConj.defined.to_definable + +instance qqConj.definable' : Γ-[m + 1]-Function₁ (qqConj : V → V) := + .of_sigmaOne qqConj.definable + +end + +@[simp] +lemma qqConj_semiformula {n ps : V} : + IsSemiformula L n (^⋀ ps) ↔ (∀ i < len ps, IsSemiformula L n ps.[i]) := + by + induction ps using adjoin_ISigma1.sigma1_succ_induction + · definability + case nil => simp + case adjoin p ps + ih => + simp only [qqConj_cons, IsSemiformula.and, ih, len_adjoin] + constructor + · rintro ⟨hp, hps⟩ i hi + rcases zero_or_succ i with (rfl | ⟨i, rfl⟩) + · simpa using hp + · simpa using hps i (by simpa using hi) + · intro h + exact + ⟨by simpa using h 0 (by simp), fun i hi ↦ by simpa using h (i + 1) (by simpa using hi)⟩ + +@[simp] +lemma len_le_conj (ps : V) : len ps ≤ ^⋀ ps := + by + induction ps using adjoin_ISigma1.sigma1_succ_induction + · definability + case nil => simp [qqVerum] + case adjoin p ps ih => + simp only [len_adjoin, qqConj_cons, succ_le_iff_lt] + exact lt_of_le_of_lt ih (by simp) + +end qqConj + +namespace QQDisj + +/-- The blueprint construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.QQDisj`. -/ +def blueprint : VecRec.Blueprint 0 + where + nil := .mkSigma (“y. !qqFalsumDef y”) + adjoin := .mkSigma (“y p ps ih. !qqOrDef y p ih”) + +/-- The construction construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.QQDisj`. -/ +noncomputable def construction : VecRec.Construction V blueprint + where + nil _ := ^⊥ + adjoin _ p _ ih := p ^⋎ ih + nil_defined := .mk fun v ↦ by simp [blueprint] + adjoin_defined := .mk fun v ↦ by simp [blueprint] + +end QQDisj + +section qqDisj + +open QQDisj + +/-- The qq Disj construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def qqDisj (ps : V) : V := + construction.result ![] ps + +/-- The qq Disj Graph construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +def qqDisjGraph : Σ₁.Semisentence 2 := + blueprint.resultDef + +/-- The «term^⋁ » construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +scoped notation:65 "^⋁ " ps:66 => qqDisj ps + +@[simp] +lemma qqDisj_nil : ^⋁ (0 : V) = ^⊥ := by simp [qqDisj, construction] + +@[simp] +lemma qqDisj_cons (p ps : V) : ^⋁ (p ∷ ps) = p ^⋎ (^⋁ ps) := by simp [qqDisj, construction] + +section + +instance qqDisj.defined : Σ₁-Function₁[V] qqDisj via qqDisjGraph := + construction.result_defined + +instance qqDisj.definable : Σ₁-Function₁[V] qqDisj := + qqDisj.defined.to_definable + +instance qqDisj.definable' : Γ-[m + 1]-Function₁[V] qqDisj := + .of_sigmaOne qqDisj.definable + +end + +@[simp] +lemma qqDisj_semiformula {ps : V} : + IsSemiformula L n (^⋁ ps) ↔ (∀ i < len ps, IsSemiformula L n ps.[i]) := + by + induction ps using adjoin_ISigma1.sigma1_succ_induction + · definability + case nil => simp + case adjoin p ps + ih => + simp only [qqDisj_cons, IsSemiformula.or, ih, len_adjoin] + constructor + · rintro ⟨hp, hps⟩ i hi + rcases zero_or_succ i with (rfl | ⟨i, rfl⟩) + · simpa using hp + · simpa using hps i (by simpa using hi) + · intro h + exact + ⟨by simpa using h 0 (by simp), fun i hi ↦ by simpa using h (i + 1) (by simpa using hi)⟩ + +end qqDisj + +namespace ObjectArithmetic + +/-! +### Disjunction of sequential substution + +`disjSeqSubst w p k = subst (k ∷ w) p ^⋎ ⋯ ^⋎ subst (0 ∷ w) p ^⋎ ⊥` + + -/ +-- TOFO: remove + +section disjSeqSubst + +namespace DisjSeqSubst + +/-- The blueprint construction in +`FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic.DisjSeqSubst`. -/ +noncomputable def blueprint : PR.Blueprint 2 + where + zero := .mkSigma (“y w p. !qqFalsumDef y”) + succ := + .mkSigma + (“y ih k w p. + ∃ numeral, + !numeralGraph numeral k ∧ + ∃ v, !adjoinDef v numeral w ∧ ∃ q, !(substsGraph ℒₒᵣ)q v p ∧ !qqOrDef y q ih”) + +/-- The construction construction in +`FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic.DisjSeqSubst`. -/ +noncomputable def construction : PR.Construction V blueprint + where + zero _ := ^⊥ + succ param k ih := (subst ℒₒᵣ (numeral k ∷ param 0) (param 1)) ^⋎ ih + zero_defined := .mk fun v ↦ by simp [blueprint] + succ_defined := .mk fun v ↦ by simp [blueprint] + +end DisjSeqSubst + +open DisjSeqSubst + +/-- +The disj Seq Subst construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic`. -/ +noncomputable def disjSeqSubst (w p k : V) : V := + construction.result ![w, p] k + +@[simp] +lemma disjSeqSubst_zero (w p : V) : disjSeqSubst w p 0 = ^⊥ := by + simp [disjSeqSubst, construction] + +@[simp] +lemma disjSeqSubst_succ (w p k : V) : + disjSeqSubst w p (k + 1) = subst ℒₒᵣ (numeral k ∷ w) p ^⋎ disjSeqSubst w p k := by + simp [disjSeqSubst, construction] + +/-- The disj Seq Subst Graph construction in +`FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic`. -/ +noncomputable def disjSeqSubstGraph : Σ₁.Semisentence 4 := + blueprint.resultDef |>.rew (Rew.subst ![#0, #3, #1, #2]) + +section + +instance disjSeqSubst.defined : Σ₁-Function₃[V] disjSeqSubst via disjSeqSubstGraph := + .mk fun v ↦ by simp [construction.result_defined_iff, disjSeqSubstGraph, disjSeqSubst] + +instance disjSeqSubst.definable : Σ₁-Function₃[V] disjSeqSubst := + disjSeqSubst.defined.to_definable + +instance disjSeqSubst.definable' : Γ-[m + 1]-Function₃[V] disjSeqSubst := + .of_sigmaOne disjSeqSubst.definable + +end + +lemma + _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.Bootstrapping.IsSemiformula.disjSeqSubst + {n m w p : V} (hw : IsSemitermVec ℒₒᵣ n m w) (hp : IsSemiformula ℒₒᵣ (n + 1) p) (k : V) : + IsSemiformula ℒₒᵣ m (disjSeqSubst w p k) := + by + induction k using ISigma1.sigma1_succ_induction + · definability + case zero => simp + case succ k ih => simpa [ih] using hp.subst <| hw.adjoin (numeral_semiterm m k) + +lemma substs_conj_disjSeqSubst {n m l v w p : V} (hp : IsSemiformula ℒₒᵣ (n + 1) p) + (hw : IsSemitermVec ℒₒᵣ n m w) (hv : IsSemitermVec ℒₒᵣ m l v) (k : V) : + subst ℒₒᵣ v (disjSeqSubst w p k) = disjSeqSubst (termSubstVec ℒₒᵣ n v w) p k := + by + induction k using ISigma1.sigma1_succ_induction + · definability + case zero => simp + case succ k + ih => + have hkw : IsSemitermVec ℒₒᵣ (n + 1) m (numeral k ∷ w) := hw.adjoin (numeral_semiterm m k) + have ha : IsSemiformula ℒₒᵣ m (disjSeqSubst w p k) := hp.disjSeqSubst hw k + rw [disjSeqSubst_succ, substs_or (hp.subst hkw).isUFormula ha.isUFormula, + substs_substs hp hv hkw, termSubstVec_cons (by simp) hw.isUTerm, numeral_substs hv] + simp [ih] + +end disjSeqSubst + +section substItr + +namespace SubstItr + +/-- The blueprint construction in +`FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic.SubstItr`. -/ +noncomputable def blueprint : PR.Blueprint 2 + where + zero := .mkSigma (“y w p. y = 0”) + succ := + .mkSigma + (“y ih k w p. + ∃ numeral, + !numeralGraph numeral k ∧ + ∃ v, !adjoinDef v numeral w ∧ ∃ sp, !(substsGraph ℒₒᵣ)sp v p ∧ !adjoinDef y sp ih”) + +/-- The construction construction in +`FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic.SubstItr`. -/ +noncomputable def construction : PR.Construction V blueprint + where + zero _ := 0 + succ param k ih := (subst ℒₒᵣ (numeral k ∷ param 0) (param 1)) ∷ ih + zero_defined := .mk fun v ↦ by simp [blueprint] + succ_defined := .mk fun v ↦ by simp [blueprint] + +end SubstItr + +open SubstItr + +/-- The subst Itr construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic`. -/ +noncomputable def substItr (w p k : V) : V := + construction.result ![w, p] k + +@[simp] +lemma substItr_zero (w p : V) : substItr w p 0 = 0 := by simp [substItr, construction] + +@[simp] +lemma substItr_succ (w p k : V) : + substItr w p (k + 1) = subst ℒₒᵣ (numeral k ∷ w) p ∷ substItr w p k := by + simp [substItr, construction] + +section + +/-- +The subst Itr Graph construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic`. -/ +noncomputable def substItrGraph : Σ₁.Semisentence 4 := + blueprint.resultDef |>.rew (Rew.subst ![#0, #3, #1, #2]) + +instance substItr.defined : Σ₁-Function₃[V] substItr via substItrGraph := + .mk fun v ↦ by simp [construction.result_defined_iff, substItrGraph, substItr] + +instance substItr.definable : Σ₁-Function₃ (substItr : V → V → V → V) := + substItr.defined.to_definable + +instance substItr.definable' : Γ-[m + 1]-Function₃ (substItr : V → V → V → V) := + .of_sigmaOne substItr.definable + +end + +@[simp] +lemma len_substItr (w p k : V) : len (substItr w p k) = k := + by + induction k using ISigma1.sigma1_succ_induction + · definability + case zero => simp + case succ k ih => simp [ih] + +@[simp] +lemma substItr_nth (w p k : V) {i} (hi : i < k) : + (substItr w p k).[i] = subst ℒₒᵣ (numeral (k - (i + 1)) ∷ w) p := + by + induction k using ISigma1.sigma1_succ_induction generalizing i + · definability + case zero => simp at hi + case succ k ih => + simp only [substItr_succ] + rcases zero_or_succ i with (rfl | ⟨i, rfl⟩) + · simp + · simp [ih (by simpa using hi)] + +lemma + _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.Bootstrapping.IsSemiformula.substItrConj + {m n w p : V} (hp : IsSemiformula ℒₒᵣ (n + 1) p) (hw : IsSemitermVec ℒₒᵣ n m w) (k : V) : + IsSemiformula ℒₒᵣ m (^⋀ substItr w p k) := + by + simp only [qqConj_semiformula, len_substItr] + intro i hi + simp only [hi, substItr_nth] + apply hp.subst (by simp [hw]) + +lemma + _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.Bootstrapping.IsSemiformula.substItrDisj + {m n w p : V} (hp : IsSemiformula ℒₒᵣ (n + 1) p) (hw : IsSemitermVec ℒₒᵣ n m w) (k : V) : + IsSemiformula ℒₒᵣ m (^⋁ substItr w p k) := + by + simp only [qqDisj_semiformula, len_substItr] + intro i hi + simp only [hi, substItr_nth] + apply hp.subst (by simp [hw]) + +lemma neg_conj_substItr {n w p k : V} (hp : IsSemiformula ℒₒᵣ (n + 1) p) + (hw : IsSemitermVec ℒₒᵣ n m w) : + neg ℒₒᵣ (^⋀ (substItr w p k)) = ^⋁ (substItr w (neg ℒₒᵣ p) k) := + by + induction k using ISigma1.sigma1_succ_induction + · definability + case zero => simp + case succ k ih => + simp only [substItr_succ, qqConj_cons, qqDisj_cons] + rw [neg_and (L := ℒₒᵣ), ← substs_neg hp (m := m), ih] + · simp [hw] + · exact IsSemiformula.isUFormula <| hp.subst (by simpa [hw]) + · exact IsSemiformula.isUFormula <| hp.substItrConj hw k + +lemma neg_disj_substItr {n w p k : V} (hp : IsSemiformula ℒₒᵣ (n + 1) p) + (hw : IsSemitermVec ℒₒᵣ n m w) : + neg ℒₒᵣ (^⋁ (substItr w p k)) = ^⋀ (substItr w (neg ℒₒᵣ p) k) := + by + induction k using ISigma1.sigma1_succ_induction + · definability + case zero => simp + case succ k ih => + simp only [substItr_succ, qqDisj_cons, qqConj_cons] + rw [neg_or (L := ℒₒᵣ), ← substs_neg hp (m := m), ih] + · simp [hw] + · apply IsSemiformula.isUFormula <| hp.subst (by simpa [hw]) + · apply IsSemiformula.isUFormula <| hp.substItrDisj hw k + +lemma shift_conj_substItr {n w p k : V} (hp : IsSemiformula ℒₒᵣ (n + 1) p) + (hw : IsSemitermVec ℒₒᵣ n m w) : + shift ℒₒᵣ (^⋀ (substItr w p k)) = ^⋀ (substItr (termShiftVec ℒₒᵣ n w) (shift ℒₒᵣ p) k) := + by + induction k using ISigma1.sigma1_succ_induction + · definability + case zero => simp + case succ k ih => + simp only [substItr_succ, qqConj_cons] + rw [shift_and (L := ℒₒᵣ), shift_substs hp (m := m), ih, termShiftVec_cons (L := ℒₒᵣ), + numeral_shift] + · simp + · exact hw.isUTerm + · exact hw.adjoin (numeral_semiterm m k) + · exact IsSemiformula.isUFormula <| hp.subst (by simpa [hw]) + · exact IsSemiformula.isUFormula <| hp.substItrConj hw k + +lemma shift_disj_substItr {n w p k : V} (hp : IsSemiformula ℒₒᵣ (n + 1) p) + (hw : IsSemitermVec ℒₒᵣ n m w) : + shift ℒₒᵣ (^⋁ (substItr w p k)) = ^⋁ (substItr (termShiftVec ℒₒᵣ n w) (shift ℒₒᵣ p) k) := + by + induction k using ISigma1.sigma1_succ_induction + · definability + case zero => simp + case succ k ih => + simp only [substItr_succ, qqDisj_cons] + rw [shift_or (L := ℒₒᵣ), shift_substs hp (m := m), ih, termShiftVec_cons (L := ℒₒᵣ), + numeral_shift] + · simp + · exact hw.isUTerm + · exact hw.adjoin (numeral_semiterm m k) + · exact IsSemiformula.isUFormula <| hp.subst (by simpa [hw]) + · exact IsSemiformula.isUFormula <| hp.substItrDisj hw k + +lemma substs_conj_substItr {n m l w p k : V} (hp : IsSemiformula ℒₒᵣ (n + 1) p) + (hw : IsSemitermVec ℒₒᵣ n m w) (hv : IsSemitermVec ℒₒᵣ m l v) : + subst ℒₒᵣ v (^⋀ (substItr w p k)) = ^⋀ (substItr (termSubstVec ℒₒᵣ n v w) p k) := + by + induction k using ISigma1.sigma1_succ_induction + · definability + case zero => simp + case succ k + ih => + have hkw : IsSemitermVec ℒₒᵣ (n + 1) m (numeral k ∷ w) := by simp [hw] + have ha : IsSemiformula ℒₒᵣ m (^⋀ substItr w p k) := + by + simp only [qqConj_semiformula, len_substItr] + intro i hi; simpa [hi] using hp.subst (hw.adjoin (by simp)) + simp only [substItr_succ, qqConj_cons] + rw [substs_and (hp.subst hkw).isUFormula ha.isUFormula, substs_substs hp hv hkw, + termSubstVec_cons (by simp) hw.isUTerm, numeral_substs hv] + simp [ih] + +lemma substs_disj_substItr {n m l w p k : V} (hp : IsSemiformula ℒₒᵣ (n + 1) p) + (hw : IsSemitermVec ℒₒᵣ n m w) (hv : IsSemitermVec ℒₒᵣ m l v) : + subst ℒₒᵣ v (^⋁ (substItr w p k)) = ^⋁ (substItr (termSubstVec ℒₒᵣ n v w) p k) := + by + induction k using ISigma1.sigma1_succ_induction + · definability + case zero => simp + case succ k + ih => + have hkw : IsSemitermVec ℒₒᵣ (n + 1) m (numeral k ∷ w) := by simp [hw] + have ha : IsSemiformula ℒₒᵣ m (^⋁ substItr w p k) := + by + simp only [qqDisj_semiformula, len_substItr] + intro i hi; simpa [hi] using hp.subst (hw.adjoin (by simp)) + simp only [substItr_succ, qqDisj_cons] + rw [substs_or (hp.subst hkw).isUFormula ha.isUFormula, substs_substs hp hv hkw, + termSubstVec_cons (by simp) hw.isUTerm, numeral_substs hv] + simp [ih] + +end substItr + +end ObjectArithmetic + +section verums + +/-- The qq Verums construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def qqVerums (k : V) : V := + ^⋀ repeatVec ^⊤ k + +/-- The qq Verums Graph construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +def qqVerumsGraph : Σ₁.Semisentence 2 := + .mkSigma + (“y k. ∃ verum, !qqVerumDef verum ∧ ∃ vs, !repeatVecDef vs verum k ∧ !qqConjGraph y vs”) + +@[simp] +lemma le_qqVerums (k : V) : k ≤ qqVerums k := by + simpa [qqVerums] using len_le_conj (repeatVec ^⊤ k) + +section + +instance qqVerums.defined : Σ₁-Function₁[V] qqVerums via qqVerumsGraph := + .mk fun v ↦ by simp [qqVerumsGraph]; rfl + +instance qqVerums.definable : Σ₁-Function₁[V] qqVerums := + qqVerums.defined.to_definable + +instance qqVerums.definable' : Γ-[m + 1]-Function₁[V] qqVerums := + .of_sigmaOne qqVerums.definable + +end + +@[simp] +protected lemma IsSemiformula.qqVerums (k : V) : IsSemiformula L n (qqVerums k) := + by + simp only [qqVerums, qqConj_semiformula, len_repeatVec] + intro i hi; simp [nth_repeatVec _ _ hi] + +@[simp] +lemma qqVerums_zero : qqVerums (0 : V) = ^⊤ := by simp [qqVerums] + +@[simp] +lemma qqVerums_succ (k : V) : qqVerums (k + 1) = ^⊤ ^⋏ qqVerums k := by simp [qqVerums] + +end verums + +end Bootstrapping +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Formula/Typed.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Formula/Typed.lean new file mode 100644 index 000000000..7b137a421 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Formula/Typed.lean @@ -0,0 +1,706 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Term.Typed +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Formula.Iteration + +/-! Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section +/-! +# Typed Formalized Semiformula/Formula +-/ + +namespace FFL +namespace FirstOrder +namespace Arithmetic +namespace Bootstrapping + +variable {V : Type*} [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +variable {L : Language} [L.Encodable] [L.LORDefinable] + +lemma sub_succ_lt_self {a b : V} (h : b < a) : a - (b + 1) < a := by + simp [tsub_lt_iff_left (succ_le_iff_lt.mpr h)] + +lemma sub_succ_lt_selfs {a b : V} (h : b < a) : a - (a - (b + 1) + 1) = b := + by + rw [← Arithmetic.sub_sub] + apply sub_remove_left + apply sub_remove_left + rw [← add_sub_of_le (succ_le_iff_lt.mpr h)] + simp + +section typed_formula + +variable (V L) + +/-- First-order formulas with separate bound and free variables. -/ +structure Semiformula (n : ℕ) where + /-- The val construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.Semiformula`. -/ + val : V + isSemiformula : IsSemiformula L ↑n val + +attribute [simp] Semiformula.isSemiformula + +/-- The Formula construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +abbrev Formula := + Semiformula (V := V) L 0 + +variable {L V} + +variable {k n m : ℕ} + +@[simp] +lemma Semiformula.isSemiformula_zero (φ : Formula V L) : IsSemiformula L 0 φ.val := by + simpa using φ.isSemiformula + +@[simp] +lemma Semiformula.isSemiformula_one (φ : Semiformula V L 1) : IsSemiformula L 1 φ.val := by + simpa using φ.isSemiformula + +@[simp] +lemma Semiformula.isSemiformula_succ (φ : Semiformula V L (n + 1)) : + IsSemiformula L (↑n + 1 : V) φ.val := by simpa using φ.isSemiformula + +@[simp] +lemma Semiformula.isUFormula (φ : Semiformula V L n) : IsUFormula L φ.val := + φ.isSemiformula.isUFormula + +/-- The rel construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.Semiformula`. -/ +noncomputable def Semiformula.rel (R : L.Rel k) (v : SemitermVec V L k n) : Semiformula V L n := + ⟨^rel ↑k ⌜R⌝ v.val, by simp⟩ + +/-- The nrel construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.Semiformula`. -/ +noncomputable def Semiformula.nrel (R : L.Rel k) (v : SemitermVec V L k n) : + Semiformula V L n := + ⟨^nrel ↑k ⌜R⌝ v.val, by simp⟩ + +@[simp] +lemma Semiformula.rel_val (R : L.Rel k) (v : SemitermVec V L k n) : + (Semiformula.rel R v).val = ^rel ↑k ⌜R⌝ v.val := + rfl + +@[simp] +lemma Semiformula.nrel_val (R : L.Rel k) (v : SemitermVec V L k n) : + (Semiformula.nrel R v).val = ^nrel ↑k ⌜R⌝ v.val := + rfl + +/-- The inst Logical Connective Semiformula construction in +`FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable scoped instance : LogicalConnective (Semiformula V L n) + where + wedge (φ ψ) := ⟨φ.val ^⋏ ψ.val, by simp⟩ + vee (φ ψ) := ⟨φ.val ^⋎ ψ.val, by simp⟩ + arrow (φ ψ) := ⟨imp L φ.val ψ.val, by simp⟩ + tilde (φ) := ⟨neg L φ.val, by simp⟩ + +/-- The inst Logical Neutral Semiformula construction in +`FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable scoped instance : LogicalNeutral (Semiformula V L n) + where + top := ⟨^⊤, by simp⟩ + bot := ⟨^⊥, by simp⟩ + +noncomputable instance : LCWQ (Semiformula V L) + where + connectives := inferInstance + neutrals := inferInstance + all φ := ⟨^∀ φ.val, by simp⟩ + exs φ := ⟨^∃ φ.val, by simp⟩ + +/-- The verums construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def verums (k : V) : Semiformula V L n := + ⟨qqVerums k, by simp⟩ + +namespace Semiformula + +@[simp] +lemma val_verum : (⊤ : Semiformula V L n).val = ^⊤ := + rfl + +@[simp] +lemma val_falsum : (⊥ : Semiformula V L n).val = ^⊥ := + rfl + +@[simp] +lemma val_and (φ ψ : Semiformula V L n) : (φ ⋏ ψ).val = φ.val ^⋏ ψ.val := + rfl + +@[simp] +lemma val_or (φ ψ : Semiformula V L n) : (φ ⋎ ψ).val = φ.val ^⋎ ψ.val := + rfl + +@[simp] +lemma val_neg (φ : Semiformula V L n) : (∼φ).val = neg L φ.val := + rfl + +@[simp] +lemma val_imp (φ ψ : Semiformula V L n) : (φ ⇒ₗ ψ).val = imp L φ.val ψ.val := + rfl + +@[simp] +lemma val_all (φ : Semiformula V L (n + 1)) : (∀¹ φ).val = ^∀ φ.val := + rfl + +@[simp] +lemma val_exs (φ : Semiformula V L (n + 1)) : (∃¹ φ).val = ^∃ φ.val := + rfl + +@[simp] +lemma val_iff (φ ψ : Semiformula V L n) : (φ ⇔ₗ ψ).val = iff L φ.val ψ.val := + rfl + +lemma val_inj {φ ψ : Semiformula V L n} : φ.val = ψ.val ↔ φ = ψ := by rcases φ; rcases ψ; simp + +@[ext] +lemma ext {φ ψ : Semiformula V L n} (h : φ.val = ψ.val) : φ = ψ := + val_inj.mp h + +@[simp] +lemma and_inj {φ₁ φ₂ ψ₁ ψ₂ : Semiformula V L n} : φ₁ ⋏ φ₂ = ψ₁ ⋏ ψ₂ ↔ φ₁ = ψ₁ ∧ φ₂ = ψ₂ := by + simp [Semiformula.ext_iff] + +@[simp] +lemma or_inj {φ₁ φ₂ ψ₁ ψ₂ : Semiformula V L n} : φ₁ ⋎ φ₂ = ψ₁ ⋎ ψ₂ ↔ φ₁ = ψ₁ ∧ φ₂ = ψ₂ := by + simp [Semiformula.ext_iff] + +@[simp] +lemma all_inj {φ ψ : Semiformula V L (n + 1)} : ∀¹ φ = ∀¹ ψ ↔ φ = ψ := by + simp [Semiformula.ext_iff] + +@[simp] +lemma exs_inj {φ ψ : Semiformula V L (n + 1)} : ∃¹ φ = ∃¹ ψ ↔ φ = ψ := by + simp [Semiformula.ext_iff] + +@[simp] +lemma val_verums (k : V) : (verums k : Semiformula V L n).val = qqVerums k := + rfl + +@[simp] +lemma verums_zero : (verums 0 : Semiformula V L n) = ⊤ := by ext; simp + +@[simp] +lemma verums_succ (k : V) : (verums (k + 1) : Semiformula V L n) = ⊤ ⋏ verums k := by ext; simp + +instance : TildeInvolutive (Semiformula V L n) where tilde_involutive _ := by ext; simp + +instance : LogicalConnective.DeMorgan (Semiformula V L n) + where + and _ _ := by ext; simp + or _ _ := by ext; simp + imply _ _ := by ext; simp; rfl + +instance : LogicalNeutral.DeMorgan (Semiformula V L n) + where + verum := by ext; simp + falsum := by ext; simp + +@[simp] +lemma neg_all (φ : Semiformula V L (n + 1)) : ∼(∀¹ φ) = ∃¹ (∼φ) := by ext; simp +@[simp] +lemma neg_ex (φ : Semiformula V L (n + 1)) : ∼(∃¹ φ) = ∀¹ (∼φ) := by ext; simp + +@[simp] +lemma neg_rel (R : L.Rel k) (v : SemitermVec V L k n) : + ∼Semiformula.rel R v = Semiformula.nrel R v := by ext; simp +@[simp] +lemma neg_nrel (R : L.Rel k) (v : SemitermVec V L k n) : + ∼Semiformula.nrel R v = Semiformula.rel R v := by ext; simp + +lemma imp_def (φ ψ : Semiformula V L n) : φ ⇒ₗ ψ = ∼φ ⋎ ψ := by ext; simp [imp] + +/-- The shift construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.Semiformula`. -/ +noncomputable def shift (φ : Semiformula V L n) : Semiformula V L n := + ⟨Bootstrapping.shift L φ.val, φ.isSemiformula.shift⟩ + +/-- The subst construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.Semiformula`. -/ +noncomputable def subst (w : SemitermVec V L n m) (φ : Semiformula V L n) : Semiformula V L m := + ⟨Bootstrapping.subst L w.val φ.val, φ.isSemiformula.subst w.isSemitermVec⟩ + +@[simp] +lemma val_shift (φ : Semiformula V L n) : φ.shift.val = Bootstrapping.shift L φ.val := + rfl +@[simp] +lemma val_substs (φ : Semiformula V L n) (w : SemitermVec V L n m) : + (φ.subst w).val = Bootstrapping.subst L w.val φ.val := + rfl + +@[simp] +lemma shift_verum : (⊤ : Semiformula V L n).shift = ⊤ := by ext; simp [shift] +@[simp] +lemma shift_falsum : (⊥ : Semiformula V L n).shift = ⊥ := by ext; simp [shift] +@[simp] lemma shift_and (φ ψ : Semiformula V L n) : (φ ⋏ ψ).shift = φ.shift ⋏ ψ.shift := by + ext + simp [shift] +@[simp] lemma shift_or (φ ψ : Semiformula V L n) : (φ ⋎ ψ).shift = φ.shift ⋎ ψ.shift := by + ext + simp [shift] +@[simp] lemma shift_all (φ : Semiformula V L (n + 1)) : (∀¹ φ).shift = ∀¹ φ.shift := by + ext + simp [shift] +@[simp] lemma shift_exs (φ : Semiformula V L (n + 1)) : (∃¹ φ).shift = ∃¹ φ.shift := by + ext + simp [shift] +@[simp] +lemma shift_rel (R : L.Rel k) (v : SemitermVec V L k n) : + (rel R v).shift = rel R (Semiterm.shift↗ v) := by ext; simp +@[simp] +lemma shift_nrel (R : L.Rel k) (v : SemitermVec V L k n) : + (nrel R v).shift = nrel R (Semiterm.shift↗ v) := by ext; simp + +lemma neg_inj {φ ψ : Semiformula V L n} : ∼φ = ∼ψ ↔ φ = ψ := + ⟨by intro h; simpa using congr_arg (∼·) h, by rintro rfl; rfl⟩ + +@[simp] +lemma imp_inj {φ₁ φ₂ ψ₁ ψ₂ : Semiformula V L n} : φ₁ ⇒ₗ φ₂ = ψ₁ ⇒ₗ ψ₂ ↔ φ₁ = ψ₁ ∧ φ₂ = ψ₂ := by + simp [imp_def] + +@[simp] lemma shift_neg (φ : Semiformula V L n) : (∼φ).shift = ∼(φ.shift) := by + ext; simp [shift, val_neg]; simp [Bootstrapping.shift_neg φ.isSemiformula] + +@[simp] +lemma shift_imp (φ ψ : Semiformula V L n) : (φ ⇒ₗ ψ).shift = φ.shift ⇒ₗ ψ.shift := by + simp [imp_def] +@[simp] +lemma shift_iff (φ ψ : Semiformula V L n) : (φ ⇔ₗ ψ).shift = φ.shift ⇔ₗ ψ.shift := by + simp [LogicalConnective.iff] + +@[simp] lemma substs_verum (w : SemitermVec V L n m) : (⊤ : Semiformula V L n).subst w = ⊤ := by + ext; simp [subst] + +@[simp] lemma substs_falsum (w : SemitermVec V L n m) : (⊥ : Semiformula V L n).subst w = ⊥ := + by ext; simp [subst] + +@[simp] +lemma substs_and (w : SemitermVec V L n m) (φ ψ : Semiformula V L n) : + (φ ⋏ ψ).subst w = φ.subst w ⋏ ψ.subst w := by ext; simp [subst] +@[simp] +lemma substs_or (w : SemitermVec V L n m) (φ ψ : Semiformula V L n) : + (φ ⋎ ψ).subst w = φ.subst w ⋎ ψ.subst w := by ext; simp [subst] +@[simp] lemma substs_all (w : SemitermVec V L n m) (φ : Semiformula V L (n + 1)) : + (∀¹ φ).subst w = ∀¹ (φ.subst w.q) := by + ext; simp [subst, Semiterm.bvar, qVec, SemitermVec.q, w.isSemitermVec.lh] +@[simp] lemma substs_ex (w : SemitermVec V L n m) (φ : Semiformula V L (n + 1)) : + (∃¹ φ).subst w = ∃¹ (φ.subst w.q) := by + ext; simp [subst, Semiterm.bvar, qVec, SemitermVec.q, w.isSemitermVec.lh] +@[simp] +lemma substs_rel (w : SemitermVec V L n m) (R : L.Rel k) (v : SemitermVec V L k n) : + (rel R v).subst w = rel R ((Semiterm.subst w)↗ v) := by ext; simp +@[simp] +lemma substs_nrel (w : SemitermVec V L n m) (R : L.Rel k) (v : SemitermVec V L k n) : + (nrel R v).subst w = nrel R ((Semiterm.subst w)↗ v) := by ext; simp + +@[simp] lemma substs_neg (w : SemitermVec V L n m) (φ : Semiformula V L n) : (∼φ).subst w = + ∼(φ.subst w) := by + ext; simp [subst, val_neg, Bootstrapping.substs_neg φ.isSemiformula w.isSemitermVec] + +@[simp] +lemma substs_imp (w : SemitermVec V L n m) (φ ψ : Semiformula V L n) : + (φ ⇒ₗ ψ).subst w = φ.subst w ⇒ₗ ψ.subst w := by simp [imp_def] +@[simp] +lemma substs_imply (w : SemitermVec V L n m) (φ ψ : Semiformula V L n) : + (φ ⇔ₗ ψ).subst w = φ.subst w ⇔ₗ ψ.subst w := by simp [LogicalConnective.iff] + +@[simp] +lemma substs_ball (t) (w : SemitermVec V L n m) (φ : Semiformula V L (n + 1)) : + (∀¹[t] φ).subst w = ∀¹[t.subst w.q] (φ.subst w.q) := by simp [ball] +@[simp] +lemma substs_bexs (t) (w : SemitermVec V L n m) (φ : Semiformula V L (n + 1)) : + (∃¹[t] φ).subst w = ∃¹[t.subst w.q] (φ.subst w.q) := by simp [bexs] + +lemma subst_eq_self {n : ℕ} (w : SemitermVec V L n n) (φ : Semiformula V L n) (H : ∀ i, w i = + Semiterm.bvar i) : + φ.subst w = φ := by + suffices ∀ i < ↑n, w.val.[i] = ^#i by + ext; simp only [Semiformula.val_substs]; rw [Bootstrapping.subst_eq_self φ.isSemiformula + w.isSemitermVec]; simpa + intro i hi + rcases eq_fin_of_lt_nat hi with ⟨i, rfl⟩ + simpa using congr_arg Semiterm.val <| H i + +@[simp] +lemma subst_eq_self₁ (φ : Semiformula V L 1) : φ.subst ![Semiterm.bvar 0] = φ := + by + apply subst_eq_self + simp + +@[simp] +lemma subst_nil_eq_self (w : SemitermVec V L 0 0) (φ : Semiformula V L 0) : φ.subst w = φ := + subst_eq_self _ _ (by simp) + +lemma shift_substs (w : SemitermVec V L n m) (φ : Semiformula V L n) : + (φ.subst w).shift = φ.shift.subst (Semiterm.shift↗ w) := by ext; simp + [Bootstrapping.shift_substs φ.isSemiformula w.isSemitermVec] + +lemma substs_substs {n m l : ℕ} (v : SemitermVec V L m l) (w : SemitermVec V L n m) (φ : + Semiformula V L n) : + (φ.subst w).subst v = φ.subst ((Semiterm.subst v)↗ w) := by + ext; simp [Bootstrapping.substs_substs φ.isSemiformula v.isSemitermVec w.isSemitermVec] + +/-- The free construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.Semiformula`. -/ +noncomputable def free (φ : Semiformula V L 1) : Formula V L := + φ.shift.subst ![Semiterm.fvar 0] + +@[simp] +lemma free_val (φ : Semiformula V L 1) : φ.free.val = Bootstrapping.free L φ.val := by + simp [free]; rfl + +/-- The free1 construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.Semiformula`. -/ +noncomputable def free1 (φ : Semiformula V L 2) : Semiformula V L 1 := + φ.shift.subst ![Semiterm.fvar 0, Semiterm.bvar 0] + +@[simp] +lemma free1_val (φ : Semiformula V L 2) : φ.free1.val = Bootstrapping.free1 L φ.val := by + simp [free1]; rfl + +open Bootstrapping.ObjectArithmetic + +/-- The subst Itr Conj construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.Semiformula`. -/ +noncomputable def substItrConj (w : SemitermVec V ℒₒᵣ m n) (φ : Semiformula V ℒₒᵣ (m + 1)) + (z : V) : Semiformula V ℒₒᵣ n := + ⟨^⋀ Bootstrapping.ObjectArithmetic.substItr w.val φ.val z, + by + have : IsSemiformula ℒₒᵣ (↑m + 1 : V) φ.val := by simp + exact this.substItrConj w.isSemitermVec z⟩ + +/-- The subst Itr Disj construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.Semiformula`. -/ +noncomputable def substItrDisj (w : SemitermVec V ℒₒᵣ m n) (φ : Semiformula V ℒₒᵣ (m + 1)) + (z : V) : Semiformula V ℒₒᵣ n := + ⟨^⋁ Bootstrapping.ObjectArithmetic.substItr w.val φ.val z, + by + have : IsSemiformula ℒₒᵣ (↑m + 1 : V) φ.val := by simp + exact this.substItrDisj w.isSemitermVec z⟩ + +@[simp] +lemma substItrConj_val (w : SemitermVec V ℒₒᵣ m n) (φ : Semiformula V ℒₒᵣ (m + 1)) (z : V) : + (φ.substItrConj w z).val = ^⋀ Bootstrapping.ObjectArithmetic.substItr w.val φ.val z := + rfl + +@[simp] +lemma substItrDisj_val (w : SemitermVec V ℒₒᵣ m n) (φ : Semiformula V ℒₒᵣ (m + 1)) (z : V) : + (φ.substItrDisj w z).val = ^⋁ Bootstrapping.ObjectArithmetic.substItr w.val φ.val z := + rfl + +@[simp] +lemma substItrConj_zero (w : SemitermVec V ℒₒᵣ m n) (φ : Semiformula V ℒₒᵣ (m + 1)) : + φ.substItrConj w 0 = ⊤ := by ext; simp + +@[simp] lemma substItrConj_succ (w : SemitermVec V ℒₒᵣ m n) (φ : Semiformula V ℒₒᵣ (m + 1)) (z : + V) : + φ.substItrConj w (z + 1) = φ.subst (typedNumeral z :> w) ⋏ φ.substItrConj w z := by ext; simp + +@[simp] +lemma substItrConj_one (w : SemitermVec V ℒₒᵣ m n) (φ : Semiformula V ℒₒᵣ (m + 1)) : + φ.substItrConj w 1 = φ.subst (typedNumeral 0 :> w) ⋏ ⊤ := by + simpa using substItrConj_succ w φ 0 + +@[simp] +lemma substItrDisj_zero (w : SemitermVec V ℒₒᵣ m n) (φ : Semiformula V ℒₒᵣ (m + 1)) : + φ.substItrDisj w 0 = ⊥ := by ext; simp + +@[simp] lemma substItrDisj_succ (w : SemitermVec V ℒₒᵣ m n) (φ : Semiformula V ℒₒᵣ (m + 1)) (z : + V) : + φ.substItrDisj w (z + 1) = φ.subst (typedNumeral z :> w) ⋎ φ.substItrDisj w z := by ext; simp + +@[simp] +lemma substItrDisj_one (w : SemitermVec V ℒₒᵣ m n) (φ : Semiformula V ℒₒᵣ (m + 1)) : + φ.substItrDisj w 1 = φ.subst (typedNumeral 0 :> w) ⋎ ⊥ := by + simpa using substItrDisj_succ w φ 0 + +@[simp] lemma substItrConj_neg (w : SemitermVec V ℒₒᵣ m n) (φ : Semiformula V ℒₒᵣ (m + 1)) (z : V) : + ∼(φ.substItrConj w z) = (∼φ).substItrDisj w z := by + ext; simp [substItrConj, substItrDisj, neg_conj_substItr φ.isSemiformula w.isSemitermVec] + +@[simp] lemma substItrDisj_neg (w : SemitermVec V ℒₒᵣ m n) (φ : Semiformula V ℒₒᵣ (m + 1)) (z : V) : + ∼(φ.substItrDisj w z) = (∼φ).substItrConj w z := by + ext; simp [substItrConj, substItrDisj, neg_disj_substItr φ.isSemiformula w.isSemitermVec] + +@[simp] +lemma substItrConj_substs (v : SemitermVec V ℒₒᵣ n k) (w : SemitermVec V ℒₒᵣ m n) + (φ : Semiformula V ℒₒᵣ (m + 1)) (z : V) : + (φ.substItrConj w z).subst v = φ.substItrConj ((Semiterm.subst v)↗ w) z := + by + ext; simp only [substItrConj, val_substs, SemitermVec.val_substs] + rw [substs_conj_substItr φ.isSemiformula w.isSemitermVec v.isSemitermVec]; rfl + +@[simp] +lemma substItrDisj_substs (v : SemitermVec V ℒₒᵣ n k) (w : SemitermVec V ℒₒᵣ m n) + (φ : Semiformula V ℒₒᵣ (m + 1)) (z : V) : + (φ.substItrDisj w z).subst v = φ.substItrDisj ((Semiterm.subst v)↗ w) z := + by + ext; simp only [substItrDisj, val_substs, SemitermVec.val_substs] + rw [substs_disj_substItr φ.isSemiformula w.isSemitermVec v.isSemitermVec]; rfl + +@[simp] +lemma substItrConj_shift (w : SemitermVec V ℒₒᵣ m n) (φ : Semiformula V ℒₒᵣ (m + 1)) (z : V) : + (φ.substItrConj w z).shift = φ.shift.substItrConj (Semiterm.shift↗ w) z := + by + ext; simp only [substItrConj, val_shift, SemitermVec.val_shift] + rw [shift_conj_substItr φ.isSemiformula w.isSemitermVec]; rfl + +@[simp] +lemma substItrDisj_shift (w : SemitermVec V ℒₒᵣ m n) (φ : Semiformula V ℒₒᵣ (m + 1)) (z : V) : + (φ.substItrDisj w z).shift = φ.shift.substItrDisj (Semiterm.shift↗ w) z := + by + ext; simp only [substItrDisj, val_shift, SemitermVec.val_shift] + rw [shift_disj_substItr φ.isSemiformula w.isSemitermVec]; rfl + +@[simp] lemma substItrConj_free (w : SemitermVec V ℒₒᵣ m 1) (φ : Semiformula V ℒₒᵣ (m + 1)) (z : + V) : + (φ.substItrConj w z).free = φ.shift.substItrConj (Semiterm.free↗ w) z := by + unfold free; simp [Matrix.vecMap_vecMap_comp']; rfl + +@[simp] lemma substItrDisj_free (w : SemitermVec V ℒₒᵣ m 1) (φ : Semiformula V ℒₒᵣ (m + 1)) (z : + V) : + (φ.substItrDisj w z).free = φ.shift.substItrDisj (Semiterm.free↗ w) z := by + unfold free; simp [Matrix.vecMap_vecMap_comp']; rfl + +end Semiformula + +end typed_formula + +/- +section typed_isfvfree + +namespace Semiformula + +def FVFree (φ : Semiformula V L n) : Prop := L.IsFVFree n φ.val + +lemma FVFree.iff {φ : Semiformula V L n} : φ.FVFree ↔ φ.shift = φ := by + simp [FVFree, Language.IsFVFree, ext_iff] + +@[simp] lemma Fvfree.verum : (⊤ : Semiformula V L n).FVFree := by simp [FVFree] + +@[simp] lemma Fvfree.falsum : (⊥ : Semiformula V L n).FVFree := by simp [FVFree] + +@[simp] lemma Fvfree.and {φ ψ : Semiformula V L n} : + (φ ⋏ ψ).FVFree ↔ φ.FVFree ∧ ψ.FVFree := by + simp [FVFree.iff, FVFree.iff] + +@[simp] lemma Fvfree.or {φ ψ : Semiformula V L n} : (φ ⋎ ψ).FVFree ↔ φ.FVFree ∧ ψ.FVFree := by + simp [FVFree.iff] + +@[simp] lemma Fvfree.neg {φ : Semiformula V L n} : (∼φ).FVFree ↔ φ.FVFree := by + simp [FVFree.iff] + +@[simp] lemma Fvfree.all {φ : Semiformula V L (n + 1)} : ∀¹ φ.FVFree ↔ φ.FVFree := by + simp [FVFree.iff] + +@[simp] lemma Fvfree.exs {φ : Semiformula V L (n + 1)} : ∃¹ φ.FVFree ↔ φ.FVFree := by + simp [FVFree.iff] + +@[simp] lemma Fvfree.imp {φ ψ : Semiformula V L n} : (φ ⇒ₗ ψ).FVFree ↔ φ.FVFree ∧ ψ.FVFree := by + simp [FVFree.iff] + +end Semiformula + +end typed_isfvfree +-/ + +open Bootstrapping.ObjectArithmetic + +variable {k n m : ℕ} + +/-- The equals construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.Semiterm`. -/ +noncomputable def Semiterm.equals (t u : Semiterm V ℒₒᵣ n) : Semiformula V ℒₒᵣ n := + ⟨t.val ^= u.val, by simp [qqEQ]⟩ + +/-- The not Equals construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.Semiterm`. -/ +noncomputable def Semiterm.notEquals (t u : Semiterm V ℒₒᵣ n) : Semiformula V ℒₒᵣ n := + ⟨t.val ^≠ u.val, by simp [qqNEQ]⟩ + +/-- The less Than construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.Semiterm`. -/ +noncomputable def Semiterm.lessThan (t u : Semiterm V ℒₒᵣ n) : Semiformula V ℒₒᵣ n := + ⟨t.val ^< u.val, by simp [qqLT]⟩ + +/-- The not Less Than construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.Semiterm`. -/ +noncomputable def Semiterm.notLessThan (t u : Semiterm V ℒₒᵣ n) : Semiformula V ℒₒᵣ n := + ⟨t.val ^≮ u.val, by simp [qqNLT]⟩ + +/-- The «term ≐ » construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +scoped infix:46 " ≐ " => Semiterm.equals + +/-- The «term ≉ » construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +scoped infix:46 " ≉ " => Semiterm.notEquals + +/-- The «term <' » construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +scoped infix:46 " <' " => Semiterm.lessThan + +/-- The «term ≮' » construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +scoped infix:46 " ≮' " => Semiterm.notLessThan + +/-- The ball construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.Semiformula`. -/ +noncomputable def Semiformula.ball (t : Semiterm V ℒₒᵣ n) (φ : Semiformula V ℒₒᵣ (n + 1)) : + Semiformula V ℒₒᵣ n := + ∀¹ ((Semiterm.bvar 0 ≮' t.bShift) ⋎ φ) + +/-- The bexs construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.Semiformula`. -/ +noncomputable def Semiformula.bexs (t : Semiterm V ℒₒᵣ n) (φ : Semiformula V ℒₒᵣ (n + 1)) : + Semiformula V ℒₒᵣ n := + ∃¹ ((Semiterm.bvar 0 <' t.bShift) ⋏ φ) + +namespace ObjectArithmetic + +-- `Arithmetic` is intentionally re-opened here even though the ambient namespace +-- already contains it; renaming would break the widely-used public API +-- (`Bootstrapping.ObjectArithmetic.*`). Suppress the new dupNamespace linter for the +-- declarations in this namespace (the option is scoped by `namespace`/`end` and +-- reverts automatically at `end Arithmetic`). + +variable {n m : ℕ} + +@[simp] +lemma rel_eq_eq (v : Fin 2 → Semiterm V ℒₒᵣ n) : + Semiformula.rel (Language.Eq.eq : (ℒₒᵣ).Rel 2) v = (v 0 ≐ v 1) := by ext; rfl + +@[simp] +lemma nrel_eq_eq (v : Fin 2 → Semiterm V ℒₒᵣ n) : + Semiformula.nrel (Language.Eq.eq : (ℒₒᵣ).Rel 2) v = (v 0 ≉ v 1) := by ext; rfl + +@[simp] +lemma rel_lt_eq (v : Fin 2 → Semiterm V ℒₒᵣ n) : + Semiformula.rel (Language.LT.lt : (ℒₒᵣ).Rel 2) v = (v 0 <' v 1) := by ext; rfl + +@[simp] +lemma nrel_lt_eq (v : Fin 2 → Semiterm V ℒₒᵣ n) : + Semiformula.nrel (Language.LT.lt : (ℒₒᵣ).Rel 2) v = (v 0 ≮' v 1) := by ext; rfl + +@[simp] +lemma val_equals (t u : Semiterm V ℒₒᵣ n) : (t ≐ u).val = t.val ^= u.val := + rfl +@[simp] +lemma val_notEquals (t u : Semiterm V ℒₒᵣ n) : (t ≉ u).val = t.val ^≠ u.val := + rfl +@[simp] +lemma val_lessThan (t u : Semiterm V ℒₒᵣ n) : (t <' u).val = t.val ^< u.val := + rfl +@[simp] +lemma val_notLessThan (t u : Semiterm V ℒₒᵣ n) : (t ≮' u).val = t.val ^≮ u.val := + rfl + +@[simp] +lemma equals_iff {t₁ t₂ u₁ u₂ : Semiterm V ℒₒᵣ n} : (t₁ ≐ u₁) = (t₂ ≐ u₂) ↔ t₁ = t₂ ∧ u₁ = u₂ := + by simp [Semiformula.ext_iff, Semiterm.ext_iff, qqEQ] + +@[simp] +lemma notequals_iff {t₁ t₂ u₁ u₂ : Semiterm V ℒₒᵣ n} : + (t₁ ≉ u₁) = (t₂ ≉ u₂) ↔ t₁ = t₂ ∧ u₁ = u₂ := by + simp [Semiformula.ext_iff, Semiterm.ext_iff, qqNEQ] + +@[simp] +lemma lessThan_iff {t₁ t₂ u₁ u₂ : Semiterm V ℒₒᵣ n} : + (t₁ <' u₁) = (t₂ <' u₂) ↔ t₁ = t₂ ∧ u₁ = u₂ := by + simp [Semiformula.ext_iff, Semiterm.ext_iff, qqLT] + +@[simp] +lemma notLessThan_iff {t₁ t₂ u₁ u₂ : Semiterm V ℒₒᵣ n} : + (t₁ ≮' u₁) = (t₂ ≮' u₂) ↔ t₁ = t₂ ∧ u₁ = u₂ := by + simp [Semiformula.ext_iff, Semiterm.ext_iff, qqNLT] + +@[simp] lemma neg_equals (t₁ t₂ : Semiterm V ℒₒᵣ n) : + ∼(t₁ ≐ t₂) = (t₁ ≉ t₂) := by + ext; simp [Semiterm.equals, Semiterm.notEquals, qqEQ, qqNEQ] + +@[simp] lemma neg_notEquals (t₁ t₂ : Semiterm V ℒₒᵣ n) : + ∼(t₁ ≉ t₂) = (t₁ ≐ t₂) := by + ext; simp [Semiterm.equals, Semiterm.notEquals, qqEQ, qqNEQ] + +@[simp] lemma neg_lessThan (t₁ t₂ : Semiterm V ℒₒᵣ n) : + ∼(t₁ <' t₂) = (t₁ ≮' t₂) := by + ext; simp [Semiterm.lessThan, Semiterm.notLessThan, qqLT, qqNLT] + +@[simp] lemma neg_notLessThan (t₁ t₂ : Semiterm V ℒₒᵣ n) : + ∼(t₁ ≮' t₂) = (t₁ <' t₂) := by + ext; simp [Semiterm.lessThan, Semiterm.notLessThan, qqLT, qqNLT] + +@[simp] +lemma shift_equals (t₁ t₂ : Semiterm V ℒₒᵣ n) : (t₁ ≐ t₂).shift = (t₁.shift ≐ t₂.shift) := by + ext; simp [Semiterm.equals, Semiterm.shift, Semiformula.shift, qqEQ] + +@[simp] +lemma shift_notEquals (t₁ t₂ : Semiterm V ℒₒᵣ n) : (t₁ ≉ t₂).shift = (t₁.shift ≉ t₂.shift) := by + ext; simp [Semiterm.notEquals, Semiterm.shift, Semiformula.shift, qqNEQ] + +@[simp] +lemma shift_lessThan (t₁ t₂ : Semiterm V ℒₒᵣ n) : (t₁ <' t₂).shift = (t₁.shift <' t₂.shift) := + by ext; simp [Semiterm.lessThan, Semiterm.shift, Semiformula.shift, qqLT] + +@[simp] lemma shift_notLessThan (t₁ t₂ : Semiterm V ℒₒᵣ n) : + (t₁ ≮' t₂).shift = (t₁.shift ≮' t₂.shift) := by + ext; simp [Semiterm.notLessThan, Semiterm.shift, Semiformula.shift, qqNLT] + +@[simp] lemma substs_equals (w : SemitermVec V ℒₒᵣ n m) (t₁ t₂ : Semiterm V ℒₒᵣ n) : + (t₁ ≐ t₂).subst w = (t₁.subst w ≐ t₂.subst w) := by + ext; simp [Semiterm.equals, Semiterm.subst, Semiformula.subst, qqEQ] + +@[simp] lemma substs_notEquals (w : SemitermVec V ℒₒᵣ n m) (t₁ t₂ : Semiterm V ℒₒᵣ n) : + (t₁ ≉ t₂).subst w = (t₁.subst w ≉ t₂.subst w) := by + ext; simp [Semiterm.notEquals, Semiterm.subst, Semiformula.subst, qqNEQ] + +@[simp] lemma substs_lessThan (w : SemitermVec V ℒₒᵣ n m) (t₁ t₂ : Semiterm V ℒₒᵣ n) : + (t₁ <' t₂).subst w = (t₁.subst w <' t₂.subst w) := by + ext; simp [Semiterm.lessThan, Semiterm.subst, Semiformula.subst, qqLT] + +@[simp] lemma substs_notLessThan (w : SemitermVec V ℒₒᵣ n m) (t₁ t₂ : Semiterm V ℒₒᵣ n) : + (t₁ ≮' t₂).subst w = (t₁.subst w ≮' t₂.subst w) := by + ext; simp [Semiterm.notLessThan, Semiterm.subst, Semiformula.subst, qqNLT] + +@[simp] +lemma val_ball (t : Semiterm V ℒₒᵣ n) (φ : Semiformula V ℒₒᵣ (n + 1)) : + (φ.ball t).val = ^∀ (^#0 ^≮ termBShift ℒₒᵣ t.val) ^⋎ φ.val := by simp [Semiformula.ball] + +@[simp] +lemma val_bexs (t : Semiterm V ℒₒᵣ n) (φ : Semiformula V ℒₒᵣ (n + 1)) : + (φ.bexs t).val = ^∃ (^#0 ^< termBShift ℒₒᵣ t.val) ^⋏ φ.val := by simp [Semiformula.bexs] + +lemma neg_ball (t : Semiterm V ℒₒᵣ n) (φ : Semiformula V ℒₒᵣ (n + 1)) : + ∼(φ.ball t) = (∼φ).bexs t := by + ext; simp [neg_all, neg_or, qqNLT, qqLT, t.isSemiterm.termBShift.isUTerm] + +lemma neg_bexs (t : Semiterm V ℒₒᵣ n) (φ : Semiformula V ℒₒᵣ (n + 1)) : + ∼(φ.bexs t) = (∼φ).ball t := by + ext; simp [neg_ex, neg_and, qqNLT, qqLT, t.isSemiterm.termBShift.isUTerm] + +@[simp] +lemma shifts_ball (t : Semiterm V ℒₒᵣ n) (φ : Semiformula V ℒₒᵣ (n + 1)) : + (φ.ball t).shift = φ.shift.ball t.shift := by + simp [Semiformula.ball, Semiterm.bShift_shift_comm] + +@[simp] +lemma shifts_bexs (t : Semiterm V ℒₒᵣ n) (φ : Semiformula V ℒₒᵣ (n + 1)) : + (φ.bexs t).shift = φ.shift.bexs t.shift := by + simp [Semiformula.bexs, Semiterm.bShift_shift_comm] + +@[simp] +lemma substs_ball (w : SemitermVec V ℒₒᵣ n m) (t : Semiterm V ℒₒᵣ n) + (φ : Semiformula V ℒₒᵣ (n + 1)) : (φ.ball t).subst w = (φ.subst w.q).ball (t.subst w) := by + simp [Semiformula.ball] + +@[simp] +lemma substs_bexs (w : SemitermVec V ℒₒᵣ n m) (t : Semiterm V ℒₒᵣ n) + (φ : Semiformula V ℒₒᵣ (n + 1)) : (φ.bexs t).subst w = (φ.subst w.q).bexs (t.subst w) := by + simp [Semiformula.bexs] + +end ObjectArithmetic + +lemma Semiformula.ball_eqss_imp (t : Semiterm V ℒₒᵣ n) (φ : Semiformula V ℒₒᵣ (n + 1)) : + φ.ball t = ∀¹ ((Semiterm.bvar 0 <' t.bShift) ⇒ₗ φ) := by simp [Semiformula.ball, imp_def] + +end Bootstrapping +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Language.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Language.lean new file mode 100644 index 000000000..81bd61670 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Language.lean @@ -0,0 +1,323 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.HFS + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +/-! +# Internalized languages of first-order logic -/ + +namespace FFL +namespace FirstOrder +namespace Arithmetic +namespace Bootstrapping + +variable {L : Language} [L.Encodable] + +instance (k) : Semiterm.Operator.GödelNumber ℒₒᵣ (L.Func k) := + ⟨fun f ↦ Semiterm.Operator.numeral ℒₒᵣ (Encodable.encode f)⟩ + +instance (k) : Semiterm.Operator.GödelNumber ℒₒᵣ (L.Rel k) := + ⟨fun r ↦ Semiterm.Operator.numeral ℒₒᵣ (Encodable.encode r)⟩ + +variable (L) + +/-- Data and laws for LORDefinable in `FFL.FirstOrder.Language`. -/ +protected class _root_.PointwiseComposition.FFL.FirstOrder.Language.LORDefinable where + /-- The func construction in `FFL.FirstOrder.Language.LORDefinable`. -/ + func : Σ₀.Semisentence 2 + /-- The rel construction in `FFL.FirstOrder.Language.LORDefinable`. -/ + rel : Σ₀.Semisentence 2 + func_iff {k c : ℕ} : c ∈ Set.range (Encodable.encode : L.Func k → ℕ) ↔ ℕ ⊧/![k, c] func.val + rel_iff {k c : ℕ} : c ∈ Set.range (Encodable.encode : L.Rel k → ℕ) ↔ ℕ ⊧/![k, c] rel.val + +alias _root_.PointwiseComposition.FFL.FirstOrder.Language.isFunc := Language.LORDefinable.func + +alias _root_.PointwiseComposition.FFL.FirstOrder.Language.isRel := Language.LORDefinable.rel + +alias _root_.PointwiseComposition.FFL.FirstOrder.Language.iff_isFunc := + Language.LORDefinable.func_iff + +alias _root_.PointwiseComposition.FFL.FirstOrder.Language.iff_isRel := + Language.LORDefinable.rel_iff + +variable {V : Type*} [ORingStructure V] [L.LORDefinable] + +/-- The Is Func construction in `FFL.FirstOrder.Language`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Language.IsFunc (arity f : V) : Prop := + V ⊧/![arity, f] L.isFunc.val + +/-- The Is Rel construction in `FFL.FirstOrder.Language`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Language.IsRel (arity f : V) : Prop := + V ⊧/![arity, f] L.isRel.val + +variable {L} + +lemma isFunc_def (k f : V) : L.IsFunc k f ↔ V ⊧/![k, f] L.isFunc.val := by rfl + +lemma isRel_def (k R : V) : L.IsRel k R ↔ V ⊧/![k, R] L.isRel.val := by rfl + +lemma eval_func (v : Fin 2 → V) : L.isFunc.val.Evalb v ↔ L.IsFunc (v 0) (v 1) := by + simp [Language.IsFunc, ← Matrix.fun_eq_vec_two] + +lemma eval_rel_iff (v : Fin 2 → V) : L.isRel.val.Evalb v ↔ L.IsRel (v 0) (v 1) := by + simp [Language.IsRel, ← Matrix.fun_eq_vec_two] + +instance _root_.PointwiseComposition.FFL.FirstOrder.Language.IsFunc.defined : + Σ₀-Relation (L.IsFunc (V := V)) via L.isFunc := + .mk fun v ↦ eval_func (L := L) v + +instance _root_.PointwiseComposition.FFL.FirstOrder.Language.IsRel.defined : + Σ₀-Relation (L.IsRel (V := V)) via L.isRel := + .mk fun v ↦ eval_rel_iff (L := L) v + +instance _root_.PointwiseComposition.FFL.FirstOrder.Language.IsFunc.definable : + Σ₀-Relation (L.IsFunc (V := V)) := + Language.IsFunc.defined.to_definable + +instance _root_.PointwiseComposition.FFL.FirstOrder.Language.IsRel.definable : + Σ₀-Relation (L.IsRel (V := V)) := + Language.IsRel.defined.to_definable + +@[simp, definability] +instance _root_.PointwiseComposition.FFL.FirstOrder.Language.IsFunc.definable' (ℌ) : + ℌ-Relation (L.IsFunc (V := V)) := + HierarchySymbol.Definable.of_zero Language.IsFunc.definable + +@[simp, definability] +instance _root_.PointwiseComposition.FFL.FirstOrder.Language.IsRel.definable' (ℌ) : + ℌ-Relation (L.IsRel (V := V)) := + HierarchySymbol.Definable.of_zero Language.IsRel.definable + +section + +variable [V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] + +instance gödelQuoteFunc (k) : GödelQuote (L.Func k) V := + ⟨fun f ↦ ↑(Encodable.encode f)⟩ + +instance gödelQuoteRel (k) : GödelQuote (L.Rel k) V := + ⟨fun R ↦ ↑(Encodable.encode R)⟩ + +omit [L.LORDefinable] in +lemma quote_func_def (f : L.Func k) : (⌜f⌝ : V) = ↑(Encodable.encode f) := + rfl + +omit [L.LORDefinable] in +lemma quote_rel_def (R : L.Rel k) : (⌜R⌝ : V) = ↑(Encodable.encode R) := + rfl + +lemma isFunc_quote_quote {k x : ℕ} : + L.IsFunc (V := V) k x ↔ ∃ f : L.Func k, Encodable.encode f = x := + have : V ⊧/![k, x] L.isFunc.val ↔ ℕ ⊧/![k, x] L.isFunc.val := by + simpa [Matrix.comp_vecCons', Matrix.constant_eq_singleton] using + models_iff_of_Sigma0 (V := V) (σ := L.isFunc.val) (by simp) (e := ![k, x]) + Iff.trans this <| Iff.trans L.iff_isFunc.symm <| by simp + +lemma isRel_quote_quote {k x : ℕ} : + L.IsRel (V := V) k x ↔ ∃ R : L.Rel k, Encodable.encode R = x := + have : V ⊧/![k, x] L.isRel.val ↔ ℕ ⊧/![k, x] L.isRel.val := by + simpa [Matrix.comp_vecCons', Matrix.constant_eq_singleton] using + models_iff_of_Sigma0 (V := V) (σ := L.isRel.val) (by simp) (e := ![k, x]) + Iff.trans this <| Iff.trans L.iff_isRel.symm <| by simp + +@[simp] +lemma codeIn_func_quote {k : ℕ} (f : L.Func k) : L.IsFunc (V := V) k ⌜f⌝ := + (isFunc_quote_quote (V := V)).mpr ⟨f, rfl⟩ + +@[simp] +lemma codeIn_rel_quote {k : ℕ} (r : L.Rel k) : L.IsRel (V := V) k ⌜r⌝ := + (isRel_quote_quote (V := V)).mpr ⟨r, rfl⟩ + +omit [L.LORDefinable] + +@[simp] +lemma quote_func_inj (f₁ f₂ : L.Func k) : (⌜f₁⌝ : V) = (⌜f₂⌝ : V) ↔ f₁ = f₂ := by + simp [quote_func_def] + +@[simp] +lemma quote_rel_inj (R₁ R₂ : L.Rel k) : (⌜R₁⌝ : V) = (⌜R₂⌝ : V) ↔ R₁ = R₂ := by + simp [quote_rel_def] + +@[simp] +lemma coe_quote_func_nat (f : L.Func k) : ((⌜f⌝ : ℕ) : V) = (⌜f⌝ : V) := by + simp [quote_func_def] + +@[simp] +lemma coe_quote_rel_nat (R : L.Rel k) : ((⌜R⌝ : ℕ) : V) = (⌜R⌝ : V) := by simp [quote_rel_def] + +end + +lemma _root_.PointwiseComposition.FFL.FirstOrder.Language.ORing.of_mem_range_encode_func + {k f : ℕ} : + f ∈ Set.range (Encodable.encode : FirstOrder.Language.Func ℒₒᵣ k → ℕ) ↔ + (k = 0 ∧ f = 0) ∨ (k = 0 ∧ f = 1) ∨ (k = 2 ∧ f = 0) ∨ (k = 2 ∧ f = 1) := + by + constructor + · rintro ⟨f, rfl⟩ + match k, f with + | 0, Language.ORing.Func.zero => simp; rfl + | 0, Language.ORing.Func.one => simp; rfl + | 2, Language.ORing.Func.add => simp; rfl + | 2, Language.ORing.Func.mul => simp; rfl + · rintro (⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩) + · exact ⟨Language.ORing.Func.zero, rfl⟩ + · exact ⟨Language.ORing.Func.one, rfl⟩ + · exact ⟨Language.ORing.Func.add, rfl⟩ + · exact ⟨Language.ORing.Func.mul, rfl⟩ + +/-- TODO: move to Basic/Syntax/Bootstrapping.Language.lean -/ +lemma _root_.PointwiseComposition.FFL.FirstOrder.Language.ORing.of_mem_range_encode_rel + {k r : ℕ} : + r ∈ Set.range (Encodable.encode : FirstOrder.Language.Rel ℒₒᵣ k → ℕ) ↔ + (k = 2 ∧ r = 0) ∨ (k = 2 ∧ r = 1) := + by + constructor + · rintro ⟨r, rfl⟩ + match k, r with + | 2, Language.ORing.Rel.eq => simp; rfl + | 2, Language.ORing.Rel.lt => simp; rfl + · rintro (⟨rfl, rfl⟩ | ⟨rfl, rfl⟩) + · exact ⟨Language.ORing.Rel.eq, rfl⟩ + · exact ⟨Language.ORing.Rel.lt, rfl⟩ + +instance : (ℒₒᵣ).LORDefinable + where + func := + .mkSigma (“k f. (k = 0 ∧ f = 0) ∨ (k = 0 ∧ f = 1) ∨ (k = 2 ∧ f = 0) ∨ (k = 2 ∧ f = 1)”) + rel := .mkSigma (“k r. (k = 2 ∧ r = 0) ∨ (k = 2 ∧ r = 1)”) + func_iff {k c} := by simpa [models_iff] using! Language.ORing.of_mem_range_encode_func + rel_iff {k c} := by simpa [models_iff] using! Language.ORing.of_mem_range_encode_rel + +namespace ObjectArithmetic + +variable {V : Type*} [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +/-- +The zero Index construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic`. -/ +def zeroIndex : ℕ := + Encodable.encode (Language.Zero.zero : (ℒₒᵣ : FirstOrder.Language).Func 0) + +/-- The one Index construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic`. -/ +def oneIndex : ℕ := + Encodable.encode (Language.One.one : (ℒₒᵣ : FirstOrder.Language).Func 0) + +/-- The add Index construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic`. -/ +def addIndex : ℕ := + Encodable.encode (Language.Add.add : (ℒₒᵣ : FirstOrder.Language).Func 2) + +/-- The mul Index construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic`. -/ +def mulIndex : ℕ := + Encodable.encode (Language.Mul.mul : (ℒₒᵣ : FirstOrder.Language).Func 2) + +/-- The eq Index construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic`. -/ +def eqIndex : ℕ := + Encodable.encode (Language.Eq.eq : (ℒₒᵣ : FirstOrder.Language).Rel 2) + +/-- The lt Index construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic`. -/ +def ltIndex : ℕ := + Encodable.encode (Language.LT.lt : (ℒₒᵣ : FirstOrder.Language).Rel 2) + +@[simp] +lemma LOR_func_zeroIndex : (ℒₒᵣ).IsFunc 0 (zeroIndex : V) := by + simpa using! codeIn_func_quote (V := V) (L := ℒₒᵣ) Language.Zero.zero + +@[simp] +lemma LOR_func_oneIndex : (ℒₒᵣ).IsFunc 0 (oneIndex : V) := by + simpa using! codeIn_func_quote (V := V) (L := ℒₒᵣ) Language.One.one + +@[simp] +lemma LOR_func_addIndex : (ℒₒᵣ).IsFunc 2 (addIndex : V) := by + simpa using! codeIn_func_quote (V := V) (L := ℒₒᵣ) Language.Add.add + +@[simp] +lemma LOR_func_mulIndex : (ℒₒᵣ).IsFunc 2 (mulIndex : V) := by + simpa using! codeIn_func_quote (V := V) (L := ℒₒᵣ) Language.Mul.mul + +@[simp] +lemma LOR_rel_eqIndex : (ℒₒᵣ).IsRel 2 (eqIndex : V) := by + simpa using! codeIn_rel_quote (V := V) (L := ℒₒᵣ) Language.Eq.eq + +@[simp] +lemma LOR_rel_ltIndex : (ℒₒᵣ).IsRel 2 (ltIndex : V) := by + simpa using! codeIn_rel_quote (V := V) (L := ℒₒᵣ) Language.LT.lt + +lemma func_def_LOR : + (ℒₒᵣ).isFunc = + .mkSigma (“k f. (k = 0 ∧ f = 0) ∨ (k = 0 ∧ f = 1) ∨ (k = 2 ∧ f = 0) ∨ (k = 2 ∧ f = 1)”) := + rfl + +lemma rel_def_LOR : (ℒₒᵣ).isRel = .mkSigma (“k r. (k = 2 ∧ r = 0) ∨ (k = 2 ∧ r = 1)”) := + rfl + +lemma coe_zeroIndex_eq : (zeroIndex : V) = 0 := + rfl + +lemma coe_oneIndex_eq : (oneIndex : V) = 1 := by simp [oneIndex]; rfl + +lemma coe_addIndex_eq : (addIndex : V) = 0 := + rfl + +lemma coe_mulIndex_eq : (mulIndex : V) = 1 := by simp [mulIndex]; rfl + +@[reducible] +instance gödelQuoteFuncLOR (k) : GödelQuote ((ℒₒᵣ).Func k) V := + gödelQuoteFunc k + +@[reducible] +instance gödelQuoteRelLOR (k) : GödelQuote ((ℒₒᵣ).Rel k) V := + gödelQuoteRel k + +lemma isFunc_iff_LOR {k f : V} : + (ℒₒᵣ).IsFunc k f ↔ + (k = 0 ∧ f = ⌜(Language.Zero.zero : (ℒₒᵣ).Func 0)⌝) ∨ + (k = 0 ∧ f = ⌜(Language.One.one : (ℒₒᵣ).Func 0)⌝) ∨ + (k = 2 ∧ f = ⌜(Language.Add.add : (ℒₒᵣ).Func 2)⌝) ∨ + (k = 2 ∧ f = ⌜(Language.Mul.mul : (ℒₒᵣ).Func 2)⌝) := + by + rw [isFunc_def (L := ℒₒᵣ), func_def_LOR] + suffices k = 0 ∧ f = 0 ∨ k = 0 ∧ f = 1 ∨ k = 2 ∧ f = 0 ∨ k = 2 ∧ f = 1 ↔ _ by simpa + apply iff_of_eq + congr + · calc + (1 : V) = (1 : ℕ) := by simp + _ = ⌜(Language.One.one : (ℒₒᵣ).Func 0)⌝ := by rfl + · calc + (1 : V) = (1 : ℕ) := by simp + _ = ⌜(Language.Mul.mul : (ℒₒᵣ).Func 2)⌝ := by rfl + +lemma isRel_iff_LOR {k R : V} : + (ℒₒᵣ).IsRel k R ↔ + (k = 2 ∧ R = ⌜(Language.Eq.eq : (ℒₒᵣ).Rel 2)⌝) ∨ + (k = 2 ∧ R = ⌜(Language.LT.lt : (ℒₒᵣ).Rel 2)⌝) := + by + rw [isRel_def (L := ℒₒᵣ), rel_def_LOR] + suffices k = 2 ∧ R = 0 ∨ k = 2 ∧ R = 1 ↔ _ by simpa + apply iff_of_eq + congr + · calc + (1 : V) = (1 : ℕ) := by simp + +end ObjectArithmetic + +end Bootstrapping +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Proof/Basic.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Proof/Basic.lean new file mode 100644 index 000000000..67733f71f --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Proof/Basic.lean @@ -0,0 +1,1218 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Theory + +/-! Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section +namespace FFL + +open FirstOrder Arithmetic + +variable {V : Type*} [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +variable {L : Language} [L.Encodable] [L.LORDefinable] + +variable {T U : Theory L} [T.Δ₁] [U.Δ₁] + +namespace FirstOrder +namespace Arithmetic +namespace Bootstrapping + +variable (L) + +/-- The Is Formula Set construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +def IsFormulaSet (s : V) : Prop := + ∀ p ∈ s, IsFormula L p + +/-- The is Formula Set construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def isFormulaSet : ∆₁.Semisentence 1 := .mkDelta + (.mkSigma “s. ∀ p ∈' s, !(isSemiformula L).sigma 0 p”) + (.mkPi “s. ∀ p ∈' s, !(isSemiformula L).pi 0 p”) + +variable {L} + +namespace IsFormulaSet + +section + +instance defined : ∆₁-Predicate[V] IsFormulaSet L via isFormulaSet L := + .mk ⟨by intro v; simp [isFormulaSet], by intro v; simp [isFormulaSet]; rfl⟩ + +instance definable : ∆₁-Predicate[V] IsFormulaSet L := + defined.to_definable + +instance definable' : Γ-[m + 1]-Predicate[V] IsFormulaSet L := + .of_deltaOne definable + +end + +@[simp] +lemma empty : IsFormulaSet L (∅ : V) := fun p ↦ by simp + +@[simp] +lemma singleton {p : V} : IsFormulaSet L ({ p } : V) ↔ IsFormula L p := + by + constructor + · intro h; exact h p (by simp) + · intro h p; simp only [mem_singleton_iff] + rintro rfl; exact h + +@[simp] +lemma insert_iff {p s : V} : IsFormulaSet L (insert p s) ↔ IsFormula L p ∧ IsFormulaSet L s := + by + constructor + · intro h; exact ⟨h p (by simp), fun q hq ↦ h q (by simp [hq])⟩ + · rintro ⟨hp, hs⟩ q; simp only [mem_bitInsert_iff]; rintro (rfl | hqs) + · exact hp + · exact hs q hqs + +alias ⟨insert, _⟩ := insert_iff + +@[simp] +lemma union {s₁ s₂ : V} : IsFormulaSet L (s₁ ∪ s₂) ↔ IsFormulaSet L s₁ ∧ IsFormulaSet L s₂ := + ⟨fun h ↦ ⟨fun p hp ↦ h p (by simp [hp]), fun p hp ↦ h p (by simp [hp])⟩, fun h p hp ↦ + by + rcases mem_cup_iff.mp hp with (h₁ | h₂) + · exact h.1 p h₁ + · exact h.2 p h₂⟩ + +end IsFormulaSet + +variable (L) + +lemma setShift_existsUnique (s : V) : ∃! t : V, ∀ y, y ∈ t ↔ ∃ x ∈ s, y = shift L x := + sigma₁_replacement (by definability) s + +/-- The set Shift construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def setShift (s : V) : V := + Classical.chooseUnique (setShift_existsUnique L s) + +/-- The set Shift Graph construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def setShiftGraph : Σ₁.Semisentence 2 := .mkSigma + “t s. (∀ y ∈' t, ∃ x ∈' s, !(shiftGraph L) y x) ∧ (∀ x ∈' s, ∃ y, !(shiftGraph L) y x ∧ y ∈ t)” + +variable {L} + +section setShift + +lemma mem_setShift_iff {s y : V} : y ∈ setShift L s ↔ ∃ x ∈ s, y = shift L x := + Classical.chooseUnique_spec (setShift_existsUnique L s) y + +lemma IsFormulaSet.setShift {s : V} (h : IsFormulaSet L s) : IsFormulaSet L (setShift L s) := + by + simp only [IsFormulaSet, mem_setShift_iff, forall_exists_index, and_imp] + rintro _ p hp rfl; exact (h p hp).shift + +lemma shift_mem_setShift {p s : V} (h : p ∈ s) : shift L p ∈ setShift L s := + mem_setShift_iff.mpr ⟨p, h, rfl⟩ + +@[simp] +lemma IsFormulaSet.setShift_iff {s : V} : + IsFormulaSet L (Bootstrapping.setShift L s) ↔ IsFormulaSet L s := + ⟨by intro h p hp; simpa using h (shift L p) (shift_mem_setShift hp), IsFormulaSet.setShift⟩ + +@[simp] +lemma mem_setShift_union {s t : V} : setShift L (s ∪ t) = setShift L s ∪ setShift L t := + mem_ext <| by + simp only [mem_setShift_iff, mem_cup_iff]; intro x + constructor + · rintro ⟨z, (hz | hz), rfl⟩ + · left; exact ⟨z, hz, rfl⟩ + · right; exact ⟨z, hz, rfl⟩ + · rintro (⟨z, hz, rfl⟩ | ⟨z, hz, rfl⟩) + · exact ⟨z, Or.inl hz, rfl⟩ + · exact ⟨z, Or.inr hz, rfl⟩ + +@[simp] +lemma mem_setShift_insert {x s : V} : + setShift L (insert x s) = insert (shift L x) (setShift L s) := + mem_ext <| by simp [mem_setShift_iff] + +@[simp] +lemma setShift_empty : setShift L (∅ : V) = ∅ := + mem_ext <| by simp [mem_setShift_iff] +section + +private lemma setShift_graph (t s : V) : + t = setShift L s ↔ (∀ y ∈ t, ∃ x ∈ s, y = shift L x) ∧ (∀ x ∈ s, shift L x ∈ t) := + by + constructor + · rintro rfl + constructor + · intro y hy; exact mem_setShift_iff.mp hy + · intro x hx; exact mem_setShift_iff.mpr ⟨x, hx, rfl⟩ + · rintro ⟨h₁, h₂⟩ + apply mem_ext; intro y; constructor + · intro hy; exact mem_setShift_iff.mpr (h₁ y hy) + · intro hy + rcases mem_setShift_iff.mp hy with ⟨x, hx, rfl⟩ + exact h₂ x hx + +instance setShift.defined : Σ₁-Function₁[V] setShift L via setShiftGraph L := + .mk fun v ↦ by simp [setShiftGraph, setShift_graph] + +instance setShift.definable : Σ₁-Function₁[V] setShift L := + setShift.defined.to_definable + +end + +end setShift + +/-- The ax L construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def axL (s p : V) : V := + ⟪s, 0, p⟫ + 1 + +/-- The verum Intro construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def verumIntro (s : V) : V := + ⟪s, 1, 0⟫ + 1 + +/-- The and Intro construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def andIntro (s p q dp dq : V) : V := + ⟪s, 2, p, q, dp, dq⟫ + 1 + +/-- The or Intro construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def orIntro (s p q d : V) : V := + ⟪s, 3, p, q, d⟫ + 1 + +/-- The all Intro construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def allIntro (s p d : V) : V := + ⟪s, 4, p, d⟫ + 1 + +/-- The exs Intro construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def exsIntro (s p t d : V) : V := + ⟪s, 5, p, t, d⟫ + 1 + +/-- The wk Rule construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def wkRule (s d : V) : V := + ⟪s, 6, d⟫ + 1 + +/-- The shift Rule construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def shiftRule (s d : V) : V := + ⟪s, 7, d⟫ + 1 + +/-- The cut Rule construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def cutRule (s p d₁ d₂ : V) : V := + ⟪s, 8, p, d₁, d₂⟫ + 1 + +/-- The axm construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def axm (s p : V) : V := + ⟪s, 9, p⟫ + 1 + +section + +/-- The ax LGraph construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +def axLGraph : Σ₀.Semisentence 3 := + .mkSigma “y s p. ∃ y' < y, !pair₃Def y' s 0 p ∧ y = y' + 1” + +instance axL.defined : Σ₀-Function₂[V] axL via axLGraph := + .mk fun v ↦ by simp_all [axLGraph, axL] + +/-- The verum Intro Graph construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +def verumIntroGraph : Σ₀.Semisentence 2 := + .mkSigma “y s. ∃ y' < y, !pair₃Def y' s 1 0 ∧ y = y' + 1” + +instance verumIntro.defined : Σ₀-Function₁[V] verumIntro via verumIntroGraph := + .mk fun v ↦ by simp_all [verumIntroGraph, verumIntro] + +/-- The and Intro Graph construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +def andIntroGraph : Σ₀.Semisentence 6 := + .mkSigma “y s p q dp dq. ∃ y' < y, !pair₆Def y' s 2 p q dp dq ∧ y = y' + 1” + +instance andIntro.defined : Σ₀-Function₅ (andIntro : V → V → V → V → V → V) via andIntroGraph := + .mk fun v ↦ by simp_all [andIntroGraph, andIntro] + +/-- The or Intro Graph construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +def orIntroGraph : Σ₀.Semisentence 5 := + .mkSigma “y s p q d. ∃ y' < y, !pair₅Def y' s 3 p q d ∧ y = y' + 1” + +instance orIntro.defined : Σ₀-Function₄ (orIntro : V → V → V → V → V) via orIntroGraph := + .mk fun v ↦ by simp_all [orIntroGraph, orIntro] + +/-- The all Intro Graph construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +def allIntroGraph : Σ₀.Semisentence 4 := + .mkSigma “y s p d. ∃ y' < y, !pair₄Def y' s 4 p d ∧ y = y' + 1” + +instance allIntro.defined : Σ₀-Function₃ (allIntro : V → V → V → V) via allIntroGraph := + .mk fun v ↦ by simp_all [allIntroGraph, allIntro] + +/-- The exs Intro Graph construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +def exsIntroGraph : Σ₀.Semisentence 5 := + .mkSigma “y s p t d. ∃ y' < y, !pair₅Def y' s 5 p t d ∧ y = y' + 1” + +instance exsIntro.defined : Σ₀-Function₄ (exsIntro : V → V → V → V → V) via exsIntroGraph := + .mk fun v ↦ by simp_all [exsIntroGraph, numeral_eq_natCast, exsIntro] + +/-- The wk Rule Graph construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +def wkRuleGraph : Σ₀.Semisentence 3 := + .mkSigma “y s d. ∃ y' < y, !pair₃Def y' s 6 d ∧ y = y' + 1” + +instance wkRule.defined : Σ₀-Function₂ (wkRule : V → V → V) via wkRuleGraph := + .mk fun v ↦ by simp_all [wkRuleGraph, numeral_eq_natCast, wkRule] + +/-- The shift Rule Graph construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +def shiftRuleGraph : Σ₀.Semisentence 3 := + .mkSigma “y s d. ∃ y' < y, !pair₃Def y' s 7 d ∧ y = y' + 1” + +instance shiftRule.defined : Σ₀-Function₂ (shiftRule : V → V → V) via shiftRuleGraph := + .mk fun v ↦ by simp_all [shiftRuleGraph, numeral_eq_natCast, shiftRule] + +/-- The cut Rule Graph construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +def cutRuleGraph : Σ₀.Semisentence 5 := + .mkSigma “y s p d₁ d₂. ∃ y' < y, !pair₅Def y' s 8 p d₁ d₂ ∧ y = y' + 1” + +instance cutRule_defined : Σ₀-Function₄ (cutRule : V → V → V → V → V) via cutRuleGraph := + .mk fun v ↦ by simp_all [cutRuleGraph, numeral_eq_natCast, cutRule] + +/-- The axm Graph construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +def axmGraph : Σ₀.Semisentence 3 := + .mkSigma “y s p. ∃ y' < y, !pair₃Def y' s 9 p ∧ y = y' + 1” + +instance axm_defined : Σ₀-Function₂ (axm : V → V → V) via axmGraph := + .mk fun v ↦ by simp_all [axmGraph, numeral_eq_natCast, axm] + +instance (ℌ : HierarchySymbol) : ℌ-Function₄ (orIntro : V → V → V → V → V) := + .of_zero orIntro.defined.to_definable + +instance (ℌ : HierarchySymbol) : ℌ-Function₂ (axm : V → V → V) := + .of_zero axm_defined.to_definable + +@[simp] +lemma seq_lt_axL (s p : V) : s < axL s p := + le_iff_lt_succ.mp <| le_pair_left _ _ +@[simp] +lemma arity_lt_axL (s p : V) : p < axL s p := + le_iff_lt_succ.mp <| le_trans (by simp) <| le_pair_right _ _ + +@[simp] +lemma seq_lt_verumIntro (s : V) : s < verumIntro s := + le_iff_lt_succ.mp <| le_pair_left _ _ + +@[simp] +lemma seq_lt_andIntro (s p q dp dq : V) : s < andIntro s p q dp dq := + le_iff_lt_succ.mp <| le_pair_left _ _ +@[simp] +lemma p_lt_andIntro (s p q dp dq : V) : p < andIntro s p q dp dq := + le_iff_lt_succ.mp <| + le_trans (le_trans (le_pair_left _ _) <| le_pair_right _ _) <| le_pair_right _ _ +@[simp] +lemma q_lt_andIntro (s p q dp dq : V) : q < andIntro s p q dp dq := + le_iff_lt_succ.mp <| + le_trans + (le_trans (le_trans (le_pair_left _ _) <| le_pair_right _ _) <| le_pair_right _ _) <| + le_pair_right _ _ +@[simp] +lemma dp_lt_andIntro (s p q dp dq : V) : dp < andIntro s p q dp dq := + le_iff_lt_succ.mp <| + le_trans + (le_trans (le_trans (le_trans (by simp) <| le_pair_right _ _) <| le_pair_right _ _) <| + le_pair_right _ _) <| + le_pair_right _ _ +@[simp] +lemma dq_lt_andIntro (s p q dp dq : V) : dq < andIntro s p q dp dq := + le_iff_lt_succ.mp <| + le_trans + (le_trans (le_trans (le_trans (by simp) <| le_pair_right _ _) <| le_pair_right _ _) <| + le_pair_right _ _) <| + le_pair_right _ _ + +@[simp] +lemma seq_lt_orIntro (s p q d : V) : s < orIntro s p q d := + le_iff_lt_succ.mp <| le_pair_left _ _ +@[simp] +lemma p_lt_orIntro (s p q d : V) : p < orIntro s p q d := + le_iff_lt_succ.mp <| + le_trans (le_trans (le_pair_left _ _) <| le_pair_right _ _) <| le_pair_right _ _ +@[simp] +lemma q_lt_orIntro (s p q d : V) : q < orIntro s p q d := + le_iff_lt_succ.mp <| + le_trans + (le_trans (le_trans (le_pair_left _ _) <| le_pair_right _ _) <| le_pair_right _ _) <| + le_pair_right _ _ +@[simp] +lemma d_lt_orIntro (s p q d : V) : d < orIntro s p q d := + le_iff_lt_succ.mp <| + le_trans + (le_trans (le_trans (le_pair_right _ _) <| le_pair_right _ _) <| le_pair_right _ _) <| + le_pair_right _ _ + +@[simp] +lemma seq_lt_allIntro (s p d : V) : s < allIntro s p d := + le_iff_lt_succ.mp <| le_pair_left _ _ +@[simp] +lemma p_lt_allIntro (s p d : V) : p < allIntro s p d := + le_iff_lt_succ.mp <| + le_trans (le_trans (le_pair_left _ _) <| le_pair_right _ _) <| le_pair_right _ _ +@[simp] +lemma s_lt_allIntro (s p d : V) : d < allIntro s p d := + le_iff_lt_succ.mp <| le_trans (le_trans (by simp) <| le_pair_right _ _) <| le_pair_right _ _ + +@[simp] +lemma seq_lt_exsIntro (s p t d : V) : s < exsIntro s p t d := + le_iff_lt_succ.mp <| le_pair_left _ _ +@[simp] +lemma p_lt_exsIntro (s p t d : V) : p < exsIntro s p t d := + le_iff_lt_succ.mp <| + le_trans (le_trans (le_pair_left _ _) <| le_pair_right _ _) <| le_pair_right _ _ +@[simp] +lemma t_lt_exsIntro (s p t d : V) : t < exsIntro s p t d := + le_iff_lt_succ.mp <| + le_trans + (le_trans (le_trans (le_pair_left _ _) <| le_pair_right _ _) <| le_pair_right _ _) <| + le_pair_right _ _ +@[simp] +lemma d_lt_exsIntro (s p t d : V) : d < exsIntro s p t d := + le_iff_lt_succ.mp <| + le_trans + (le_trans (le_trans (le_pair_right _ _) <| le_pair_right _ _) <| le_pair_right _ _) <| + le_pair_right _ _ + +@[simp] +lemma seq_lt_wkRule (s d : V) : s < wkRule s d := + le_iff_lt_succ.mp <| le_pair_left _ _ +@[simp] +lemma d_lt_wkRule (s d : V) : d < wkRule s d := + le_iff_lt_succ.mp <| le_trans (le_pair_right _ _) <| le_pair_right _ _ + +@[simp] +lemma seq_lt_shiftRule (s d : V) : s < shiftRule s d := + le_iff_lt_succ.mp <| le_pair_left _ _ +@[simp] +lemma d_lt_shiftRule (s d : V) : d < shiftRule s d := + le_iff_lt_succ.mp <| le_trans (le_pair_right _ _) <| le_pair_right _ _ + +@[simp] +lemma seq_lt_cutRule (s p d₁ d₂ : V) : s < cutRule s p d₁ d₂ := + le_iff_lt_succ.mp <| le_pair_left _ _ +@[simp] +lemma p_lt_cutRule (s p d₁ d₂ : V) : p < cutRule s p d₁ d₂ := + le_iff_lt_succ.mp <| + le_trans (le_trans (le_pair_left _ _) <| le_pair_right _ _) <| le_pair_right _ _ +@[simp] +lemma d₁_lt_cutRule (s p d₁ d₂ : V) : d₁ < cutRule s p d₁ d₂ := + le_iff_lt_succ.mp <| + le_trans + (le_trans (le_trans (le_pair_left _ _) <| le_pair_right _ _) <| le_pair_right _ _) <| + le_pair_right _ _ +@[simp] +lemma d₂_lt_cutRule (s p d₁ d₂ : V) : d₂ < cutRule s p d₁ d₂ := + le_iff_lt_succ.mp <| + le_trans + (le_trans (le_trans (le_pair_right _ _) <| le_pair_right _ _) <| le_pair_right _ _) <| + le_pair_right _ _ + +@[simp] +lemma seq_lt_axm (s p : V) : s < axm s p := + le_iff_lt_succ.mp <| le_pair_left _ _ +@[simp] +lemma p_lt_axm (s p : V) : p < axm s p := + le_iff_lt_succ.mp <| le_trans (le_pair_right _ _) <| le_pair_right _ _ + +@[simp] +lemma fstIdx_axL (s p : V) : fstIdx (axL s p) = s := by simp [fstIdx, axL] +@[simp] +lemma fstIdx_verumIntro (s : V) : fstIdx (verumIntro s) = s := by simp [fstIdx, verumIntro] +@[simp] +lemma fstIdx_andIntro (s p q dp dq : V) : fstIdx (andIntro s p q dp dq) = s := by + simp [fstIdx, andIntro] +@[simp] +lemma fstIdx_orIntro (s p q dpq : V) : fstIdx (orIntro s p q dpq) = s := by + simp [fstIdx, orIntro] +@[simp] +lemma fstIdx_allIntro (s p d : V) : fstIdx (allIntro s p d) = s := by simp [fstIdx, allIntro] +@[simp] +lemma fstIdx_exsIntro (s p t d : V) : fstIdx (exsIntro s p t d) = s := by + simp [fstIdx, exsIntro] +@[simp] +lemma fstIdx_wkRule (s d : V) : fstIdx (wkRule s d) = s := by simp [fstIdx, wkRule] +@[simp] +lemma fstIdx_shiftRule (s d : V) : fstIdx (shiftRule s d) = s := by simp [fstIdx, shiftRule] +@[simp] +lemma fstIdx_cutRule (s p d₁ d₂ : V) : fstIdx (cutRule s p d₁ d₂) = s := by + simp [fstIdx, cutRule] +@[simp] +lemma fstIdx_axm (s p : V) : fstIdx (axm s p) = s := by simp [fstIdx, axm] + +end + +namespace Derivation + +/-- The conseq construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.Derivation`. -/ +noncomputable abbrev conseq (x : V) : V := + π₁ x + +variable (T) + +/-- The Phi construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.Derivation`. -/ +def Phi (C : Set V) (d : V) : Prop := + IsFormulaSet L (fstIdx d) ∧ + ((∃ s p, d = axL s p ∧ p ∈ s ∧ neg L p ∈ s) ∨ + (∃ s, d = verumIntro s ∧ ^⊤ ∈ s) ∨ + (∃ s p q dp dq, + d = andIntro s p q dp dq ∧ + p ^⋏ q ∈ s ∧ + (fstIdx dp = insert p s ∧ dp ∈ C) ∧ (fstIdx dq = insert q s ∧ dq ∈ C)) ∨ + (∃ s p q dpq, + d = orIntro s p q dpq ∧ + p ^⋎ q ∈ s ∧ fstIdx dpq = insert p (insert q s) ∧ dpq ∈ C) ∨ + (∃ s p dp, + d = allIntro s p dp ∧ + ^∀ p ∈ s ∧ fstIdx dp = insert (free L p) (setShift L s) ∧ dp ∈ C) ∨ + (∃ s p t dp, + d = exsIntro s p t dp ∧ + ^∃ p ∈ s ∧ IsTerm L t ∧ fstIdx dp = insert (substs1 L t p) s ∧ dp ∈ C) ∨ + (∃ s d', d = wkRule s d' ∧ fstIdx d' ⊆ s ∧ d' ∈ C) ∨ + (∃ s d', d = shiftRule s d' ∧ s = setShift L (fstIdx d') ∧ d' ∈ C) ∨ + (∃ s p d₁ d₂, + d = cutRule s p d₁ d₂ ∧ + (fstIdx d₁ = insert p s ∧ d₁ ∈ C) ∧ + (fstIdx d₂ = insert (neg L p) s ∧ d₂ ∈ C)) ∨ + (∃ s p, d = axm s p ∧ p ∈ s ∧ p ∈ T.Δ₁Class)) + +private lemma phi_iff (C d : V) : + Phi T {x | x ∈ C} d ↔ + IsFormulaSet L (fstIdx d) ∧ + ((∃ s < d, ∃ p < d, d = axL s p ∧ p ∈ s ∧ neg L p ∈ s) ∨ + (∃ s < d, d = verumIntro s ∧ ^⊤ ∈ s) ∨ + (∃ s < d, + ∃ p < d, + ∃ q < d, + ∃ dp < d, + ∃ dq < d, + d = andIntro s p q dp dq ∧ + p ^⋏ q ∈ s ∧ + (fstIdx dp = insert p s ∧ dp ∈ C) ∧ + (fstIdx dq = insert q s ∧ dq ∈ C)) ∨ + (∃ s < d, + ∃ p < d, + ∃ q < d, + ∃ dpq < d, + d = orIntro s p q dpq ∧ + p ^⋎ q ∈ s ∧ fstIdx dpq = insert p (insert q s) ∧ dpq ∈ C) ∨ + (∃ s < d, + ∃ p < d, + ∃ dp < d, + d = allIntro s p dp ∧ + ^∀ p ∈ s ∧ fstIdx dp = insert (free L p) (setShift L s) ∧ dp ∈ C) ∨ + (∃ s < d, + ∃ p < d, + ∃ t < d, + ∃ dp < d, + d = exsIntro s p t dp ∧ + ^∃ p ∈ s ∧ + IsTerm L t ∧ fstIdx dp = insert (substs1 L t p) s ∧ dp ∈ C) ∨ + (∃ s < d, ∃ d' < d, d = wkRule s d' ∧ fstIdx d' ⊆ s ∧ d' ∈ C) ∨ + (∃ s < d, + ∃ d' < d, d = shiftRule s d' ∧ s = setShift L (fstIdx d') ∧ d' ∈ C) ∨ + (∃ s < d, + ∃ p < d, + ∃ d₁ < d, + ∃ d₂ < d, + d = cutRule s p d₁ d₂ ∧ + (fstIdx d₁ = insert p s ∧ d₁ ∈ C) ∧ + (fstIdx d₂ = insert (neg L p) s ∧ d₂ ∈ C)) ∨ + (∃ s < d, ∃ p < d, d = axm s p ∧ p ∈ s ∧ p ∈ T.Δ₁Class)) := + by + constructor + · rintro ⟨hs, H⟩ + refine ⟨hs, ?_⟩ + rcases H with + (⟨s, p, rfl, h⟩ | ⟨s, rfl, h⟩ | ⟨s, p, q, dp, dq, rfl, h⟩ | ⟨s, p, q, dpq, rfl, h⟩ | + ⟨s, p, dp, rfl, h⟩ | ⟨s, p, t, dp, rfl, h⟩ | ⟨s, d', rfl, h⟩ | ⟨s, d', rfl, h⟩ | + ⟨s, p, d₁, d₂, rfl, h⟩ | ⟨s, p, rfl, h⟩) + · left; exact ⟨s, by simp, p, by simp, rfl, h⟩ + · right; left; exact ⟨s, by simp, rfl, h⟩ + · right; right; left; + exact ⟨s, by simp, p, by simp, q, by simp, dp, by simp, dq, by simp, rfl, h⟩ + · right; right; right; left; + exact ⟨s, by simp, p, by simp, q, by simp, dpq, by simp, rfl, h⟩ + · right; right; right; right; left; exact ⟨s, by simp, p, by simp, dp, by simp, rfl, h⟩ + · right; right; right; right; right; left; + exact ⟨s, by simp, p, by simp, t, by simp, dp, by simp, rfl, h⟩ + · right; right; right; right; right; right; left; exact ⟨s, by simp, d', by simp, rfl, h⟩ + · right; right; right; right; right; right; right; left; + exact ⟨s, by simp, d', by simp, rfl, h⟩ + · right; right; right; right; right; right; right; right; left; + exact ⟨s, by simp, p, by simp, d₁, by simp, d₂, by simp, rfl, h⟩ + · right; right; right; right; right; right; right; right; right; + exact ⟨s, by simp, p, by simp, rfl, h⟩ + · rintro ⟨hs, H⟩ + refine ⟨hs, ?_⟩ + rcases H with + (⟨s, _, p, _, rfl, h⟩ | ⟨s, _, rfl, h⟩ | ⟨s, _, p, _, q, _, dp, _, dq, _, rfl, h⟩ | + ⟨s, _, p, _, q, _, dpq, _, rfl, h⟩ | ⟨s, _, p, _, dp, _, rfl, h⟩ | + ⟨s, _, p, _, t, _, dp, _, rfl, h⟩ | ⟨s, _, d', _, rfl, h⟩ | ⟨s, _, d', _, rfl, h⟩ | + ⟨s, _, p, _, d₁, _, d₂, _, rfl, h⟩ | ⟨s, _, p, _, h⟩) + · left; exact ⟨s, p, rfl, h⟩ + · right; left; exact ⟨s, rfl, h⟩ + · right; right; left; exact ⟨s, p, q, dp, dq, rfl, h⟩ + · right; right; right; left; exact ⟨s, p, q, dpq, rfl, h⟩ + · right; right; right; right; left; exact ⟨s, p, dp, rfl, h⟩ + · right; right; right; right; right; left; exact ⟨s, p, t, dp, rfl, h⟩ + · right; right; right; right; right; right; left; exact ⟨s, d', rfl, h⟩ + · right; right; right; right; right; right; right; left; exact ⟨s, d', rfl, h⟩ + · right; right; right; right; right; right; right; right; left; exact ⟨s, p, d₁, d₂, rfl, h⟩ + · right; right; right; right; right; right; right; right; right; exact ⟨s, p, h⟩ + +/-- The blueprint construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.Derivation`. -/ +noncomputable def blueprint : Fixpoint.Blueprint 0 := ⟨.mkDelta + (.mkSigma “d C. + (∃ fst, !fstIdxDef fst d ∧ !(isFormulaSet L).sigma fst) ∧ + ( (∃ s < d, ∃ p < d, !axLGraph d s p ∧ p ∈ s ∧ ∃ np, !(negGraph L) np p ∧ np ∈ s) ∨ + (∃ s < d, !verumIntroGraph d s ∧ ∃ vrm, !qqVerumDef vrm ∧ vrm ∈ s) ∨ + (∃ s < d, ∃ p < d, ∃ q < d, ∃ dp < d, ∃ dq < d, + !andIntroGraph d s p q dp dq ∧ (∃ and, !qqAndDef and p q ∧ and ∈ s) ∧ + (∃ c, !fstIdxDef c dp ∧ !insertDef c p s ∧ dp ∈ C) ∧ + (∃ c, !fstIdxDef c dq ∧ !insertDef c q s ∧ dq ∈ C)) ∨ + (∃ s < d, ∃ p < d, ∃ q < d, ∃ dpq < d, + !orIntroGraph d s p q dpq ∧ (∃ or, !qqOrDef or p q ∧ or ∈ s) ∧ + ∃ c, !fstIdxDef c dpq ∧ ∃ c', !insertDef c' q s ∧ !insertDef c p c' ∧ dpq ∈ C) ∨ + (∃ s < d, ∃ p < d, ∃ dp < d, + !allIntroGraph d s p dp ∧ (∃ all, !qqAllDef all p ∧ all ∈ s) ∧ + ∃ c, !fstIdxDef c dp ∧ ∃ fp, !(freeGraph L) fp p ∧ ∃ ss, !(setShiftGraph L) ss s ∧ + !insertDef c fp ss ∧ dp ∈ C) ∨ + (∃ s < d, ∃ p < d, ∃ t < d, ∃ dp < d, + !exsIntroGraph d s p t dp ∧ (∃ ex, !qqExsDef ex p ∧ ex ∈ s) ∧ + !(isSemiterm L).sigma 0 t ∧ ∃ c, !fstIdxDef c dp ∧ ∃ pt, !(substs1Graph L) pt t p ∧ + !insertDef c pt s ∧ dp ∈ C) ∨ + (∃ s < d, ∃ d' < d, + !wkRuleGraph d s d' ∧ ∃ c, !fstIdxDef c d' ∧ !bitSubsetDef c s ∧ d' ∈ C) ∨ + (∃ s < d, ∃ d' < d, + !shiftRuleGraph d s d' ∧ ∃ c, !fstIdxDef c d' ∧ !(setShiftGraph L) s c ∧ d' ∈ C) ∨ + (∃ s < d, ∃ p < d, ∃ d₁ < d, ∃ d₂ < d, + !cutRuleGraph d s p d₁ d₂ ∧ + (∃ c, !fstIdxDef c d₁ ∧ !insertDef c p s ∧ d₁ ∈ C) ∧ + (∃ c, !fstIdxDef c d₂ ∧ ∃ np, !(negGraph L) np p ∧ !insertDef c np s ∧ d₂ ∈ C)) ∨ + (∃ s < d, ∃ p < d, + !axmGraph d s p ∧ p ∈ s ∧ !T.Δ₁ch.sigma p) )” + ) + (.mkPi “d C. + (∀ fst, !fstIdxDef fst d → !(isFormulaSet L).pi fst) ∧ + ( (∃ s < d, ∃ p < d, !axLGraph d s p ∧ p ∈ s ∧ ∀ np, !(negGraph L) np p → np ∈ s) ∨ + (∃ s < d, !verumIntroGraph d s ∧ ∀ vrm, !qqVerumDef vrm → vrm ∈ s) ∨ + (∃ s < d, ∃ p < d, ∃ q < d, ∃ dp < d, ∃ dq < d, + !andIntroGraph d s p q dp dq ∧ (∀ and, !qqAndDef and p q → and ∈ s) ∧ + (∀ c, !fstIdxDef c dp → !insertDef c p s ∧ dp ∈ C) ∧ + (∀ c, !fstIdxDef c dq → !insertDef c q s ∧ dq ∈ C)) ∨ + (∃ s < d, ∃ p < d, ∃ q < d, ∃ dpq < d, + !orIntroGraph d s p q dpq ∧ (∀ or, !qqOrDef or p q → or ∈ s) ∧ + ∀ c, !fstIdxDef c dpq → ∀ c', !insertDef c' q s → !insertDef c p c' ∧ dpq ∈ C) ∨ + (∃ s < d, ∃ p < d, ∃ dp < d, + !allIntroGraph d s p dp ∧ (∀ all, !qqAllDef all p → all ∈ s) ∧ + ∀ c, !fstIdxDef c dp → ∀ fp, !(freeGraph L) fp p → ∀ ss, !(setShiftGraph L) ss s → + !insertDef c fp ss ∧ dp ∈ C) ∨ + (∃ s < d, ∃ p < d, ∃ t < d, ∃ dp < d, + !exsIntroGraph d s p t dp ∧ (∀ ex, !qqExsDef ex p → ex ∈ s) ∧ + !(isSemiterm L).pi 0 t ∧ + ∀ c, !fstIdxDef c dp → ∀ pt, !(substs1Graph L) pt t p → !insertDef c pt s ∧ dp ∈ C) ∨ + (∃ s < d, ∃ d' < d, + !wkRuleGraph d s d' ∧ ∀ c, !fstIdxDef c d' → !bitSubsetDef c s ∧ d' ∈ C) ∨ + (∃ s < d, ∃ d' < d, + !shiftRuleGraph d s d' ∧ ∀ c, !fstIdxDef c d' → ∀ ss, !(setShiftGraph L) ss c → s = ss ∧ + d' ∈ C) ∨ + (∃ s < d, ∃ p < d, ∃ d₁ < d, ∃ d₂ < d, + !cutRuleGraph d s p d₁ d₂ ∧ + (∀ c, !fstIdxDef c d₁ → !insertDef c p s ∧ d₁ ∈ C) ∧ + (∀ c, !fstIdxDef c d₂ → ∀ np, !(negGraph L) np p → !insertDef c np s ∧ d₂ ∈ C)) ∨ + (∃ s < d, ∃ p < d, + !axmGraph d s p ∧ p ∈ s ∧ !T.Δ₁ch.pi p) )” + )⟩ + + + +lemma Phi_definable : + ∆₁.Defined (fun v : Fin 2 → V ↦ Phi T {x | x ∈ v 1} (v 0)) (blueprint T).core := + .mk <| by + constructor + · intro v; simp [blueprint] + · intro v; simp [phi_iff, blueprint] + +/-- The construction construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.Derivation`. -/ +def construction : Fixpoint.Construction V (blueprint T) + where + Φ := fun _ ↦ Phi T + defined := Phi_definable _ + monotone := by + rintro C C' hC _ d ⟨hs, H⟩ + refine ⟨hs, ?_⟩ + rcases H with + (h | h | ⟨s, p, q, dp, dq, rfl, hpq, ⟨hp, hpC⟩, ⟨hq, hqC⟩⟩ | + ⟨s, p, q, dpq, rfl, hpq, h, hdC⟩ | ⟨s, p, dp, rfl, hp, h, hdC⟩ | + ⟨s, p, t, dp, rfl, hp, ht, h, hdC⟩ | ⟨s, d', rfl, ss, hdC⟩ | ⟨s, d', rfl, ss, hdC⟩ | + ⟨s, p, d₁, d₂, rfl, ⟨h₁, hd₁C⟩, ⟨h₂, hd₂C⟩⟩ | ⟨s, p, h⟩) + · left; exact h + · right; left; exact h + · right; right; left; exact ⟨s, p, q, dp, dq, rfl, hpq, ⟨hp, hC hpC⟩, ⟨hq, hC hqC⟩⟩ + · right; right; right; left; exact ⟨s, p, q, dpq, rfl, hpq, h, hC hdC⟩ + · right; right; right; right; left; exact ⟨s, p, dp, rfl, hp, h, hC hdC⟩ + · right; right; right; right; right; left; exact ⟨s, p, t, dp, rfl, hp, ht, h, hC hdC⟩ + · right; right; right; right; right; right; left; exact ⟨s, d', rfl, ss, hC hdC⟩ + · right; right; right; right; right; right; right; left; exact ⟨s, d', rfl, ss, hC hdC⟩ + · right; right; right; right; right; right; right; right; left; + exact ⟨s, p, d₁, d₂, rfl, ⟨h₁, hC hd₁C⟩, ⟨h₂, hC hd₂C⟩⟩ + · right; right; right; right; right; right; right; right; right; exact ⟨s, p, h⟩ + +instance : (construction T).StrongFinite V where + strong_finite := by + rintro C _ d ⟨hs, H⟩ + refine ⟨hs, ?_⟩ + rcases H with + (h | h | ⟨s, p, q, dp, dq, rfl, hpq, ⟨hp, hpC⟩, ⟨hq, hqC⟩⟩ | + ⟨s, p, q, dpq, rfl, hpq, h, hdC⟩ | ⟨s, p, dp, rfl, hp, h, hdC⟩ | + ⟨s, p, t, dp, rfl, hp, ht, h, hdC⟩ | ⟨s, d', rfl, ss, hdC⟩ | ⟨s, d', rfl, ss, hdC⟩ | + ⟨s, p, d₁, d₂, rfl, ⟨h₁, hd₁C⟩, ⟨h₂, hd₂C⟩⟩ | ⟨s, p, h⟩) + · left; exact h + · right; left; exact h + · right; right; left; + exact ⟨s, p, q, dp, dq, rfl, hpq, ⟨hp, hpC, by simp⟩, ⟨hq, hqC, by simp⟩⟩ + · right; right; right; left; exact ⟨s, p, q, dpq, rfl, hpq, h, hdC, by simp⟩ + · right; right; right; right; left; exact ⟨s, p, dp, rfl, hp, h, hdC, by simp⟩ + · right; right; right; right; right; left; exact ⟨s, p, t, dp, rfl, hp, ht, h, hdC, by simp⟩ + · right; right; right; right; right; right; left; exact ⟨s, d', rfl, ss, hdC, by simp⟩ + · right; right; right; right; right; right; right; left; + exact ⟨s, d', rfl, ss, hdC, by simp⟩ + · right; right; right; right; right; right; right; right; left; + exact ⟨s, p, d₁, d₂, rfl, ⟨h₁, hd₁C, by simp⟩, ⟨h₂, hd₂C, by simp⟩⟩ + · right; right; right; right; right; right; right; right; right; exact ⟨s, p, h⟩ + +end Derivation + +end Bootstrapping +end Arithmetic +end FirstOrder + +namespace FirstOrder +namespace Arithmetic +namespace Bootstrapping + +open PeanoMinus ISigma0 ISigma1 Derivation + +variable (T) + +/-- The Derivation construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +def Derivation : V → Prop := + (construction T).IsFixedPoint ![] + +/-- The Derivation Of construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +def DerivationOf (d s : V) : Prop := + fstIdx d = s ∧ Derivation T d + +/-- The Derivable construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +def Derivable (s : V) : Prop := + ∃ d, DerivationOf T d s + +/-- The Proof construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +def Proof (d φ : V) : Prop := + DerivationOf T d { φ } + +/-- The Provable construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +def Provable (φ : V) : Prop := + ∃ d, Proof T d φ + +/-- The derivation construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def derivation : ∆₁.Semisentence 1 := + (blueprint T).fixpointDefΔ₁ + +/-- The derivation Of construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def derivationOf : ∆₁.Semisentence 2 := .mkDelta + (.mkSigma “d s. !fstIdxDef s d ∧ !(derivation T).sigma d”) + (.mkPi “d s. !fstIdxDef s d ∧ !(derivation T).pi d”) + +/-- The derivable construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def derivable : Σ₁.Semisentence 1 := .mkSigma + “Γ. ∃ d, !(derivationOf T).sigma d Γ” + +/-- The proof construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def proof : ∆₁.Semisentence 2 := .mkDelta + (.mkSigma “d φ. ∃ s, !insertDef s φ 0 ∧ !(derivationOf T).sigma d s”) + (.mkPi “d φ. ∀ s, !insertDef s φ 0 → !(derivationOf T).pi d s”) + +/-- The provable construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def provable : Σ₁.Semisentence 1 := .mkSigma + “φ. ∃ d, !(proof T).sigma d φ” + +/-- The provability Pred construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable abbrev provabilityPred (σ : Sentence L) : ArithmeticSentence := + (provable T).val/[⌜σ⌝] + +/-- The provability Pred' construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def provabilityPred' (σ : Sentence L) : Σ₁.Sentence := .mkSigma + “!(provable T) !!(⌜σ⌝)” + +-- Proving this by `rfl` overflows memory on Lean v4.33.1. +@[simp] +lemma provabilityPred'_val (σ : Sentence L) : + (provabilityPred' T σ).val = provabilityPred T σ := + by + unfold provabilityPred' provabilityPred + simp only [HierarchySymbol.Semiformula.val_mkSigma] + +variable {T} + +section + +instance Derivation.defined : ∆₁-Predicate[V] Derivation T via derivation T := + (construction T).fixpoint_definedΔ₁ + +instance Derivation.definable : ∆₁-Predicate[V] Derivation T := + Derivation.defined.to_definable + +instance Derivation.definable' : Γ-[m + 1]-Predicate[V] Derivation T := + Derivation.definable.of_deltaOne + +instance DerivationOf.defined : ∆₁-Relation[V] DerivationOf T via derivationOf T := .mk + ⟨by intro v; simp [derivationOf], by + intro v + simp [derivationOf, eq_comm (b := fstIdx (v 0))] + rfl⟩ + +instance DerivationOf.definable : ∆₁-Relation[V] DerivationOf T := + DerivationOf.defined.to_definable + +instance DerivationOf.definable' : Γ-[m + 1]-Relation[V] DerivationOf T := + DerivationOf.definable.of_deltaOne + +instance Derivable.defined : Σ₁-Predicate[V] Derivable T via derivable T := + .mk fun v ↦ by simp [derivable, Derivable] + +instance Derivable.definable : Σ₁-Predicate[V] Derivable T := + Derivable.defined.to_definable + +/-- instance for definability tactic -/ +instance Derivable.definable' : Σ-[0 + 1]-Predicate[V] Derivable T := + Derivable.definable + +instance Proof.defined : ∆₁-Relation[V] Proof T via proof T := .mk + ⟨by intro v; simp [proof], by intro v; simp [Proof, proof, singleton_eq_insert, emptyset_def]⟩ + +instance Proof.definable : ∆₁-Relation[V] Proof T := + Proof.defined.to_definable + +instance Proof.definable' : Γ-[m + 1]-Relation[V] Proof T := + Proof.definable.of_deltaOne + +instance Provable.defined : Σ₁-Predicate[V] Provable T via provable T := + .mk fun v ↦ by simp [provable, Provable] + +instance Provable.definable : Σ₁-Predicate[V] Provable T := + Provable.defined.to_definable + +/-- instance for definability tactic -/ +instance Provable.definable' : Σ-[0 + 1]-Predicate[V] Provable T := + Provable.definable + +end + +namespace Derivation + +lemma case_iff {d : V} : + Derivation T d ↔ + IsFormulaSet L (fstIdx d) ∧ + ((∃ s p, d = Bootstrapping.axL s p ∧ p ∈ s ∧ neg L p ∈ s) ∨ + (∃ s, d = verumIntro s ∧ ^⊤ ∈ s) ∨ + (∃ s p q dp dq, + d = andIntro s p q dp dq ∧ + p ^⋏ q ∈ s ∧ + DerivationOf T dp (insert p s) ∧ DerivationOf T dq (insert q s)) ∨ + (∃ s p q dpq, + d = orIntro s p q dpq ∧ + p ^⋎ q ∈ s ∧ DerivationOf T dpq (insert p (insert q s))) ∨ + (∃ s p dp, + d = allIntro s p dp ∧ + ^∀ p ∈ s ∧ DerivationOf T dp (insert (free L p) (setShift L s))) ∨ + (∃ s p t dp, + d = exsIntro s p t dp ∧ + ^∃ p ∈ s ∧ IsTerm L t ∧ DerivationOf T dp (insert (substs1 L t p) s)) ∨ + (∃ s d', d = wkRule s d' ∧ fstIdx d' ⊆ s ∧ Derivation T d') ∨ + (∃ s d', + d = shiftRule s d' ∧ s = setShift L (fstIdx d') ∧ Derivation T d') ∨ + (∃ s p d₁ d₂, + d = cutRule s p d₁ d₂ ∧ + DerivationOf T d₁ (insert p s) ∧ + DerivationOf T d₂ (insert (neg L p) s)) ∨ + (∃ s p, d = axm s p ∧ p ∈ s ∧ p ∈ T.Δ₁Class)) := + (construction T).case + +alias ⟨case, + _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.Bootstrapping.Derivation.mk⟩ := case_iff + +lemma induction1 (Γ) {P : V → Prop} (hP : Γ-[1]-Predicate P) {d} (hd : Derivation T d) + (hAxL : ∀ s, IsFormulaSet L s → ∀ p ∈ s, neg L p ∈ s → P (axL s p)) + (hVerumIntro : ∀ s, IsFormulaSet L s → ^⊤ ∈ s → P (verumIntro s)) + (hAnd : + ∀ s, + IsFormulaSet L s → + ∀ p q dp dq, + p ^⋏ q ∈ s → + DerivationOf T dp (insert p s) → + DerivationOf T dq (insert q s) → P dp → P dq → P (andIntro s p q dp dq)) + (hOr : + ∀ s, + IsFormulaSet L s → + ∀ p q d, + p ^⋎ q ∈ s → DerivationOf T d (insert p (insert q s)) → P d → P (orIntro s p q d)) + (hAll : + ∀ s, + IsFormulaSet L s → + ∀ p d, + ^∀ p ∈ s → + DerivationOf T d (insert (free L p) (setShift L s)) → P d → P (allIntro s p d)) + (hExs : + ∀ s, + IsFormulaSet L s → + ∀ p t d, + ^∃ p ∈ s → + IsTerm L t → + DerivationOf T d (insert (substs1 L t p) s) → P d → P (exsIntro s p t d)) + (hWk : ∀ s, IsFormulaSet L s → ∀ d, fstIdx d ⊆ s → Derivation T d → P d → P (wkRule s d)) + (hShift : + ∀ s, + IsFormulaSet L s → + ∀ d, s = setShift L (fstIdx d) → Derivation T d → P d → P (shiftRule s d)) + (hCut : + ∀ s, + IsFormulaSet L s → + ∀ p d₁ d₂, + DerivationOf T d₁ (insert p s) → + DerivationOf T d₂ (insert (neg L p) s) → P d₁ → P d₂ → P (cutRule s p d₁ d₂)) + (hRoot : ∀ s, IsFormulaSet L s → ∀ p, p ∈ s → p ∈ T.Δ₁Class → P (axm s p)) : P d := + (construction T).induction (v := ![]) hP + (by + intro C ih d hd + rcases hd with + ⟨hds, + (⟨s, p, rfl, hps, hnps⟩ | ⟨s, rfl, hs⟩ | ⟨s, p, q, dp, dq, rfl, hpq, h₁, h₂⟩ | + ⟨s, p, q, d, rfl, hpq, h⟩ | ⟨s, p, d, rfl, hp, h, hC⟩ | + ⟨s, p, t, d, rfl, hp, ht, h, hC⟩ | ⟨s, d, rfl, h, hC⟩ | ⟨s, d, rfl, h, hC⟩ | + ⟨s, p, d₁, d₂, rfl, ⟨h₁, hC₁⟩, ⟨h₂, hC₂⟩⟩ | ⟨s, p, rfl, hs, hT⟩)⟩ + · exact hAxL s (by simpa using hds) p hps hnps + · exact hVerumIntro s (by simpa using hds) hs + · exact + hAnd s (by simpa using hds) p q dp dq hpq ⟨h₁.1, (ih dp h₁.2).1⟩ + ⟨h₂.1, (ih dq h₂.2).1⟩ (ih dp h₁.2).2 (ih dq h₂.2).2 + · exact hOr s (by simpa using hds) p q d hpq ⟨h.1, (ih d h.2).1⟩ (ih d h.2).2 + · exact hAll s (by simpa using hds) p d hp ⟨h, (ih d hC).1⟩ (ih d hC).2 + · exact hExs s (by simpa using hds) p t d hp ht ⟨h, (ih d hC).1⟩ (ih d hC).2 + · exact hWk s (by simpa using hds) d h (ih d hC).1 (ih d hC).2 + · exact hShift s (by simpa using hds) d h (ih d hC).1 (ih d hC).2 + · exact + hCut s (by simpa using hds) p d₁ d₂ ⟨h₁, (ih d₁ hC₁).1⟩ ⟨h₂, (ih d₂ hC₂).1⟩ + (ih d₁ hC₁).2 (ih d₂ hC₂).2 + · exact hRoot s (by simpa using hds) p hs hT) + d hd + +lemma isFormulaSet {d : V} (h : Derivation T d) : IsFormulaSet L (fstIdx d) := + (h : Derivation T d).case.1 + +lemma + _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.Bootstrapping.DerivationOf.isFormulaSet + {d s : V} (h : DerivationOf T d s) : IsFormulaSet L s := by simpa [h.1] using h.2.case.1 + +lemma axL {s p : V} (hs : IsFormulaSet L s) (h : p ∈ s) (hn : neg L p ∈ s) : + Derivation T (axL s p) := + Bootstrapping.Derivation.mk ⟨by simpa using hs, Or.inl ⟨s, p, rfl, h, hn⟩⟩ + +lemma verumIntro {s : V} (hs : IsFormulaSet L s) (h : ^⊤ ∈ s) : Derivation T (verumIntro s) := + Bootstrapping.Derivation.mk ⟨by simpa using hs, Or.inr <| Or.inl ⟨s, rfl, h⟩⟩ + +lemma andIntro {s p q dp dq : V} (h : p ^⋏ q ∈ s) (hdp : DerivationOf T dp (insert p s)) + (hdq : DerivationOf T dq (insert q s)) : Derivation T (andIntro s p q dp dq) := + Bootstrapping.Derivation.mk + ⟨by simp only [fstIdx_andIntro]; intro r hr; exact hdp.isFormulaSet r (by simp [hr]), + Or.inr <| Or.inr <| Or.inl ⟨s, p, q, dp, dq, rfl, h, hdp, hdq⟩⟩ + +lemma orIntro {s p q dpq : V} (h : p ^⋎ q ∈ s) + (hdpq : DerivationOf T dpq (insert p (insert q s))) : Derivation T (orIntro s p q dpq) := + Bootstrapping.Derivation.mk + ⟨by simp only [fstIdx_orIntro]; intro r hr; exact hdpq.isFormulaSet r (by simp [hr]), + Or.inr <| Or.inr <| Or.inr <| Or.inl ⟨s, p, q, dpq, rfl, h, hdpq⟩⟩ + +lemma allIntro {s p dp : V} (h : ^∀ p ∈ s) + (hdp : DerivationOf T dp (insert (free L p) (setShift L s))) : + Derivation T (allIntro s p dp) := + Bootstrapping.Derivation.mk + ⟨by simp only [fstIdx_allIntro]; intro q hq; simpa using hdp.isFormulaSet (shift L q) (by + simp [shift_mem_setShift hq]), + Or.inr <| Or.inr <| Or.inr <| Or.inr <| Or.inl ⟨s, p, dp, rfl, h, hdp⟩⟩ + +lemma exsIntro {s p t dp : V} (h : ^∃ p ∈ s) (ht : IsTerm L t) + (hdp : DerivationOf T dp (insert (substs1 L t p) s)) : Derivation T (exsIntro s p t dp) := + Bootstrapping.Derivation.mk + ⟨by simp only [fstIdx_exsIntro]; intro q hq; exact hdp.isFormulaSet q (by simp [hq]), + Or.inr <| Or.inr <| Or.inr <| Or.inr <| Or.inr <| Or.inl ⟨s, p, t, dp, rfl, h, ht, hdp⟩⟩ + +lemma wkRule {s s' d : V} (hs : IsFormulaSet L s) (h : s' ⊆ s) (hd : DerivationOf T d s') : + Derivation T (wkRule s d) := + Bootstrapping.Derivation.mk + ⟨by simpa using hs, + Or.inr <| + Or.inr <| + Or.inr <| Or.inr <| Or.inr <| Or.inr <| Or.inl ⟨s, d, rfl, by simp [hd.1, h], hd.2⟩⟩ + +lemma shiftRule {s d : V} (hd : DerivationOf T d s) : + Derivation T (shiftRule (setShift L s) d) := + Bootstrapping.Derivation.mk + ⟨by simp [hd.isFormulaSet], + Or.inr <| + Or.inr <| + Or.inr <| + Or.inr <| + Or.inr <| Or.inr <| Or.inr <| Or.inl ⟨setShift L s, d, rfl, by simp [hd.1], hd.2⟩⟩ + +lemma cutRule {s p d₁ d₂ : V} (hd₁ : DerivationOf T d₁ (insert p s)) + (hd₂ : DerivationOf T d₂ (insert (neg L p) s)) : Derivation T (cutRule s p d₁ d₂) := + Bootstrapping.Derivation.mk + ⟨by simp only [fstIdx_cutRule]; intro q hq; exact hd₁.isFormulaSet q (by simp [hq]), + Or.inr <| + Or.inr <| + Or.inr <| + Or.inr <| + Or.inr <| Or.inr <| Or.inr <| Or.inr <| Or.inl ⟨s, p, d₁, d₂, rfl, hd₁, hd₂⟩⟩ + +lemma axm {s p : V} (hs : IsFormulaSet L s) (hp : p ∈ s) (hT : p ∈ T.Δ₁Class) : + Derivation T (axm s p) := + Bootstrapping.Derivation.mk + ⟨by simpa using hs, + Or.inr <| + Or.inr <| + Or.inr <| + Or.inr <| Or.inr <| Or.inr <| Or.inr <| Or.inr <| Or.inr ⟨s, p, rfl, hp, hT⟩⟩ + +variable {U : Theory L} [U.Δ₁] + +lemma of_ss (h : T.Δ₁Class (V := V) ⊆ U.Δ₁Class) {d : V} : Derivation T d → Derivation U d := + by + intro hd + apply Bootstrapping.Derivation.induction1 Σ ?_ hd + · intro s hs p hp hn; apply Derivation.axL hs hp hn + · intro s hs hv; apply Derivation.verumIntro hs hv + · intro s _ p q dp dq hpq hdp hdq ihp ihq + apply Derivation.andIntro hpq ⟨hdp.1, ihp⟩ ⟨hdq.1, ihq⟩ + · intro s _ p q d hpq hd ih + apply Derivation.orIntro hpq ⟨hd.1, ih⟩ + · intro s _ p d hp hd ih + apply Derivation.allIntro hp ⟨hd.1, ih⟩ + · intro s _ p t d hp ht hd ih + apply Derivation.exsIntro hp ht ⟨hd.1, ih⟩ + · intro s hs d h _ ih + apply Derivation.wkRule hs h ⟨rfl, ih⟩ + · rintro s hs d rfl _ ih + apply Derivation.shiftRule ⟨rfl, ih⟩ + · intro s _ p d₁ d₂ h₁ h₂ ih₁ ih₂ + apply Derivation.cutRule ⟨h₁.1, ih₁⟩ ⟨h₂.1, ih₂⟩ + · intro s hs p hps hpT + apply Derivation.axm hs hps (h hpT) + · definability + +end Derivation + +namespace Derivable + +lemma isFormulaSet {s : V} (h : Derivable T s) : IsFormulaSet L s := by + rcases h with ⟨d, hd⟩; exact hd.isFormulaSet + +lemma em {s : V} (hs : IsFormulaSet L s) (p) (h : p ∈ s) (hn : neg L p ∈ s) : Derivable T s := + ⟨axL s p, by simp, Derivation.axL hs h hn⟩ + +lemma verum {s : V} (hs : IsFormulaSet L s) (h : ^⊤ ∈ s) : Derivable T s := + ⟨verumIntro s, by simp, Derivation.verumIntro hs h⟩ + +lemma and_m {s p q : V} (h : p ^⋏ q ∈ s) (hp : Derivable T (insert p s)) + (hq : Derivable T (insert q s)) : Derivable T s := + by + rcases hp with ⟨dp, hdp⟩; rcases hq with ⟨dq, hdq⟩ + exact ⟨andIntro s p q dp dq, by simp, Derivation.andIntro h hdp hdq⟩ + +lemma or_m {s p q : V} (h : p ^⋎ q ∈ s) (hpq : Derivable T (insert p (insert q s))) : + Derivable T s := by + rcases hpq with ⟨dpq, hdpq⟩ + exact ⟨orIntro s p q dpq, by simp, Derivation.orIntro h hdpq⟩ + +lemma all_m {s p : V} (h : ^∀ p ∈ s) (hp : Derivable T (insert (free L p) (setShift L s))) : + Derivable T s := by + rcases hp with ⟨dp, hdp⟩ + exact ⟨allIntro s p dp, by simp, Derivation.allIntro h hdp⟩ + +lemma ex_m {s p t : V} (h : ^∃ p ∈ s) (ht : IsTerm L t) + (hp : Derivable T (insert (substs1 L t p) s)) : Derivable T s := + by + rcases hp with ⟨dp, hdp⟩ + exact ⟨exsIntro s p t dp, by simp, Derivation.exsIntro h ht hdp⟩ + +lemma wk {s s' : V} (hs : IsFormulaSet L s) (h : s' ⊆ s) (hd : Derivable T s') : + Derivable T s := by + rcases hd with ⟨d, hd⟩ + exact ⟨wkRule s d, by simp, Derivation.wkRule hs h hd⟩ + +lemma shift {s : V} (hd : Derivable T s) : Derivable T (setShift L s) := + by + rcases hd with ⟨d, hd⟩ + exact ⟨shiftRule (setShift L s) d, by simp, Derivation.shiftRule hd⟩ + +lemma ofSetEq {s s' : V} (h : ∀ x, x ∈ s' ↔ x ∈ s) (hd : Derivable T s') : Derivable T s := + by + have : s' = s := mem_ext h + rcases this; exact hd + +lemma exchange {s p q : V} (h : Derivable T (insert p <| insert q s)) : + Derivable T (insert q <| insert p s) := + h.ofSetEq (fun x ↦ by simp; tauto) + +lemma cut {s : V} (p) (hd₁ : Derivable T (insert p s)) + (hd₂ : Derivable T (insert (neg L p) s)) : Derivable T s := + by + rcases hd₁ with ⟨d₁, hd₁⟩; rcases hd₂ with ⟨d₂, hd₂⟩ + exact ⟨cutRule s p d₁ d₂, by simp, Derivation.cutRule hd₁ hd₂⟩ + +lemma by_axm {s : V} (hs : IsFormulaSet L s) (p) (hp : p ∈ s) (hT : p ∈ T.Δ₁Class) : + Derivable T s := by exact ⟨Bootstrapping.axm s p, by simp, Derivation.axm hs hp hT⟩ + +lemma of_ss (h : T.Δ₁Class (V := V) ⊆ U.Δ₁Class) {s : V} : Derivable T s → Derivable U s := by + rintro ⟨d, hd⟩; exact ⟨d, hd.1, hd.2.of_ss h⟩ + +lemma and {s p q : V} (hp : Derivable T (insert p s)) (hq : Derivable T (insert q s)) : + Derivable T (insert (p ^⋏ q) s) := + and_m (p := p) (q := q) (by simp) + (wk (by simp [hp.isFormulaSet.insert, hq.isFormulaSet.insert]) + (insert_subset_insert_of_subset _ <| by simp) hp) + (wk (by simp [hp.isFormulaSet.insert, hq.isFormulaSet.insert]) + (insert_subset_insert_of_subset _ <| by simp) hq) + +lemma or {s p q : V} (hpq : Derivable T (insert p (insert q s))) : + Derivable T (insert (p ^⋎ q) s) := + or_m (p := p) (q := q) (by simp) + (wk (by simp [hpq.isFormulaSet.insert, hpq.isFormulaSet.insert.2.insert]) + (insert_subset_insert_of_subset _ <| insert_subset_insert_of_subset _ <| by simp) hpq) + +/-- Crucial inducion for formalized $\Sigma_1$-completeness. -/ +lemma conj (ps : V) {s : V} (hs : IsFormulaSet L s) + (ds : ∀ i < len ps, Derivable T (insert ps.[i] s)) : Derivable T (insert (^⋀ ps) s) := + by + have : ∀ k ≤ len ps, Derivable T (insert (^⋀ (takeLast ps k)) s) := + by + intro k hk + induction k using ISigma1.sigma1_succ_induction + · definability + case zero => simpa using verum (by simp [hs]) (by simp) + case succ k + ih => + have ih : Derivable T (insert (^⋀ takeLast ps k) s) := ih (le_trans le_self_add hk) + have : Derivable T (insert ps.[len ps - (k + 1)] s) := + ds (len ps - (k + 1)) ((tsub_lt_iff_left hk).mpr (by simp)) + simpa [takeLast_succ_of_lt (succ_le_iff_lt.mp hk)] using this.and ih + simpa using this (len ps) (by rfl) + +lemma disjDistr (ps s : V) (d : Derivable T (vecToSet ps ∪ s)) : + Derivable T (insert (^⋁ ps) s) := + by + have : + ∀ k ≤ len ps, + ∀ s' ≤ vecToSet ps, + s' ⊆ vecToSet ps → + (∀ i < len ps - k, ps.[i] ∈ s') → Derivable T (insert (^⋁ takeLast ps k) (s' ∪ s)) := + by + intro k hk + induction k using ISigma1.sigma1_succ_induction + · apply HierarchySymbol.Definable.imp (by definability) + apply HierarchySymbol.Definable.ball_le (by definability) + apply HierarchySymbol.Definable.imp (by definability) + apply HierarchySymbol.Definable.imp (by definability) + definability + case zero => + intro s' _ ss hs' + refine wk ?_ ?_ d + · suffices IsFormulaSet L s' by simpa [by simpa using d.isFormulaSet] + intro x hx + exact d.isFormulaSet x (by simp [ss hx]) + · intro x + simp only [mem_cup_iff, mem_vecToSet_iff, takeLast_zero, qqDisj_nil, mem_bitInsert_iff] + rintro (⟨i, hi, rfl⟩ | hx) + · right; left; exact hs' i (by simpa using hi) + · right; right; exact hx + case succ k ih => + intro s' _ ss hs' + simp only [takeLast_succ_of_lt (succ_le_iff_lt.mp hk), qqDisj_cons] + apply Derivable.or + let s'' := insert ps.[len ps - (k + 1)] s' + have hs'' : s'' ⊆ vecToSet ps := by + intro x; simp only [mem_bitInsert_iff, s''] + rintro (rfl | h) + · exact mem_vecToSet_iff.mpr ⟨_, by simp [tsub_lt_iff_left hk], rfl⟩ + · exact ss h + have : Derivable T (insert (^⋁ takeLast ps k) (s'' ∪ s)) := + by + refine ih (le_trans (by simp) hk) s'' (le_of_subset hs'') hs'' ?_ + intro i hi + have : i ≤ len ps - (k + 1) := by simpa [Arithmetic.sub_sub] using le_sub_one_of_lt hi + rcases lt_or_eq_of_le this with (hi | rfl) + · simp [s'', hs' i hi] + · simp [s''] + exact ofSetEq (by intro x; simp [s'']; tauto) this + simpa using this (len ps) (by rfl) ∅ (by simp [emptyset_def]) (by simp) (by simp) + +lemma disj (ps s : V) {i} (hps : ∀ i < len ps, IsFormula L ps.[i]) (hi : i < len ps) + (d : Derivable T (insert ps.[i] s)) : Derivable T (insert (^⋁ ps) s) := + disjDistr ps s <| + wk + (by + suffices IsFormulaSet L (vecToSet ps) by simpa [by simpa using d.isFormulaSet] + intro x hx; rcases mem_vecToSet_iff.mp hx with ⟨i, hi, rfl⟩; exact hps i hi) + (by + intro x; simp only [mem_bitInsert_iff, mem_cup_iff] + rintro (rfl | hx) + · left; exact mem_vecToSet_iff.mpr ⟨i, hi, rfl⟩ + · right; exact hx) + d + +lemma all {p s : V} (hp : IsSemiformula L 1 p) + (dp : Derivable T (insert (free L p) (setShift L s))) : Derivable T (insert (^∀ p) s) := + all_m (p := p) (by simp) + (wk (by simp [hp, by simpa using dp.isFormulaSet]) (by intro x; simp; tauto) dp) + +lemma exs {p t s : V} (hp : IsSemiformula L 1 p) (ht : IsTerm L t) + (dp : Derivable T (insert (substs1 L t p) s)) : Derivable T (insert (^∃ p) s) := + ex_m (p := p) (by simp) ht <| + wk (by simp [hp, by simpa using dp.isFormulaSet]) (by intro x; simp; tauto) dp + +end Derivable + +lemma internal_provable_iff_internal_derivable {φ : V} : + Provable T φ ↔ Derivable T (insert φ ∅ : V) := + by + constructor + · rintro ⟨b, hb⟩ + exact ⟨b, by simpa using! hb⟩ + · rintro ⟨b, hb⟩ + exact ⟨b, by simpa using! hb⟩ + +alias ⟨Provable.toDerivable, Derivable.toProvable⟩ := internal_provable_iff_internal_derivable + +namespace Provable + +lemma conj (ps : V) (ds : ∀ i < len ps, Provable T ps.[i]) : Provable T (^⋀ ps) := + Derivable.toProvable <| Derivable.conj _ (by simp) fun i hi ↦ (ds i hi).toDerivable + +lemma disj (ps : V) {i} (hps : ∀ i < len ps, IsFormula L ps.[i]) (hi : i < len ps) + (d : Provable T ps.[i]) : Provable T (^⋁ ps) := + Derivable.toProvable <| Derivable.disj _ _ hps hi d.toDerivable + +end Provable + +end Bootstrapping +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Proof/Coding.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Proof/Coding.lean new file mode 100644 index 000000000..9498f1758 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Proof/Coding.lean @@ -0,0 +1,520 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Proof.Typed +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.LK.Simplified + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace FFL +namespace FirstOrder + +open Arithmetic Bootstrapping + +variable {V : Type*} [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +variable {L : Language} [L.DecidableEq] [L.Encodable] [L.LORDefinable] + +variable {T : Theory L} [T.Δ₁] + +namespace LK2 +namespace Derivation + +variable (V) + +/-- The quote construction in `FFL.FirstOrder.LK2.Derivation.Sequent`. -/ +noncomputable def Sequent.quote (Γ : Finset (Proposition L)) : V := + ∑ φ ∈ Γ, Exp.exp (⌜φ⌝ : V) + +noncomputable instance : GödelQuote (Finset (Proposition L)) V := + ⟨Sequent.quote V⟩ + +omit [L.DecidableEq] in +lemma Sequent.quote_def (Γ : Finset (Proposition L)) : ⌜Γ⌝ = ∑ φ ∈ Γ, Exp.exp (⌜φ⌝ : V) := + rfl + +variable {V} + +omit [L.DecidableEq] in +@[simp] +lemma Sequent.quote_empty : (⌜(∅ : Finset (Proposition L))⌝ : V) = ∅ := by + simp [Sequent.quote_def, emptyset_def] + +@[simp] +lemma Sequent.mem_quote_iff {Γ : Finset (Proposition L)} {φ} : ⌜φ⌝ ∈ (⌜Γ⌝ : V) ↔ φ ∈ Γ := + by + induction Γ using Finset.induction generalizing φ + case empty => simp [Sequent.quote_def] + case insert a Γ ha + ih => + have : Exp.exp ⌜a⌝ + ∑ φ ∈ Γ, Exp.exp (⌜φ⌝ : V) = insert (⌜a⌝ : V) (⌜Γ⌝ : V) := + by + suffices ∑ φ ∈ Γ, Exp.exp ⌜φ⌝ = ⌜Γ⌝ by + simpa [insert, bitInsert, (not_iff_not.mpr ih.symm).mp ha, add_comm] + rw [Sequent.quote_def] + simp only [quote_def, ha, not_false_eq_true, Finset.sum_insert, Finset.mem_insert] + rw [this] + simp [← ih] + +lemma Sequent.quote_inj {Γ Δ : Finset (Proposition L)} : (⌜Γ⌝ : V) = ⌜Δ⌝ → Γ = Δ := fun h ↦ by + ext φ; rw [← Sequent.mem_quote_iff (V := V), h]; simp + +omit [L.DecidableEq] in +@[simp] +lemma Sequent.quote_singleton (φ : Proposition L) : + (⌜({ φ } : Finset (Proposition L))⌝ : V) = {⌜φ⌝} := by simp [Sequent.quote_def]; rfl + +omit [L.DecidableEq] in +@[simp] +lemma Sequent.quote_insert [L.DecidableEq] (Γ : Finset (Proposition L)) (φ) : + (⌜(insert φ Γ)⌝ : V) = insert ⌜φ⌝ ⌜Γ⌝ := + by + by_cases hp : φ ∈ Γ + · simp [Sequent.mem_quote_iff, hp, insert_eq_self_of_mem] + · have : (⌜insert φ Γ⌝ : V) = Exp.exp ⌜φ⌝ + ⌜Γ⌝ := by simp [Sequent.quote_def, hp] + simp [Sequent.mem_quote_iff, this, insert_eq, bitInsert, hp, add_comm] + +omit [L.DecidableEq] in +lemma Sequent.mem_quote [L.DecidableEq] {Γ : Finset (Proposition L)} (hx : x ∈ (⌜Γ⌝ : V)) : + ∃ φ ∈ Γ, x = ⌜φ⌝ := by + induction Γ using Finset.induction + case empty => simp at hx + case insert a Γ _ ih => + have : x = ⌜a⌝ ∨ x ∈ (⌜Γ⌝ : V) := by simpa using hx + rcases this with (rfl | hx) + · exact ⟨a, by simp⟩ + · rcases ih hx with ⟨p, hx, rfl⟩ + exact ⟨p, by simp [*]⟩ + +lemma Sequent.mem_quote_iff' {Γ : Finset (Proposition L)} : + x ∈ (⌜Γ⌝ : V) ↔ (∃ φ ∈ Γ, x = ⌜φ⌝) := by + constructor + · intro h; exact Sequent.mem_quote h + · rintro ⟨p, hp, rfl⟩; simp [Sequent.mem_quote_iff, hp] + +@[simp] +lemma Sequent.quote_subset_quote {Γ Δ : Finset (Proposition L)} : (⌜Γ⌝ : V) ⊆ ⌜Δ⌝ ↔ Γ ⊆ Δ := + ⟨fun h _ hp ↦ Sequent.mem_quote_iff.mp <| h <| Sequent.mem_quote_iff.mpr hp, fun h x hx ↦ by + rcases Sequent.mem_quote hx with ⟨φ, hφ, rfl⟩; simp [h hφ]⟩ + +lemma setShift_quote (Γ : Finset (Proposition L)) : + setShift L (⌜Γ⌝ : V) = ⌜Finset.image Rewriting.shift Γ⌝ := + by + apply mem_ext + intro x; simp only [mem_setShift_iff] + constructor + · rintro ⟨x, hx, rfl⟩ + rcases Sequent.mem_quote hx with ⟨p, _, rfl⟩ + rw [← Semiformula.quote_shift, Sequent.mem_quote_iff] + simpa using ⟨p, by simpa [Sequent.mem_quote_iff] using hx, rfl⟩ + · intro hx + rcases Sequent.mem_quote hx with ⟨p', hp', rfl⟩ + rcases by simpa using hp' with ⟨p, hp, rfl⟩ + exact ⟨⌜p⌝, by simpa [Sequent.mem_quote_iff] using hp, by simp [Semiformula.quote_def]⟩ + +@[simp] +lemma formulaSet_quote_finset (Γ : Finset (Proposition L)) : IsFormulaSet L (⌜Γ⌝ : V) := + by + intro x hx + rcases LK2.Derivation.Sequent.mem_quote hx with ⟨p, _, rfl⟩; simp [Semiformula.quote_def] + +noncomputable instance : GödelQuote (Finset (Proposition L)) (Bootstrapping.Sequent V L) := + ⟨fun Γ ↦ ⟨⌜Γ⌝, by simp⟩⟩ + +@[simp] +lemma Sequent.typed_quote_val (Γ : Finset (Proposition L)) : + (⌜Γ⌝ : Bootstrapping.Sequent V L).val = ⌜Γ⌝ := + rfl + +@[simp] +lemma Sequent.quote_mem_quote {φ : Proposition L} {Γ : Finset (Proposition L)} : + ⌜φ⌝ ∈ (⌜Γ⌝ : Bootstrapping.Sequent V L) ↔ φ ∈ Γ := by + simp [Bootstrapping.Sequent.mem_iff, ← Semiformula.quote_def] + +@[simp] +lemma Sequent.typed_quote_insert (Γ : Finset (Proposition L)) (φ) : + (⌜insert φ Γ⌝ : Bootstrapping.Sequent V L) = insert ⌜φ⌝ ⌜Γ⌝ := by + ext; + simp [Bootstrapping.Sequent.mem_iff, Semiformula.quote_def] + +@[simp] +lemma Sequent.typed_quote_empty : + (⌜(∅ : Finset (Proposition L))⌝ : Bootstrapping.Sequent V L) = ∅ := + rfl + +@[simp] +lemma Sequent.typed_quote_singleton (φ : Proposition L) : + (⌜({ φ } : Finset (Proposition L))⌝ : Bootstrapping.Sequent V L) = {⌜φ⌝} := + by + rw [show ({ φ } : Finset (Proposition L)) = insert φ ∅ by simp] + rw [Sequent.typed_quote_insert]; simp [Sequent.insert_empty_eq_singleton] + +@[simp] +lemma setShift_typed_quote (Γ : Finset (Proposition L)) : + (⌜Finset.image Rewriting.shift Γ⌝ : Bootstrapping.Sequent V L) = + (⌜Γ⌝ : Bootstrapping.Sequent V L).shift := + by + apply Sequent.ext' + simp [← setShift_quote]; rfl + +lemma Sequent.typed_quote_inj {Γ Δ : Finset (Proposition L)} : + (⌜Γ⌝ : Bootstrapping.Sequent V L) = ⌜Δ⌝ → Γ = Δ := fun h ↦ + by + have : (⌜Γ⌝ : V) = ⌜Δ⌝ := by simpa using congr_arg Sequent.val h + exact quote_inj this + +lemma Sequent.coe_eq (Γ : Finset (Proposition L)) : (↑(⌜Γ⌝ : ℕ) : V) = ⌜Γ⌝ := + by + induction Γ using Finset.induction + · simp + case insert φ s h ih => simp [insert_absolute, ih, Semiformula.coe_quote_eq_quote] + +@[simp] +lemma Sequent.typed_quote_subset_typed_quote {Γ Δ : Finset (Proposition L)} : + (⌜Γ⌝ : Bootstrapping.Sequent V L) ⊆ ⌜Δ⌝ ↔ Γ ⊆ Δ := + Sequent.quote_subset_quote + +lemma isFormulaSet_sound {s : ℕ} : IsFormulaSet L s → ∃ S : Finset (Proposition L), ⌜S⌝ = s := + by + intro h + have : ∀ x, ∃ φ : Proposition L, x ∈ s → ⌜φ⌝ = x := + by + intro x; by_cases hx : x ∈ s + · simpa [hx] using (h x hx).sound + · simp [hx] + choose ps hps using this + exact + ⟨(s.bitIndices.map ps).toFinset, by + apply mem_ext + intro x + constructor + · intro h + rcases LK2.Derivation.Sequent.mem_quote h with ⟨p, hp, rfl⟩ + rcases by simpa using hp with ⟨x, hx, rfl⟩ + have hxs : x ∈ s := mem_iff_mem_bitIndices.mpr (Nat.mem_bitIndices.mpr hx) + simpa [hps x hxs] using hxs + · intro h + rw [← hps x h] + simpa [LK2.Derivation.Sequent.mem_quote_iff] using + ⟨x, Nat.mem_bitIndices.mp (mem_iff_mem_bitIndices.mp h), rfl⟩⟩ + +variable (V) + +/-- The typed Quote construction in `FFL.FirstOrder.LK2.Derivation`. -/ +noncomputable def typedQuote {Γ : Finset (Proposition L)} : T ⟹₂Γ → T.internalize V ⊢!ᵈᵉʳ ⌜Γ⌝ + | closed Δ φ h hn => + TDerivation.em ⌜φ⌝ (by simpa) (by simpa using! Sequent.quote_mem_quote.mpr hn) + | axm φ hT hΓ => + TDerivation.byAxm ⌜φ⌝ + (by + simp only [tmem, internalize_theory] + exact (Δ₁Class.mem_iff'' (T := T) (φ := φ)).mpr hT) + (by simpa using! Sequent.quote_mem_quote.mpr hΓ) + | verum h => TDerivation.verum (by simpa using! Sequent.quote_mem_quote.mpr h) + | and (φ := φ) (ψ := ψ) h bp bq => + TDerivation.and' (show ⌜φ⌝ ⋏ ⌜ψ⌝ ∈ ⌜Γ⌝ by simpa using! Sequent.quote_mem_quote.mpr h) + (bp.typedQuote.cast (by simp)) (bq.typedQuote.cast (by simp)) + | or (φ := φ) (ψ := ψ) h b => + TDerivation.or' (show ⌜φ⌝ ⋎ ⌜ψ⌝ ∈ ⌜Γ⌝ by simpa using! Sequent.quote_mem_quote.mpr h) <| + b.typedQuote.cast (by simp) + | all (φ := φ) h d => + TDerivation.all' (show ∀¹ ⌜φ⌝ ∈ ⌜Γ⌝ by simpa using! Sequent.quote_mem_quote.mpr h) <| + d.typedQuote.cast (by simp) + | exs (φ := φ) h t d => + TDerivation.exs' (show ∃¹ ⌜φ⌝ ∈ ⌜Γ⌝ by simpa using! Sequent.quote_mem_quote.mpr h) ⌜t⌝ <| + d.typedQuote.cast (by simp [Matrix.constant_eq_singleton]) + | wk d ss => TDerivation.wk d.typedQuote (by simpa) + | shift d => (TDerivation.shift d.typedQuote).cast (by simp) + | cut (φ := φ) d dn => + TDerivation.cut (φ := ⌜φ⌝) (d.typedQuote.cast (by simp)) (dn.typedQuote.cast (by simp)) + +noncomputable instance (Γ : Finset (Proposition L)) : + GödelQuote (T ⟹₂Γ) (T.internalize V ⊢!ᵈᵉʳ ⌜Γ⌝) := + ⟨typedQuote V⟩ + +noncomputable instance (Γ : Finset (Proposition L)) : GödelQuote (T ⟹₂Γ) V := + ⟨fun d ↦ (⌜d⌝ : T.internalize V ⊢!ᵈᵉʳ ⌜Γ⌝).val⟩ + +lemma quote_cast {Γ Δ : Finset (Proposition L)} (d : T ⟹₂Γ) (h : Γ = Δ) : + (⌜LK2.Derivation.cast d h⌝ : V) = ⌜d⌝ := by subst h; rfl + +lemma quote_def (d : T ⟹₂Γ) : (⌜d⌝ : V) = (typedQuote V d).val := + rfl + +section + +attribute [local simp] Semiformula.quote_def Semiterm.quote_def Sentence.quote_eq + +variable {Γ Δ : Finset (Proposition L)} {φ ψ : Proposition L} + +lemma quote_closed (h : φ ∈ Γ) (hn : ∼φ ∈ Γ) : (⌜closed (T := T) Γ φ h hn⌝ : V) = axL ⌜Γ⌝ ⌜φ⌝ := + by simp [quote_def, typedQuote] + +lemma quote_axm (σ : Sentence L) (hT : σ ∈ T) (hΓ : (σ : Proposition L) ∈ Γ) : + (⌜axm (Γ := Γ) σ hT hΓ⌝ : V) = Bootstrapping.axm ⌜Γ⌝ ⌜σ⌝ := by simp [quote_def, typedQuote] + +lemma quote_verum (h : ⊤ ∈ Γ) : (⌜verum (T := T) h⌝ : V) = verumIntro ⌜Γ⌝ := by + simp [quote_def, typedQuote] + +lemma quote_and (h : φ ⋏ ψ ∈ Γ) (d₁ : T ⟹₂insert φ Γ) (d₂ : T ⟹₂insert ψ Γ) : + (⌜and h d₁ d₂⌝ : V) = andIntro ⌜Γ⌝ ⌜φ⌝ ⌜ψ⌝ ⌜d₁⌝ ⌜d₂⌝ := by simp [quote_def, typedQuote] + +lemma quote_or (h : φ ⋎ ψ ∈ Γ) (d : T ⟹₂insert φ (insert ψ Γ)) : + (⌜or h d⌝ : V) = orIntro ⌜Γ⌝ ⌜φ⌝ ⌜ψ⌝ ⌜d⌝ := by simp [quote_def, typedQuote] + +lemma quote_all {φ : Semiproposition L 1} (h : ∀¹ φ ∈ Γ) + (d : T ⟹₂insert (Rewriting.free φ) (Γ.image Rewriting.shift)) : + (⌜all h d⌝ : V) = allIntro ⌜Γ⌝ ⌜φ⌝ ⌜d⌝ := by simp [quote_def, typedQuote] + +lemma quote_exs {φ : Semiproposition L 1} (h : ∃¹ φ ∈ Γ) (t : SyntacticTerm L) + (d : T ⟹₂insert (φ/[t]) Γ) : (⌜exs h t d⌝ : V) = exsIntro ⌜Γ⌝ ⌜φ⌝ ⌜t⌝ ⌜d⌝ := by + simp [quote_def, typedQuote] + +lemma quote_wk (d : T ⟹₂Δ) (ss : Δ ⊆ Γ) : (⌜wk d ss⌝ : V) = wkRule ⌜Γ⌝ ⌜d⌝ := by + simp [quote_def, typedQuote] + +lemma quote_shift (d : T ⟹₂Γ) : (⌜shift d⌝ : V) = shiftRule ⌜Γ.image Rewriting.shift⌝ ⌜d⌝ := by + simp [quote_def, typedQuote, ← setShift_typed_quote] + +lemma quote_cut (d₁ : T ⟹₂insert φ Γ) (d₂ : T ⟹₂insert (∼φ) Γ) : + (⌜cut d₁ d₂⌝ : V) = cutRule ⌜Γ⌝ ⌜φ⌝ ⌜d₁⌝ ⌜d₂⌝ := by simp [quote_def, typedQuote] + +end + +lemma coe_typedQuote_val_eq (d : T ⟹₂Γ) : ↑(d.typedQuote ℕ).val = (d.typedQuote V).val := + match d with + | closed Δ φ h hn => by + simp [typedQuote, axL, nat_cast_pair, Sequent.coe_eq, Semiformula.coe_quote_eq_quote'] + | axm φ hT _ => + by + simp only [typedQuote, TDerivation.byAxm_val, Bootstrapping.axm, Sequent.typed_quote_val, + Nat.cast_add, nat_cast_pair, Sequent.coe_eq, Nat.cast_one, add_left_inj, pair_ext_iff, + true_and] + refine ⟨Nat.cast_ofNat, ?_⟩ + exact Sentence.coe_quote_eq_quote (V := V) φ + | verum h => by simp [typedQuote, Bootstrapping.verumIntro, nat_cast_pair, Sequent.coe_eq] + | and h b₁ b₂ => + by + simp only [typedQuote, TDerivation.and'_val, andIntro, Sequent.typed_quote_val, + TDerivation.cast_val, Nat.cast_add, nat_cast_pair, Sequent.coe_eq, + Semiformula.coe_quote_eq_quote', b₁.coe_typedQuote_val_eq, b₂.coe_typedQuote_val_eq, + Nat.cast_one, add_left_inj, pair_ext_iff, and_true, true_and] + exact Nat.cast_ofNat + | or h b => + by + simp only [typedQuote, TDerivation.or'_val, orIntro, Sequent.typed_quote_val, + TDerivation.cast_val, Nat.cast_add, nat_cast_pair, Sequent.coe_eq, + Semiformula.coe_quote_eq_quote', b.coe_typedQuote_val_eq, Nat.cast_one, add_left_inj, + pair_ext_iff, and_true, true_and] + exact Nat.cast_ofNat + | all h b => + by + simp only [typedQuote, Nat.reduceAdd, TDerivation.all'_val, allIntro, Sequent.typed_quote_val, + TDerivation.cast_val, Nat.cast_add, nat_cast_pair, Sequent.coe_eq, + Semiformula.coe_quote_eq_quote', b.coe_typedQuote_val_eq, Nat.cast_one, add_left_inj, + pair_ext_iff, and_true, true_and] + exact Nat.cast_ofNat + | exs h t b => + by + simp only [typedQuote, Nat.reduceAdd, Nat.succ_eq_add_one, TDerivation.exs'_val, exsIntro, + Sequent.typed_quote_val, TDerivation.cast_val, Nat.cast_add, nat_cast_pair, Sequent.coe_eq, + Semiformula.coe_quote_eq_quote', Semiterm.coe_quote_eq_quote', b.coe_typedQuote_val_eq, + Nat.cast_one, add_left_inj, pair_ext_iff, and_true, true_and] + exact Nat.cast_ofNat + | wk b ss => + by + simp only [typedQuote, TDerivation.wk_val, wkRule, Sequent.typed_quote_val, Nat.cast_add, + nat_cast_pair, Sequent.coe_eq, b.coe_typedQuote_val_eq, Nat.cast_one, add_left_inj, + pair_ext_iff, and_true, true_and] + exact Nat.cast_ofNat + | shift b => + by + simp only [typedQuote, TDerivation.cast_val, TDerivation.shift_val, shiftRule, + ← setShift_typed_quote, Sequent.typed_quote_val, Nat.cast_add, nat_cast_pair, + Sequent.coe_eq, b.coe_typedQuote_val_eq, Nat.cast_one, add_left_inj, pair_ext_iff, and_true, + true_and] + exact Nat.cast_ofNat + | cut b₁ b₂ => + by + simp only [typedQuote, TDerivation.cut_val, cutRule, Sequent.typed_quote_val, + TDerivation.cast_val, Nat.cast_add, nat_cast_pair, Sequent.coe_eq, + Semiformula.coe_quote_eq_quote', b₁.coe_typedQuote_val_eq, b₂.coe_typedQuote_val_eq, + Nat.cast_one, add_left_inj, pair_ext_iff, and_true, true_and] + exact Nat.cast_ofNat + +lemma coe_quote_eq (d : T ⟹₂Γ) : (↑(⌜d⌝ : ℕ) : V) = ⌜d⌝ := + coe_typedQuote_val_eq V d + +end Derivation +end LK2 + +noncomputable instance (Γ : LK.Sequent L) : GödelQuote (⊢ᴸᴷ¹ Γ) V := + ⟨fun b ↦ ⌜LK.Derivation.toDerivation2 (∅ : Theory L) b⌝⟩ + +noncomputable instance (φ : Sentence L) : GödelQuote (T ⊢! φ) V := + ⟨fun b ↦ ⌜b.toProof2⌝⟩ + +lemma quote_derivation_def {Γ : LK.Sequent L} (b : ⊢ᴸᴷ¹ Γ) : + (⌜b⌝ : V) = ⌜LK.Derivation.toDerivation2 (∅ : Theory L) b⌝ := + rfl + +lemma quote_proof_def {φ : Sentence L} (b : T ⊢! φ) : (⌜b⌝ : V) = ⌜b.toProof2⌝ := + rfl + +@[simp] +lemma derivation_of_quote_derivation {Γ : LK.Sequent L} (b : ⊢ᴸᴷ¹ Γ) : + DerivationOf T (⌜b⌝ : V) ⌜Γ.toFinset⌝ := + by + let x := LK2.Derivation.typedQuote V (LK.Derivation.toDerivation2 (∅ : Theory L) b) + suffices DerivationOf T x.val ⌜Γ.toFinset⌝ from this + exact + ⟨x.derivationOf.1, + x.derivationOf.2.of_ss + (by + intro p hp + change V ⊧/![p] (⊥ : ∆₁.Semisentence 1).val at hp + simp at hp)⟩ + +@[simp] +lemma proof_of_quote_proof2 {φ : Sentence L} (d : T ⊢₂! (φ : Proposition L)) : + Proof T (⌜d⌝ : V) ⌜φ⌝ := + by + let x := LK2.Derivation.typedQuote V d + suffices Proof T x.val ⌜φ⌝ from this + simpa using! x.derivationOf + +@[simp] +lemma proof_of_quote_proof {φ : Sentence L} (b : T ⊢! φ) : Proof T (⌜b⌝ : V) ⌜φ⌝ := + proof_of_quote_proof2 b.toProof2 + +lemma coe_quote_proof_eq (d : T ⊢! φ) : (↑(⌜d⌝ : ℕ) : V) = ⌜d⌝ := by + simp [quote_proof_def, LK2.Derivation.coe_quote_eq] + +namespace Arithmetic +namespace Bootstrapping + +open LK2.Derivation + +lemma Derivation.sound {d : ℕ} (h : Derivation T d) : ∃ Γ, ⌜Γ⌝ = fstIdx d ∧ T ⟹₂! Γ := + by + induction d using Nat.strongRec + case ind d ih => + rcases h.case with ⟨hs, H⟩ + rcases isFormulaSet_sound hs with ⟨Γ, hΓ⟩ + refine ⟨Γ, hΓ, ?_⟩ + rcases H with + (⟨s, φ, rfl, hφ, hnp⟩ | ⟨s, rfl, hv⟩ | ⟨s, φ, ψ, dp, dq, rfl, hpq, ⟨hφ, hdφ⟩, ⟨hψ, hdq⟩⟩ | + ⟨s, φ, ψ, d, rfl, hpq, ⟨h, hd⟩⟩ | ⟨s, φ, d, rfl, hps, hd, dd⟩ | + ⟨s, φ, t, d, rfl, hps, ht, hd, dd⟩ | ⟨s, d, rfl, hs, dd⟩ | ⟨s, d, rfl, rfl, dd⟩ | + ⟨s, φ, d₁, d₂, rfl, ⟨h₁, dd₁⟩, ⟨h₂, dd₂⟩⟩ | ⟨s, φ, rfl, hs, hT⟩) + · rcases (hs φ (by simp [hφ])).sound with ⟨φ, rfl⟩ + refine + ⟨LK2.Derivation.closed Γ φ (by simp [← Sequent.mem_quote_iff (V := ℕ), hΓ, hφ]) + (by simpa [← Sequent.mem_quote_iff (V := ℕ), hΓ, Semiformula.quote_def] using hnp)⟩ + · refine ⟨LK2.Derivation.verum (by simp [← Sequent.mem_quote_iff (V := ℕ), hΓ, hv])⟩ + · have fpq : IsFormula L φ ∧ IsFormula L ψ := by simpa using hs (φ ^⋏ ψ) (by simp [hpq]) + rcases by simpa using hΓ + rcases fpq.1.sound with ⟨φ, rfl⟩ + rcases fpq.2.sound with ⟨ψ, rfl⟩ + rcases ih dp (by simp) hdφ with ⟨Γφ, hΓφ, ⟨bφ⟩⟩ + rcases ih dq (by simp) hdq with ⟨Γψ, hΓψ, ⟨bψ⟩⟩ + refine + ⟨LK2.Derivation.and (φ := φ) (ψ := ψ) (by simp [← Sequent.mem_quote_iff (V := ℕ), hpq]) + (bφ.cast <| Sequent.quote_inj (V := ℕ) (by simp [hΓφ, hφ])) + (bψ.cast <| Sequent.quote_inj (V := ℕ) (by simp [hΓψ, hψ]))⟩ + · have fpq : IsFormula L φ ∧ IsFormula L ψ := by simpa using hs (φ ^⋎ ψ) (by simp [hpq]) + rcases by simpa using hΓ + rcases fpq.1.sound with ⟨φ, rfl⟩ + rcases fpq.2.sound with ⟨ψ, rfl⟩ + rcases ih d (by simp) hd with ⟨Δ, hΔ, ⟨b⟩⟩ + refine + ⟨LK2.Derivation.or (φ := φ) (ψ := ψ) + (by simp [← Sequent.mem_quote_iff (V := ℕ), Semiformula.quote_or, hpq]) + (b.cast <| Sequent.quote_inj (V := ℕ) (by simp [hΔ, h]))⟩ + · rcases by simpa using hΓ + have : IsSemiformula L 1 φ := by simpa using hs (^∀ φ) (by simp [hps]) + rcases this.sound with ⟨φ, rfl⟩ + rcases ih d (by simp) dd with ⟨Δ, hΔ, ⟨b⟩⟩ + refine + ⟨LK2.Derivation.all (φ := φ) + (by simp [← Sequent.mem_quote_iff (V := ℕ), Semiformula.quote_all, hps]) + (b.cast <| + Sequent.quote_inj (V := ℕ) <| by + simp [hΔ, hd, setShift_quote, Semiformula.quote_def])⟩ + · rcases by simpa using hΓ + have : IsSemiformula L 1 φ := by simpa using hs (^∃ φ) (by simp [hps]) + rcases this.sound with ⟨φ, rfl⟩ + rcases ht.sound with ⟨t, rfl⟩ + rcases ih d (by simp) dd with ⟨Δ, hΔ, ⟨b⟩⟩ + refine + ⟨LK2.Derivation.exs (φ := φ) + (by simp [← Sequent.mem_quote_iff (V := ℕ), Semiformula.quote_ex, hps]) t + (b.cast <| + Sequent.quote_inj (V := ℕ) <| by + simp [hΔ, hd, substs1, Matrix.constant_eq_singleton, Semiformula.quote_def, + Semiterm.quote_def])⟩ + · rcases by simpa using hΓ + rcases ih d (by simp) dd with ⟨Δ, hΔ, ⟨b⟩⟩ + refine + ⟨LK2.Derivation.wk (Δ := Δ) b + ((Sequent.quote_subset_quote (V := ℕ)).mp <| by simp [hΔ, hs])⟩ + · rcases ih d (by simp) dd with ⟨Δ, hΔ, ⟨b⟩⟩ + have : Γ = Finset.image Rewriting.shift Δ := + Sequent.quote_inj <| by simpa [← hΔ, setShift_quote] using hΓ + rcases this + refine ⟨LK2.Derivation.shift b⟩ + · rcases by simpa using hΓ + have : IsFormula L φ := dd₁.isFormulaSet φ (by simp [h₁]) + rcases this.sound with ⟨φ, rfl⟩ + rcases ih d₁ (by simp) dd₁ with ⟨Δ₁, hΔ₁, ⟨b₁⟩⟩ + have : Δ₁ = (φ ∷ᵀ Γ) := Sequent.quote_inj (V := ℕ) <| by simp [hΔ₁, h₁] + rcases this + rcases ih d₂ (by simp) dd₂ with ⟨Δ₂, hΔ₂, ⟨b₂⟩⟩ + have : Δ₂ = (∼φ ∷ᵀ Γ) := + Sequent.quote_inj (V := ℕ) <| by simp [hΔ₂, h₂, Semiformula.quote_def] + rcases this + refine ⟨LK2.Derivation.cut b₁ b₂⟩ + · rcases by simpa using hΓ + rcases Sequent.mem_quote hs with ⟨φ, hφ, rfl⟩ + have : ∃ σ ∈ T, φ = ↑σ := by simpa using hT + rcases this with ⟨σ, hσ, rfl⟩ + refine ⟨LK2.Derivation.axm σ (by simp [hσ]) hφ⟩ + +/-- The sound2 construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.Provable`. -/ +noncomputable def Provable.sound2 {φ : Proposition L} (h : Provable T (⌜φ⌝ : ℕ)) : T ⊢₂! φ := + by + let d := Classical.choose h + have hd : Proof T d (⌜φ⌝ : ℕ) := Classical.choose_spec h + let Γ := Classical.choose hd.2.sound + have hΓ := Classical.choose_spec hd.2.sound + rcases hΓ with ⟨e, b⟩ + have hΓ : Γ = { φ } := + Sequent.quote_inj (V := ℕ) <| by + rw [e, hd.1] + simp + exact LK2.Derivation.cast (Classical.choice b) hΓ + +lemma Provable.sound {φ : Sentence L} (h : Provable T (⌜φ⌝ : ℕ)) : T ⊢ φ := + provable_iff_derivable2.mpr ⟨Provable.sound2 (by simpa using! h)⟩ + +end Bootstrapping +end Arithmetic + +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Proof/Typed.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Proof/Typed.lean new file mode 100644 index 000000000..76c402efe --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Proof/Typed.lean @@ -0,0 +1,844 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Proof.Basic + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +/-! +# Typed internal Tait-calculus +-/ + +namespace FFL + +open FirstOrder Arithmetic + +variable {V : Type*} [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +variable {L : Language} [L.Encodable] [L.LORDefinable] + +namespace FirstOrder +namespace Arithmetic +namespace Bootstrapping + +section typed_theory + +/-- The tmem construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +abbrev tmem (φ : Formula V L) (T : Theory L) [T.Δ₁] : Prop := + φ.val ∈ T.Δ₁Class + +/-- The «term ∈' » construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +scoped infix:50 " ∈' " => tmem + +end typed_theory + +section typed_sequent + +variable (V L) + +/-- Data and laws for Sequent in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +structure Sequent where + /-- The val construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.Sequent`. -/ + val : V + val_formulaSet : IsFormulaSet L val + +attribute [simp] Sequent.val_formulaSet + +variable {V L} + +instance : EmptyCollection (Sequent V L) := + ⟨⟨∅, by simp⟩⟩ + +noncomputable instance : Singleton (Formula V L) (Sequent V L) := + ⟨fun φ ↦ ⟨{ φ.val }, by simp⟩⟩ + +noncomputable instance : Insert (Formula V L) (Sequent V L) := + ⟨fun φ Γ ↦ ⟨insert φ.val Γ.val, by simp⟩⟩ + +noncomputable instance : Union (Sequent V L) := + ⟨fun Γ Δ ↦ ⟨Γ.val ∪ Δ.val, by simp⟩⟩ + +instance : Membership (Formula V L) (Sequent V L) := + ⟨fun Γ φ ↦ (φ.val ∈ Γ.val)⟩ + +instance : HasSubset (Sequent V L) := + ⟨(·.val ⊆ ·.val)⟩ + +/-- The «term ∷ᵀ » construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +scoped infixr:50 " ∷ᵀ " => Insert.insert + +namespace Sequent + +variable {Γ Δ : Sequent V L} {φ ψ : Formula V L} + +lemma mem_iff : φ ∈ Γ ↔ φ.val ∈ Γ.val := + iff_of_eq rfl + +lemma subset_iff : Γ ⊆ Δ ↔ Γ.val ⊆ Δ.val := + iff_of_eq rfl + +@[simp] +lemma val_empty : (∅ : (Sequent V L)).val = ∅ := + rfl + +@[simp] +lemma val_singleton (φ : Formula V L) : ({ φ } : (Sequent V L)).val = { φ.val } := + rfl + +@[simp] +lemma val_insert (φ : Formula V L) (Γ : (Sequent V L)) : + (insert φ Γ).val = insert φ.val Γ.val := + rfl + +@[simp] +lemma val_union (Γ Δ : (Sequent V L)) : (Γ ∪ Δ).val = Γ.val ∪ Δ.val := + rfl + +@[simp] +lemma not_mem_empty (φ : Formula V L) : φ ∉ (∅ : (Sequent V L)) := by simp [mem_iff] + +@[simp] +lemma mem_singleton_iff : φ ∈ ({ ψ } : (Sequent V L)) ↔ φ = ψ := by + simp [mem_iff, Semiformula.val_inj] + +@[simp] +lemma mem_insert_iff : φ ∈ insert ψ Γ ↔ φ = ψ ∨ φ ∈ Γ := by simp [mem_iff, Semiformula.val_inj] + +@[simp] +lemma mem_union_iff : φ ∈ Γ ∪ Δ ↔ φ ∈ Γ ∨ φ ∈ Δ := by simp [mem_iff] + +@[ext] +lemma ext (h : ∀ x, x ∈ Γ ↔ x ∈ Δ) : Γ = Δ := + by + rcases Γ with ⟨Γ, hΓ⟩; rcases Δ with ⟨Δ, hΔ⟩ + suffices ∀ x, x ∈ Γ ↔ x ∈ Δ by simpa using mem_ext this + intro x + constructor + · intro hx; simpa using mem_iff.mp <| h ⟨x, hΓ x hx⟩ |>.1 (by simp [mem_iff, hx]) + · intro hx; simpa using mem_iff.mp <| h ⟨x, hΔ x hx⟩ |>.2 (by simp [mem_iff, hx]) + +lemma ext' (h : Γ.val = Δ.val) : Γ = Δ := by rcases Γ; rcases Δ; simpa using h + +lemma insert_empty_eq_singleton : insert φ (∅ : Sequent V L) = { φ } := by ext; simp + +/-- The shift construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.Sequent`. -/ +noncomputable def shift (s : (Sequent V L)) : (Sequent V L) := + ⟨setShift L s.val, by simp⟩ + +@[simp] +lemma shift_empty : (∅ : (Sequent V L)).shift = ∅ := + ext' <| by simp [shift] + +@[simp] +lemma shift_insert : (insert φ Γ).shift = insert φ.shift Γ.shift := + ext' <| by simp [shift] + +lemma insert_eq_of_mem (h : φ ∈ Γ) : insert φ Γ = Γ := by + ext; + simp only [mem_insert_iff, or_iff_right_iff_imp]; rintro rfl; simpa + +end Sequent + +end typed_sequent + +section typed_derivation + +/-- Auxiliary theories for the typed internal proof. -/ +structure InternalTheory (V : Type*) (L : Language) [L.Encodable] [L.LORDefinable] where + /-- The theory construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.InternalTheory`. -/ + theory : Theory L + /-- The Δ₁ construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.InternalTheory`. -/ + Δ₁ : theory.Δ₁ + +instance : CoeOut (InternalTheory V L) (Theory L) := + ⟨InternalTheory.theory⟩ + +instance (T : InternalTheory V L) : T.theory.Δ₁ := + T.Δ₁ + +variable (V) + +/-- The internalize construction in `FFL.FirstOrder.Theory`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Theory.internalize (T : Theory L) [T.Δ₁] : + InternalTheory V L := + ⟨T, inferInstance⟩ + +variable {V} + +omit [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] in +@[simp] +lemma internalize_theory (T : Theory L) [T.Δ₁] : (T.internalize V).theory = T := + rfl + +/-- Data and laws for TDerivation in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +structure TDerivation (T : InternalTheory V L) (Γ : Sequent V L) where + /-- The val construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TDerivation`. -/ + val : V + derivationOf : DerivationOf T.theory val Γ.val + +attribute [simp] TDerivation.derivationOf + +/-- The «term ⊢!ᵈᵉʳ » construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +scoped infix:45 " ⊢!ᵈᵉʳ " => TDerivation + +/-- The TProof construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +def TProof (T : InternalTheory V L) (φ : Formula V L) := + T ⊢!ᵈᵉʳ insert φ ∅ + +instance : Entailment (InternalTheory V L) (Formula V L) := + ⟨TProof⟩ + +instance : HasSubset (InternalTheory V L) := + ⟨fun T U ↦ T.theory.Δ₁Class (V := V) ⊆ U.theory.Δ₁Class⟩ + +variable {T U : InternalTheory V L} + +/-- The to TDerivation construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.Derivable`. -/ +noncomputable def + _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.Bootstrapping.Derivable.toTDerivation + (Γ : Sequent V L) (h : Derivable T.theory Γ.val) : T ⊢!ᵈᵉʳ Γ := + by + choose a ha using h; choose d hd using ha.2 + exact ⟨a, ha.1, d, hd⟩ + +lemma TDerivation.toDerivable {Γ : (Sequent V L)} (d : T ⊢!ᵈᵉʳ Γ) : Derivable T.theory Γ.val := + ⟨d.val, d.derivationOf⟩ + +lemma TProvable.iff_provable {σ : Formula V L} : T ⊢ σ ↔ Provable T.theory σ.val := + by + constructor + · intro b + simpa [← singleton_eq_insert] using! TDerivation.toDerivable b.get + · intro h + exact ⟨Derivable.toTDerivation _ <| by simpa [← singleton_eq_insert] using! h⟩ + +alias ⟨toProvable, + _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.Bootstrapping.Provable.toTProvable⟩ := + TProvable.iff_provable + +def proof_to_tDerivation {σ : Formula V L} : T ⊢! σ → T ⊢!ᵈᵉʳ insert σ ∅ := fun x ↦ x + +lemma tprovable_iff_provable {T : Theory L} [T.Δ₁] {σ : Formula V L} : + T.internalize V ⊢ σ ↔ Provable T σ.val := + TProvable.iff_provable + +lemma tprovable_tquote_iff_provable_quote {T : Theory L} [T.Δ₁] {φ : Proposition L} : + T.internalize V ⊢ ⌜φ⌝ ↔ Provable T (⌜φ⌝ : V) := + TProvable.iff_provable + +lemma tprovable_tquote_iff_provable_quote_sentence {T : Theory L} [T.Δ₁] {σ : Sentence L} : + T.internalize V ⊢ ⌜σ⌝ ↔ Provable T (⌜σ⌝ : V) := + TProvable.iff_provable + +/-- The to TProof construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TDerivation`. -/ +def TDerivation.toTProof {φ} (d : T ⊢!ᵈᵉʳ insert φ ∅) : T ⊢! φ := + d + +/-- Transport an internal derivation along equality of its sequents. -/ +def TDerivation.ofEq (d : T ⊢!ᵈᵉʳ Γ) (e : Γ = Δ) : T ⊢!ᵈᵉʳ Δ := by rcases e; exact d + +/-- The to TDerivation construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TProof`. -/ +def TProof.toTDerivation {φ} (d : T ⊢! φ) : T ⊢!ᵈᵉʳ insert φ ∅ := + d + +namespace TDerivation + +variable {Γ Δ : (Sequent V L)} {φ ψ p₀ p₁ p₂ p₃ p₄ : Formula V L} + +/-- The cast construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TDerivation`. -/ +protected noncomputable def cast {Γ Δ : Bootstrapping.Sequent V L} (e : Γ = Δ) : + T ⊢!ᵈᵉʳ Γ → T ⊢!ᵈᵉʳ Δ := fun d ↦ by rcases e; exact d + +@[simp] +lemma cast_val {Γ Δ : Bootstrapping.Sequent V L} (e : Γ = Δ) (d : T ⊢!ᵈᵉʳ Γ) : + (TDerivation.cast e d).val = d.val := by rcases e; simp [TDerivation.cast] + +/-- The by Axm construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TDerivation`. -/ +noncomputable def byAxm (φ) (h : φ ∈' T.theory) (hΓ : φ ∈ Γ) : T ⊢!ᵈᵉʳ Γ := + ⟨Bootstrapping.axm Γ.val φ.val, by simp, Derivation.axm (by simp) (by simpa) h⟩ + +@[simp] +lemma byAxm_val (φ) (h : φ ∈' T.theory) (hΓ : φ ∈ Γ) : + (byAxm φ h hΓ).val = Bootstrapping.axm Γ.val φ.val := + rfl + +/-- The em construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TDerivation`. -/ +noncomputable def em (φ) (h : φ ∈ Γ := by simp) (hn : ∼φ ∈ Γ := by simp) : T ⊢!ᵈᵉʳ Γ := + ⟨axL Γ.val φ.val, by simp, Derivation.axL (by simp) h hn⟩ + +@[simp] +lemma em_val (φ) (h : φ ∈ Γ) (hn : ∼φ ∈ Γ) : + (em φ h hn : T ⊢!ᵈᵉʳ Γ).val = Bootstrapping.axL Γ.val φ.val := + rfl + +/-- The verum construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TDerivation`. -/ +noncomputable def verum (h : ⊤ ∈ Γ := by simp) : T ⊢!ᵈᵉʳ Γ := + ⟨verumIntro Γ.val, by simp, Derivation.verumIntro (by simp) h⟩ + +@[simp] +lemma verum_val (h : ⊤ ∈ Γ) : (verum h : T ⊢!ᵈᵉʳ Γ).val = Bootstrapping.verumIntro Γ.val := + rfl + +/-- The and' construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TDerivation`. -/ +noncomputable def and' (H : φ ⋏ ψ ∈ Γ) (dp : T ⊢!ᵈᵉʳ insert φ Γ) (dq : T ⊢!ᵈᵉʳ insert ψ Γ) : + T ⊢!ᵈᵉʳ Γ := + ⟨andIntro Γ.val φ.val ψ.val dp.val dq.val, by simp, + Derivation.andIntro (by simpa) (by simpa using dp.derivationOf) + (by simpa using dq.derivationOf)⟩ + +@[simp] +lemma and'_val (H : φ ⋏ ψ ∈ Γ) (dp : T ⊢!ᵈᵉʳ insert φ Γ) (dq : T ⊢!ᵈᵉʳ insert ψ Γ) : + (and' H dp dq : T ⊢!ᵈᵉʳ Γ).val = andIntro Γ.val φ.val ψ.val dp.val dq.val := + rfl + +/-- The or' construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TDerivation`. -/ +noncomputable def or' (H : φ ⋎ ψ ∈ Γ) (dpq : T ⊢!ᵈᵉʳ insert φ (insert ψ Γ)) : T ⊢!ᵈᵉʳ Γ := + ⟨orIntro Γ.val φ.val ψ.val dpq.val, by simp, + Derivation.orIntro (by simpa) (by simpa using dpq.derivationOf)⟩ + +@[simp] +lemma or'_val (H : φ ⋎ ψ ∈ Γ) (dpq : T ⊢!ᵈᵉʳ insert φ (insert ψ Γ)) : + (or' H dpq : T ⊢!ᵈᵉʳ Γ).val = orIntro Γ.val φ.val ψ.val dpq.val := + rfl + +/-- The all' construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TDerivation`. -/ +noncomputable def all' {φ : Semiformula V L 1} (H : ∀¹ φ ∈ Γ) + (dp : T ⊢!ᵈᵉʳ insert φ.free Γ.shift) : T ⊢!ᵈᵉʳ Γ := + ⟨allIntro Γ.val φ.val dp.val, by simp, + Derivation.allIntro (by simpa) (by simpa using! dp.derivationOf)⟩ + +@[simp] +lemma all'_val {φ : Semiformula V L 1} (H : ∀¹ φ ∈ Γ) (dp : T ⊢!ᵈᵉʳ insert φ.free Γ.shift) : + (all' H dp : T ⊢!ᵈᵉʳ Γ).val = allIntro Γ.val φ.val dp.val := + rfl + +/-- The exs' construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TDerivation`. -/ +noncomputable def exs' {φ : Semiformula V L 1} (H : ∃¹ φ ∈ Γ) (t : Term V L) + (dp : T ⊢!ᵈᵉʳ insert (φ.subst ![t]) Γ) : T ⊢!ᵈᵉʳ Γ := + ⟨exsIntro Γ.val φ.val t.val dp.val, by simp, + Derivation.exsIntro (by simpa) (by simp) (by simpa using! dp.derivationOf)⟩ + +@[simp] +lemma exs'_val {φ : Semiformula V L 1} (H : ∃¹ φ ∈ Γ) (t : Term V L) + (dp : T ⊢!ᵈᵉʳ insert (φ.subst ![t]) Γ) : + (exs' H t dp : T ⊢!ᵈᵉʳ Γ).val = exsIntro Γ.val φ.val t.val dp.val := + rfl + +/-- The wk construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TDerivation`. -/ +noncomputable def wk (d : T ⊢!ᵈᵉʳ Δ) (h : Δ ⊆ Γ) : T ⊢!ᵈᵉʳ Γ := + ⟨wkRule Γ.val d.val, by simp, Derivation.wkRule (s' := Δ.val) (by simp) (by simpa) (by simp)⟩ + +@[simp] +lemma wk_val (d : T ⊢!ᵈᵉʳ Δ) (h : Δ ⊆ Γ) : (wk d h).val = wkRule Γ.val d.val := + rfl + +/-- The shift construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TDerivation`. -/ +noncomputable def shift (d : T ⊢!ᵈᵉʳ Γ) : T ⊢!ᵈᵉʳ Γ.shift := + ⟨shiftRule Γ.shift.val d.val, by simp, Derivation.shiftRule (by simp)⟩ + +@[simp] +lemma shift_val (d : T ⊢!ᵈᵉʳ Γ) : (shift d).val = shiftRule Γ.shift.val d.val := + rfl + +/-- The cut construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TDerivation`. -/ +noncomputable def cut (d₁ : T ⊢!ᵈᵉʳ insert φ Γ) (d₂ : T ⊢!ᵈᵉʳ insert (∼φ) Γ) : T ⊢!ᵈᵉʳ Γ := + ⟨cutRule Γ.val φ.val d₁.val d₂.val, by simp, + Derivation.cutRule (by simpa using d₁.derivationOf) (by simpa using d₂.derivationOf)⟩ + +@[simp] +lemma cut_val (d₁ : T ⊢!ᵈᵉʳ insert φ Γ) (d₂ : T ⊢!ᵈᵉʳ insert (∼φ) Γ) : + (cut d₁ d₂).val = cutRule Γ.val φ.val d₁.val d₂.val := + rfl + +/-- The and construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TDerivation`. -/ +noncomputable def and (dp : T ⊢!ᵈᵉʳ insert φ Γ) (dq : T ⊢!ᵈᵉʳ insert ψ Γ) : + T ⊢!ᵈᵉʳ insert (φ ⋏ ψ) Γ := + Derivable.toTDerivation _ <| by + simpa using Derivable.and (by simpa using dp.toDerivable) (by simpa using dq.toDerivable) + +/-- The or construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TDerivation`. -/ +noncomputable def or (dpq : T ⊢!ᵈᵉʳ insert φ (insert ψ Γ)) : T ⊢!ᵈᵉʳ insert (φ ⋎ ψ) Γ := + Derivable.toTDerivation _ <| by simpa using Derivable.or (by simpa using dpq.toDerivable) + +/-- The all construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TDerivation`. -/ +noncomputable def all {φ : Semiformula V L 1} (dp : T ⊢!ᵈᵉʳ insert φ.free Γ.shift) : + T ⊢!ᵈᵉʳ insert (∀¹ φ) Γ := + Derivable.toTDerivation _ <| by + simpa using! Derivable.all (by simp) (by simpa using! dp.toDerivable) + +/-- The exs construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TDerivation`. -/ +noncomputable def exs {φ : Semiformula V L 1} (t : Term V L) + (dp : T ⊢!ᵈᵉʳ insert (φ.subst ![t]) Γ) : T ⊢!ᵈᵉʳ insert (∃¹ φ) Γ := + Derivable.toTDerivation _ <| by + simpa using! Derivable.exs (by simp) t.isSemiterm (by simpa using! dp.toDerivable) + +/-- The of Subset construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TDerivation`. -/ +def ofSubset (h : T ⊆ U) (d : T ⊢!ᵈᵉʳ Γ) : U ⊢!ᵈᵉʳ Γ + where + val := d.val + derivationOf := ⟨d.derivationOf.1, d.derivationOf.2.of_ss h⟩ + +/-- The cut' construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TDerivation`. -/ +noncomputable def cut' (d₁ : T ⊢!ᵈᵉʳ insert φ Γ) (d₂ : T ⊢!ᵈᵉʳ insert (∼φ) Δ) : T ⊢!ᵈᵉʳ Γ ∪ Δ := + cut (φ := φ) (d₁.wk (by intro x; simp; tauto)) (d₂.wk (by intro x; simp; tauto)) + +/-- The modus Ponens construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TDerivation`. -/ +noncomputable def modusPonens (dpq : T ⊢!ᵈᵉʳ insert (φ ⇒ₗ ψ) Γ) (dp : T ⊢!ᵈᵉʳ insert φ Γ) : + T ⊢!ᵈᵉʳ insert ψ Γ := + by + let d : T ⊢!ᵈᵉʳ insert (φ ⇒ₗ ψ) (insert ψ Γ) := + dpq.wk (insert_subset_insert_of_subset _ <| by simp) + let b : T ⊢!ᵈᵉʳ insert (∼(φ ⇒ₗ ψ)) (insert ψ Γ) := + by + simp only [Semiformula.imp_def, LogicalConnective.DeMorgan.or, LogicalNeutral.DeMorgan.neg] + exact and (dp.wk (insert_subset_insert_of_subset _ <| by simp)) (em ψ (by simp) (by simp)) + exact cut d b + +/-- The rotate₁ construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TDerivation`. -/ +noncomputable def rotate₁ (d : T ⊢!ᵈᵉʳ p₀ ∷ᵀ p₁ ∷ᵀ Γ) : T ⊢!ᵈᵉʳ p₁ ∷ᵀ p₀ ∷ᵀ Γ := + ofEq d (by ext x; simp; tauto) + +/-- The rotate₂ construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TDerivation`. -/ +noncomputable def rotate₂ (d : T ⊢!ᵈᵉʳ p₀ ∷ᵀ p₁ ∷ᵀ p₂ ∷ᵀ Γ) : T ⊢!ᵈᵉʳ p₂ ∷ᵀ p₁ ∷ᵀ p₀ ∷ᵀ Γ := + ofEq d (by ext x; simp; tauto) + +/-- The rotate₃ construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TDerivation`. -/ +noncomputable def rotate₃ (d : T ⊢!ᵈᵉʳ p₀ ∷ᵀ p₁ ∷ᵀ p₂ ∷ᵀ p₃ ∷ᵀ Γ) : + T ⊢!ᵈᵉʳ p₃ ∷ᵀ p₁ ∷ᵀ p₂ ∷ᵀ p₀ ∷ᵀ Γ := + ofEq d (by ext x; simp; tauto) + +/-- The or Inv construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TDerivation`. -/ +noncomputable def orInv (d : T ⊢!ᵈᵉʳ φ ⋎ ψ ∷ᵀ Γ) : T ⊢!ᵈᵉʳ φ ∷ᵀ ψ ∷ᵀ Γ := + by + have b : T ⊢!ᵈᵉʳ φ ⋎ ψ ∷ᵀ φ ∷ᵀ ψ ∷ᵀ Γ := wk d (by intro x; simp; tauto) + have : T ⊢!ᵈᵉʳ ∼(φ ⋎ ψ) ∷ᵀ φ ∷ᵀ ψ ∷ᵀ Γ := + by + simp only [LogicalConnective.DeMorgan.or] + apply and (em φ) (em ψ) + exact cut b this + +/-- The specialize construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TDerivation`. -/ +noncomputable def specialize {φ : Semiformula V L 1} (b : T ⊢!ᵈᵉʳ (∀¹ φ) ∷ᵀ Γ) (t : Term V L) : + T ⊢!ᵈᵉʳ φ.subst ![t] ∷ᵀ Γ := + by + apply TDerivation.cut (φ := (∀¹ φ)) + · exact (TDerivation.wk b <| by intro x; simp; tauto) + · rw [Semiformula.neg_all] + apply TDerivation.exs t + apply TDerivation.em (φ.subst ![t]) + +end TDerivation + +namespace TProof + +variable {T U : InternalTheory V L} {φ ψ : Formula V L} + +/-- Condition D2 -/ +noncomputable def modusPonens (d : T ⊢! φ ⇒ₗ ψ) (b : T ⊢! φ) : T ⊢! ψ := + TDerivation.modusPonens d b + +/-- The by Axm construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TProof`. -/ +noncomputable def byAxm {φ : Formula V L} (h : φ ∈' T.theory) : T ⊢! φ := + TDerivation.byAxm φ h (by simp) + +/-- The of Subset construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TProof`. -/ +noncomputable def ofSubset (h : T ⊆ U) {φ : Formula V L} : T ⊢! φ → U ⊢! φ := + TDerivation.ofSubset h + +lemma of_subset (h : T ⊆ U) {φ : Formula V L} : T ⊢ φ → U ⊢ φ := by + rintro ⟨b⟩; + exact ⟨ofSubset h b⟩ + +noncomputable instance : Entailment.ModusPonens T := + ⟨modusPonens⟩ + +noncomputable instance : Entailment.NegationEquiv T where + negEquivProof + {φ} := + by + suffices T ⊢! (φ ⋎ ∼φ ⋎ ⊥) ⋏ (φ ⋏ ⊤ ⋎ ∼φ) by + simpa [Axioms.NegEquiv, FFL.LogicalConnective.iff, Semiformula.imp_def] + apply TDerivation.and + · apply TDerivation.or + apply TDerivation.rotate₁ + apply TDerivation.or + exact TDerivation.em φ + · apply TDerivation.or + apply TDerivation.and + · exact TDerivation.em φ + · exact TDerivation.verum + +noncomputable instance : Entailment.Minimal T + where + verumProof := TDerivation.toTProof <| TDerivation.verum + implyKProof + {φ ψ} := by + simp only [Axioms.ImplyK, Semiformula.imp_def] + apply TDerivation.or + apply TDerivation.rotate₁ + apply TDerivation.or + exact TDerivation.em φ + implySProof + {φ ψ + r} := + by + simp only [Axioms.ImplyS, Semiformula.imp_def, LogicalConnective.DeMorgan.or, + LogicalNeutral.DeMorgan.neg] + apply TDerivation.or + apply TDerivation.rotate₁ + apply TDerivation.or + apply TDerivation.rotate₁ + apply TDerivation.or + apply TDerivation.rotate₂ + apply TDerivation.and + · exact TDerivation.em φ + · apply TDerivation.rotate₃ + apply TDerivation.and + · exact TDerivation.em φ + · apply TDerivation.and + · exact TDerivation.em ψ + · exact TDerivation.em r + and₁Proof + {φ + ψ} := + by + simp only [Axioms.AndElim₁, Semiformula.imp_def, LogicalConnective.DeMorgan.and] + apply TDerivation.or + apply TDerivation.or + exact TDerivation.em φ + and₂Proof + {φ + ψ} := + by + simp only [Axioms.AndElim₂, Semiformula.imp_def, LogicalConnective.DeMorgan.and] + apply TDerivation.or + apply TDerivation.or + exact TDerivation.em ψ + and₃Proof + {φ ψ} := by + simp only [Axioms.AndInst, Semiformula.imp_def] + apply TDerivation.or + apply TDerivation.rotate₁ + apply TDerivation.or + apply TDerivation.rotate₁ + apply TDerivation.and + · exact TDerivation.em φ + · exact TDerivation.em ψ + or₁Proof + {φ ψ} := by + simp only [Axioms.OrInst₁, Semiformula.imp_def] + apply TDerivation.or + apply TDerivation.rotate₁ + apply TDerivation.or + exact TDerivation.em φ + or₂Proof + {φ ψ} := by + suffices T ⊢! ∼ψ ⋎ φ ⋎ ψ by simpa [Axioms.OrInst₂, Semiformula.imp_def] + apply TDerivation.or + apply TDerivation.rotate₁ + apply TDerivation.or + exact TDerivation.em ψ + or₃Proof + {φ ψ + r} := + by + suffices T ⊢! φ ⋏ ∼r ⋎ ψ ⋏ ∼r ⋎ ∼φ ⋏ ∼ψ ⋎ r by simpa [Axioms.OrElim, Semiformula.imp_def] + apply TDerivation.or + apply TDerivation.rotate₁ + apply TDerivation.or + apply TDerivation.rotate₁ + apply TDerivation.or + apply TDerivation.and + · apply TDerivation.rotate₃ + apply TDerivation.and + · exact TDerivation.em φ + · exact TDerivation.em r + · apply TDerivation.rotate₂ + apply TDerivation.and + · exact TDerivation.em ψ + · exact TDerivation.em r + +noncomputable instance : Entailment.Cl T where + dneProof + {φ} := by simpa [Axioms.DNE, Semiformula.imp_def] using! TDerivation.or (TDerivation.em φ) + +/-- The exs Intro construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TProof`. -/ +noncomputable def exsIntro (φ : Semiformula V L 1) (t : Term V L) (b : T ⊢! φ.subst ![t]) : + T ⊢! (∃¹ φ) := + TDerivation.exs t b + +lemma ex_introProof (φ : Semiformula V L 1) (t : Term V L) (b : T ⊢ φ.subst ![t]) : + T ⊢ (∃¹ φ) := + ⟨exsIntro _ t b.get⟩ + +/-- The specialize construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TProof`. -/ +noncomputable def specialize {φ : Semiformula V L 1} (b : T ⊢! ∀¹ φ) (t : Term V L) : + T ⊢! φ.subst ![t] := + TDerivation.specialize b t + +/-- The specialize₂ construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TProof`. -/ +noncomputable def specialize₂ {φ : Semiformula V L 2} (b : T ⊢! ∀¹ ∀¹ φ) (t u : Term V L) : + T ⊢! φ.subst ![t, u] := + by + have : T ⊢! ∀¹ Semiformula.subst (SemitermVec.q ![u]) φ := by simpa using specialize b u + simpa [Semiformula.substs_substs] using specialize this t + +/-- The specialize₃ construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TProof`. -/ +noncomputable def specialize₃ {φ : Semiformula V L 3} (b : T ⊢! ∀¹ ∀¹ ∀¹ φ) + (t₁ t₂ t₃ : Term V L) : T ⊢! φ.subst ![t₁, t₂, t₃] := + by + have : T ⊢! ∀¹ Semiformula.subst (SemitermVec.q ![t₂, t₃]) φ := by + simpa using specialize₂ b t₂ t₃; + simpa [Semiformula.substs_substs] using specialize this t₁; + +/-- The specialize₄ construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TProof`. -/ +noncomputable def specialize₄ {φ : Semiformula V L 4} (b : T ⊢! ∀¹ ∀¹ ∀¹ ∀¹ φ) + (t₁ t₂ t₃ t₄ : Term V L) : T ⊢! φ.subst ![t₁, t₂, t₃, t₄] := + by + have : T ⊢! ∀¹ Semiformula.subst (SemitermVec.q ![t₂, t₃, t₄]) φ := by + simpa using specialize₃ b t₂ t₃ t₄; + simpa [Semiformula.substs_substs] using specialize this t₁; + +lemma specializeProof {φ : Semiformula V L 1} (b : T ⊢ (∀¹ φ)) (t : Term V L) : + T ⊢ φ.subst ![t] := + ⟨TDerivation.specialize b.get t⟩ + +lemma specialize₂Proof {φ : Semiformula V L 2} (b : T ⊢ ∀¹ ∀¹ φ) (t u : Term V L) : + T ⊢ φ.subst ![t, u] := + ⟨specialize₂ b.get t u⟩ + +lemma specialize₃Proof {φ : Semiformula V L 3} (b : T ⊢ ∀¹ ∀¹ ∀¹ φ) (t₁ t₂ t₃ : Term V L) : + T ⊢ φ.subst ![t₁, t₂, t₃] := + ⟨specialize₃ b.get t₁ t₂ t₃⟩ + +lemma specialize₄Proof {φ : Semiformula V L 4} (b : T ⊢ ∀¹ ∀¹ ∀¹ ∀¹ φ) + (t₁ t₂ t₃ t₄ : Term V L) : T ⊢ φ.subst ![t₁, t₂, t₃, t₄] := + ⟨specialize₄ b.get _ _ _ _⟩ + +/-- The shift construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TProof`. -/ +noncomputable def shift {φ : Formula V L} (d : T ⊢! φ) : T ⊢! φ.shift := by + simpa using! TDerivation.shift d + +lemma shiftProof {φ : Formula V L} (d : T ⊢ φ) : T ⊢ φ.shift := + ⟨by simpa using! TDerivation.shift d.get⟩ + +/-- The all construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TProof`. -/ +noncomputable def all {φ : Semiformula V L 1} (dp : T ⊢! φ.free) : T ⊢! ∀¹ φ := + TDerivation.all (by simpa using! dp) + +/-- The all₂ construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TProof`. -/ +noncomputable def all₂ {φ : Semiformula V L 2} + (d : T ⊢! φ.shift.shift.subst ![Semiterm.fvar 0, Semiterm.fvar 1]) : T ⊢! ∀¹ ∀¹ φ := + by + apply all + suffices T ⊢! ∀¹ Semiformula.subst ![Semiterm.bvar 0, Semiterm.fvar 0] φ.shift by + simpa [Semiformula.free, SemitermVec.q, Semiformula.shift_substs, Semiformula.substs_substs] + apply all + simpa [Semiformula.free, SemitermVec.q, Semiformula.shift_substs, Semiformula.substs_substs] + +lemma all₂Proof {φ : Semiformula V L 2} + (d : T ⊢ φ.shift.shift.subst ![Semiterm.fvar 0, Semiterm.fvar 1]) : T ⊢ ∀¹ ∀¹ φ := + ⟨all₂ d.get⟩ + +lemma allProof {φ : Semiformula V L 1} (dp : T ⊢ φ.free) : T ⊢ ∀¹ φ := + ⟨all dp.get⟩ + +/-- The specialize shift construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TProof`. -/ +noncomputable def specializeShift {φ : Semiformula V L 1} (b : T ⊢! ∀¹ φ) (t : Term V L) : + T ⊢! φ.shift.subst ![t] := + by + have : T ⊢! ∀¹ φ.shift := by simpa using shift b + exact specialize this t + +/-- The specialize₂ shift construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TProof`. -/ +noncomputable def specialize₂Shift {φ : Semiformula V L 2} (b : T ⊢! ∀¹ ∀¹ φ) (t u : Term V L) : + T ⊢! φ.shift.shift.subst ![t, u] := + by + have : T ⊢! ∀¹ ∀¹ φ.shift.shift := by simpa using shift (shift b) + exact specialize₂ this t u + +lemma specialize₂ShiftProof {φ : Semiformula V L 2} (b : T ⊢ ∀¹ ∀¹ φ) (t u : Term V L) : + T ⊢ φ.shift.shift.subst ![t, u] := + ⟨specialize₂Shift b.get _ _⟩ + +/-- The generalize Aux construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TProof`. -/ +noncomputable def generalizeAux {C : Formula V L} {φ : Semiformula V L 1} + (dp : T ⊢! C.shift ⇒ₗ φ.free) : T ⊢! C ⇒ₗ ∀¹ φ := + by + rw [Semiformula.imp_def] at dp ⊢ + apply TDerivation.or + apply TDerivation.rotate₁ + apply TDerivation.all + exact TDerivation.wk (TDerivation.orInv dp) (by intro x; simp; tauto) + +lemma conj_shift (Γ : List (Formula V L)) : (⋀Γ).shift = ⋀(Γ.map .shift) := + by + induction Γ using List.induction_with_singleton + case hnil => simp + case hsingle => simp [List.conj₂] + case hcons φ ps hps ih => simp [hps, ih] + +/-- The generalize construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TProof`. -/ +noncomputable def generalize {Γ} {φ : Semiformula V L 1} (d : Γ.map .shift ⊢[T]! φ.free) : + Γ ⊢[T]! ∀¹ φ := by + apply Entailment.FiniteContext.ofDefProof + apply generalizeAux + simpa [conj_shift] using Entailment.FiniteContext.toDefProof d + +lemma generalizeProof {Γ} {φ : Semiformula V L 1} (d : Γ.map .shift ⊢[T] φ.free) : + Γ ⊢[T] ∀¹ φ := + ⟨generalize d.get⟩ + +/-- The specialize With Ctx Aux construction in +`FFL.FirstOrder.Arithmetic.Bootstrapping.TProof`. -/ +noncomputable def specializeWithCtxAux {C : Formula V L} {φ : Semiformula V L 1} + (d : T ⊢! C ⇒ₗ ∀¹ φ) (t : Term V L) : T ⊢! C ⇒ₗ φ.subst ![t] := + by + rw [Semiformula.imp_def] at d ⊢ + apply TDerivation.or + apply TDerivation.rotate₁ + apply TDerivation.specialize + exact TDerivation.wk (TDerivation.orInv d) (by intro x; simp; tauto) + +/-- The specialize With Ctx construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TProof`. -/ +noncomputable def specializeWithCtx {Γ} {φ : Semiformula V L 1} (d : Γ ⊢[T]! (∀¹ φ)) (t) : + Γ ⊢[T]! φ.subst ![t] := + specializeWithCtxAux d t + +lemma specialize_with_ctxProof {Γ} {φ : Semiformula V L 1} (d : Γ ⊢[T] (∀¹ φ)) (t) : + Γ ⊢[T] φ.subst ![t] := + ⟨specializeWithCtx d.get t⟩ + +open Entailment.FiniteContext + +/-- The all Imp All construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TProof`. -/ +noncomputable def allImpAll {Γ} {φ ψ : Semiformula V L 1} + (d : Γ.map .shift ⊢[T]! φ.free ⇒ₗ ψ.free) : Γ ⊢[T]! ∀¹ φ ⇒ₗ ∀¹ ψ := + by + classical + apply deductProof + apply generalize + suffices ((∀¹ φ.shift) :: Γ.map Semiformula.shift) ⊢[T]! ψ.free by simpa + have hφ : ((∀¹ φ.shift) :: Γ.map Semiformula.shift) ⊢[T]! φ.free := + by + apply specializeWithCtx + apply byAxm₀Proof + have h : ((∀¹ φ.shift) :: Γ.map Semiformula.shift) ⊢[T]! φ.free ⇒ₗ ψ.free := + Entailment.FiniteContext.weakeningProof (by simp) d + exact h⨀hφ + +theorem all_imp_allProof {Γ} {φ ψ : Semiformula V L 1} + (d : Γ.map .shift ⊢[T] φ.free ⇒ₗ ψ.free) : Γ ⊢[T] ∀¹ φ ⇒ₗ ∀¹ ψ := + ⟨allImpAll d.get⟩ + +/-- The exs Imp Exs construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TProof`. -/ +noncomputable def exsImpExs {Γ} {φ ψ : Semiformula V L 1} + (d : Γ.map .shift ⊢[T]! φ.free ⇒ₗ ψ.free) : Γ ⊢[T]! ∃¹ φ ⇒ₗ ∃¹ ψ := + by + classical + apply Entailment.CProofOfCNNProof + suffices Γ ⊢[T]! ∀¹ ∼ψ ⇒ₗ ∀¹ ∼φ by simpa + apply allImpAll + apply Entailment.CProofOfCNNProof + simpa [Semiformula.free] using d + +theorem exs_imp_exsProof {Γ} {φ ψ : Semiformula V L 1} + (d : Γ.map .shift ⊢[T] φ.free ⇒ₗ ψ.free) : Γ ⊢[T] ∃¹ φ ⇒ₗ ∃¹ ψ := + ⟨exsImpExs d.get⟩ + +/-- The exs construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TProof`. -/ +noncomputable def exs {φ : Semiformula V L 1} (t) (dp : T ⊢! φ.subst ![t]) : T ⊢! ∃¹ φ := + TDerivation.exs t (by simpa using! dp) + +lemma exsProof {φ : Semiformula V L 1} (t) (dp : T ⊢ φ.subst ![t]) : T ⊢ ∃¹ φ := + ⟨exs t dp.get⟩ + +variable (A : InternalTheory V ℒₒᵣ) + +open Bootstrapping.ObjectArithmetic + +open _root_.PointwiseComposition.FFL.FirstOrder.Entailment + +lemma substItrDisj_right {i z : V} (w : TermVec V ℒₒᵣ m) (φ : Semiformula V ℒₒᵣ (m + 1)) + (hi : i < z) : A ⊢ φ.subst (ℕᵗi :> w) ⇒ₗ φ.substItrDisj w z := + Provable.toTProvable <| + Derivable.toProvable <| by + apply Derivable.or + apply Derivable.exchange + apply Derivable.disj (L := ℒₒᵣ) (i := z - (i + 1)) _ + · intro i hi + have hi : i < z := by simpa using hi + rw [substItr_nth _ _ _ hi] + exact φ.isSemiformula.subst (w.isSemitermVec.adjoin (by simp)) + · simpa using pos_of_gt hi + · have : z - (i + 1) < z := by simpa using pos_of_gt hi + rw [substItr_nth _ _ _ this] + have : z - (z - (i + 1) + 1) = i := sub_succ_lt_selfs hi + simp only [this, Nat.succ_eq_add_one, Semiformula.val_substs, SemitermVec.val_succ, + Matrix.head_cons, Matrix.tail_cons] + apply Derivable.em (L := ℒₒᵣ) (p := subst ℒₒᵣ (numeral i ∷ SemitermVec.val w) φ.val) + · simpa using φ.isSemiformula_succ.subst (w.isSemitermVec.adjoin (numeral_semiterm 0 i)) + · simp + · simp + +lemma substItrDisj_right_intro {ψ} {i z : V} {w : TermVec V ℒₒᵣ m} + {φ : Semiformula V ℒₒᵣ (m + 1)} (hi : i < z) (h : A ⊢ ψ ⇒ₗ φ.subst (ℕᵗi :> w)) : + A ⊢ ψ ⇒ₗ φ.substItrDisj w z := + Entailment.C_trans h (substItrDisj_right A w φ hi) + +lemma substItrConj_right_intro {ψ} {w : TermVec V ℒₒᵣ m} {φ : Semiformula V ℒₒᵣ (m + 1)} {z : V} + (h : ∀ i < z, A ⊢ ψ ⇒ₗ φ.subst (ℕᵗi :> w)) : A ⊢ ψ ⇒ₗ φ.substItrConj w z := + Provable.toTProvable <| + Derivable.toProvable <| by + apply Derivable.or + apply Derivable.exchange + apply Derivable.conj + · simp + · intro i hi + have hi : i < z := by simpa using hi + rw [substItr_nth _ _ _ hi] + apply Derivable.exchange + suffices A ⊢!ᵈᵉʳ (∼ψ ∷ᵀ φ.subst (ℕᵗ(z - (i + 1)) :> w) ∷ᵀ ∅) by + simpa using this.toDerivable + have : A ⊢ ∼ψ ⋎ Semiformula.subst (typedNumeral (z - (i + 1)) :> w) φ := + h (z - (i + 1)) (by simp [pos_of_gt hi]) + exact TDerivation.orInv (proof_to_tDerivation this.get) + +open _root_.Classical Classical in +lemma substItrDisj_left_intro {ψ} {w : TermVec V ℒₒᵣ m} {φ : Semiformula V ℒₒᵣ (m + 1)} {z : V} + (h : ∀ i < z, A ⊢ φ.subst (ℕᵗi :> w) ⇒ₗ ψ) : A ⊢ φ.substItrDisj w z ⇒ₗ ψ := + by + apply Entailment.C_of_CNN + simp only [Semiformula.substItrDisj_neg] + apply substItrConj_right_intro + intro i hi + apply Entailment.C_of_CNN + simpa using h i hi + +end TProof + +end typed_derivation + +end Bootstrapping + +end Arithmetic + +end FirstOrder + +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Term/Basic.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Term/Basic.lean new file mode 100644 index 000000000..e9204f09c --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Term/Basic.lean @@ -0,0 +1,1236 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Language + +/-! Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section +namespace FFL +namespace FirstOrder +namespace Arithmetic +namespace Bootstrapping + +variable {V : Type*} [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +variable {L : Language} [L.Encodable] [L.LORDefinable] + +section term + +/-- The qq Bvar construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def qqBvar (z : V) : V := + ⟪0, z⟫ + 1 + +/-- The qq Fvar construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def qqFvar (x : V) : V := + ⟪1, x⟫ + 1 + +/-- The qq Func construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def qqFunc (k f v : V) : V := + ⟪2, k, f, v⟫ + 1 + +/-- The qq Func N construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +def qqFuncN (k f v : ℕ) : ℕ := + (Nat.pair 2 <| Nat.pair k <| Nat.pair f v) + 1 + +/-- The «term^# » construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +scoped prefix:max "^#" => qqBvar + +/-- The «term^& » construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +scoped prefix:max "^&" => qqFvar + +/-- The «term^func » construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +scoped prefix:max "^func " => qqFunc + +lemma qqFuncN_eq_qqFunc (k f v : ℕ) : qqFuncN k f v = qqFunc k f v := by + simp [qqFunc, qqFuncN, nat_pair_eq] + +@[simp] +lemma var_lt_qqBvar (z : V) : z < ^#z := + lt_succ_iff_le.mpr <| le_pair_right 0 z + +@[simp] +lemma var_lt_qqFvar (x : V) : x < ^&x := + lt_succ_iff_le.mpr <| le_pair_right 1 x + +@[simp] +lemma arity_lt_qqFunc (k f v : V) : k < ^func k f v := + le_iff_lt_succ.mp <| + le_trans (le_pair_right 2 k) <| pair_le_pair_right 2 <| le_pair_left k ⟪f, v⟫ + +@[simp] +lemma func_lt_qqFunc (k f v : V) : f < ^func k f v := + le_iff_lt_succ.mp <| + le_trans (le_pair_left f v) <| + le_trans (le_pair_right k ⟪f, v⟫) <| le_pair_right 2 ⟪k, ⟪f, v⟫⟫ + +@[simp] +lemma terms_lt_qqFunc (k f v : V) : v < ^func k f v := + le_iff_lt_succ.mp <| + le_trans (le_pair_right f v) <| + le_trans (le_pair_right k ⟪f, v⟫) <| le_pair_right 2 ⟪k, ⟪f, v⟫⟫ + +lemma nth_lt_qqFunc_of_lt {i k f v : V} (hi : i < len v) : v.[i] < ^func k f v := + lt_trans (nth_lt_self hi) (terms_lt_qqFunc _ _ _) + +@[simp] +lemma qqBvar_inj {z z' : V} : ^#z = ^#z' ↔ z = z' := by simp [qqBvar] + +@[simp] +lemma qqFvar_inj {x x' : V} : ^&x = ^&x' ↔ x = x' := by simp [qqFvar] + +@[simp] +lemma qqFunc_inj {k f v k' f' w : V} : ^func k f v = ^func k' f' w ↔ k = k' ∧ f = f' ∧ v = w := + by simp [qqFunc] + +/-- The qq Bvar Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.qqBvarDef : Σ₀.Semisentence 2 := + .mkSigma “t z. ∃ t' < t, !pairDef t' 0 z ∧ t = t' + 1” + + + +instance qqBvar_defined : Σ₀-Function₁ (qqBvar : V → V) via qqBvarDef := + .mk fun _ ↦ by simp_all [qqBvarDef, qqBvar] + +/-- The qq Fvar Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.qqFvarDef : Σ₀.Semisentence 2 := + .mkSigma “t x. ∃ t' < t, !pairDef t' 1 x ∧ t = t' + 1” + + + +instance qqFvar_defined : Σ₀-Function₁ (qqFvar : V → V) via qqFvarDef := + .mk fun v ↦ by simp_all [qqFvarDef, qqFvar] + +private lemma qqFunc_graph {x k f v : V} : + x = ^func k f v ↔ + ∃ fv < x, fv = ⟪f, v⟫ ∧ ∃ kfv < x, kfv = ⟪k, fv⟫ ∧ ∃ x' < x, x' = ⟪2, kfv⟫ ∧ x = x' + 1 := + ⟨by + rintro rfl + exact + ⟨⟪f, v⟫, lt_succ_iff_le.mpr <| le_trans (le_pair_right _ _) (le_pair_right _ _), rfl, + ⟪k, f, v⟫, lt_succ_iff_le.mpr <| by simp, rfl, ⟪2, k, f, v⟫, by simp [qqFunc], rfl, + rfl⟩, + by rintro ⟨_, _, rfl, _, _, rfl, _, _, rfl, rfl⟩; rfl⟩ + +/-- The qq Func Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.qqFuncDef : Σ₀.Semisentence 4 := .mkSigma + “x k f v. ∃ fv < x, !pairDef fv f v ∧ ∃ kfv < x, !pairDef kfv k fv ∧ ∃ x' < x, !pairDef x' 2 + kfv ∧ x = x' + 1” + + + +instance qqFunc_defined : Σ₀-Function₃ (qqFunc : V → V → V → V) via qqFuncDef := + .mk fun v ↦ by simp [qqFuncDef, qqFunc_graph] + +namespace FormalizedTerm + +variable (L) + +/-- The Phi construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.FormalizedTerm`. -/ +def Phi (C : Set V) (t : V) : Prop := + (∃ z, t = ^#z) ∨ + (∃ x, t = ^&x) ∨ + (∃ k f v : V, L.IsFunc k f ∧ k = len v ∧ (∀ i < k, v.[i] ∈ C) ∧ t = ^func k f v) + +private lemma phi_iff (C : V) (t : V) : + Phi L {x | x ∈ C} t ↔ + (∃ z < t, t = ^#z) ∨ + (∃ x < t, t = ^&x) ∨ + (∃ k < t, + ∃ f < t, ∃ v < t, L.IsFunc k f ∧ k = len v ∧ (∀ i < k, v.[i] ∈ C) ∧ t = ^func k f v) + where + mp := by + rintro (⟨z, rfl⟩ | ⟨x, rfl⟩ | ⟨k, f, v, hkf, hk, hv, rfl⟩) + · left; exact ⟨z, lt_succ_iff_le.mpr <| by simp, rfl⟩ + · right; left + exact ⟨x, lt_succ_iff_le.mpr <| by simp, rfl⟩ + · right; right + exact ⟨k, by simp, f, by simp, v, by simp, hkf, hk, hv, rfl⟩ + mpr := by + unfold Phi + rintro (⟨z, _, rfl⟩ | ⟨x, _, rfl⟩ | ⟨k, _, f, _, v, _, hkf, hk, hv, rfl⟩) + · left; exact ⟨z, rfl⟩ + · right; left; exact ⟨x, rfl⟩ + · right; right; exact ⟨k, f, v, hkf, hk, hv, rfl⟩ + +/-- The blueprint construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.FormalizedTerm`. -/ +def blueprint : Fixpoint.Blueprint 0 where + core := .mkDelta + (.mkSigma “t C. + (∃ z < t, !qqBvarDef t z) ∨ + (∃ x < t, !qqFvarDef t x) ∨ + (∃ k < t, ∃ f < t, ∃ v < t, !L.isFunc k f ∧ !lenDef k v ∧ (∀ i < k, ∃ u, !nthDef u v i ∧ u + ∈ C) ∧ !qqFuncDef t k f v)” + (by simp)) + (.mkPi “t C. + (∃ z < t, !qqBvarDef t z) ∨ + (∃ x < t, !qqFvarDef t x) ∨ + (∃ k < t, ∃ f < t, ∃ v < t, !L.isFunc k f ∧ (∀ l, !lenDef l v → k = l) ∧ (∀ i < k, ∀ u, + !nthDef u v i → u ∈ C) ∧ !qqFuncDef t k f v)” + (by simp)) + + + +/-- +The construction construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.FormalizedTerm`. -/ +def construction : Fixpoint.Construction V (blueprint L) + where + Φ := fun _ ↦ Phi L + defined := ⟨by intro v; simp [blueprint], by intro v; simp [blueprint, phi_iff]⟩ + monotone := by + rintro C C' hC _ x (h | h | ⟨k, f, v, hkf, hk, h, rfl⟩) + · exact Or.inl h + · exact Or.inr <| Or.inl h + · exact Or.inr <| Or.inr ⟨k, f, v, hkf, hk, fun i hi ↦ hC (h i hi), rfl⟩ + +instance : (construction L).StrongFinite V where + strong_finite := by + rintro C v x (h | h | ⟨k, f, v, hkf, hk, h, rfl⟩) + · exact Or.inl h + · exact Or.inr <| Or.inl h + · exact + Or.inr <| + Or.inr + ⟨k, f, v, hkf, hk, fun i hi ↦ ⟨h i hi, lt_of_le_of_lt (nth_le _ _) (by simp)⟩, rfl⟩ + +end FormalizedTerm + +open FormalizedTerm + +variable (L) + +/-- The Is UTerm construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +def IsUTerm : V → Prop := + (construction L).IsFixedPoint ![] + +/-- +Note: `noncomputable` attribute to prohibit compilation of a large term. This is necessary for +Zoo and integration with Verso. -/ +noncomputable def isUTerm : ∆₁.Semisentence 1 := + (blueprint L).fixpointDefΔ₁ + +variable {L} + +namespace IsUTerm + +instance defined : ∆₁-Predicate (IsUTerm L (V := V)) via (isUTerm L) := + (construction L).fixpoint_definedΔ₁ + +instance definable : ∆₁-Predicate (IsUTerm L (V := V)) := + defined.to_definable + +instance definable' (Γ) : Γ-[m + 1]-Predicate (IsUTerm L (V := V)) := + definable.of_deltaOne + +end IsUTerm + +variable (L) + +/-- The Is UTerm Vec construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +def IsUTermVec (n w : V) : Prop := + n = len w ∧ ∀ i < n, IsUTerm L w.[i] + +/-- The is UTerm Vec construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def isUTermVec : ∆₁.Semisentence 2 := .mkDelta + (.mkSigma “n w. !lenDef n w ∧ ∀ i < n, ∃ u, !nthDef u w i ∧ !(isUTerm L).sigma u”) + (.mkPi “n w. (∀ l, !lenDef l w → n = l) ∧ ∀ i < n, ∀ u, !nthDef u w i → !(isUTerm L).pi u”) + +variable {L} + +namespace IsUTermVec + +protected lemma lh {n w : V} (h : IsUTermVec L n w) : n = len w := + h.1 + +lemma nth {n w : V} (h : IsUTermVec L n w) {i} : i < n → IsUTerm L w.[i] := + h.2 i + +@[simp] +lemma empty : IsUTermVec (V := V) L 0 0 := + ⟨by simp, by simp⟩ + +@[simp] +lemma empty_iff : IsUTermVec L 0 v ↔ v = 0 := + by + constructor + · intro h; exact len_zero_iff_eq_nil.mp h.lh.symm + · rintro rfl; simp + +lemma two_iff {v : V} : + IsUTermVec L 2 v ↔ ∃ t₁ t₂, IsUTerm L t₁ ∧ IsUTerm L t₂ ∧ v = ?[t₁, t₂] := + by + constructor + · intro h + rcases eq_doubleton_of_len_eq_two.mp h.lh.symm with ⟨t₁, t₂, rfl⟩ + exact + ⟨t₁, t₂, by simpa using h.nth (show 0 < 2 by simp), by + simpa using h.nth (show 1 < 2 by simp), rfl⟩ + · rintro ⟨t₁, t₂, h₁, h₂, rfl⟩; + exact + ⟨by simp [one_add_one_eq_two], by + simp [lt_two_iff_le_one, le_one_iff_eq_zero_or_one, h₁, h₂]⟩ + +@[simp] +lemma adjoin {n w t : V} (h : IsUTermVec L n w) (ht : IsUTerm L t) : + IsUTermVec L (n + 1) (t ∷ w) := + ⟨by simp [h.lh], fun i hi ↦ + by + rcases zero_or_succ i with (rfl | ⟨i, rfl⟩) + · simpa + · simpa using h.nth (by simpa using hi)⟩ + +@[simp] +lemma adjoin₁_iff {t : V} : IsUTermVec L 1 (?[t] : V) ↔ IsUTerm L t := + by + constructor + · intro h; simpa using h.nth (i := 0) (by simp) + · intro h; simpa using empty.adjoin h + +@[simp] +lemma mkSeq₂_iff {t₁ t₂ : V} : IsUTermVec L 2 (?[t₁, t₂] : V) ↔ IsUTerm L t₁ ∧ IsUTerm L t₂ := + by + constructor + · intro h; + exact ⟨by simpa using h.nth (i := 0) (by simp), by simpa using h.nth (i := 1) (by simp)⟩ + · rintro ⟨h₁, h₂⟩ + simpa [one_add_one_eq_two] using (adjoin₁_iff.mpr h₂).adjoin h₁ + +section + +instance defined : ∆₁-Relation (IsUTermVec (V := V) L) via (isUTermVec L) := + ⟨by intro v; simp [isUTermVec, HierarchySymbol.Semiformula.val_sigma, + IsUTerm.defined.proper.iff'], + by intro v; simp [isUTermVec, HierarchySymbol.Semiformula.val_sigma, IsUTermVec]⟩ + +instance definable : ∆₁-Relation (IsUTermVec (V := V) L) := + defined.to_definable + +instance definable' (Γ) : Γ-[m + 1]-Relation (IsUTermVec (V := V) L) := + definable.of_deltaOne + +end + +end IsUTermVec + +namespace IsUTerm + +lemma case_iff {t : V} : + IsUTerm L t ↔ + (∃ z, t = ^#z) ∨ + (∃ x, t = ^&x) ∨ (∃ k f v : V, L.IsFunc k f ∧ IsUTermVec L k v ∧ t = ^func k f v) := + by simpa [construction, Phi, IsUTermVec, and_assoc] using! (construction L).case + +alias ⟨case, mk⟩ := case_iff + +@[simp] +lemma bvar {z : V} : IsUTerm L ^#z := + mk (Or.inl ⟨z, rfl⟩) + +@[simp] +lemma fvar (x : V) : IsUTerm L ^&x := + mk (Or.inr <| Or.inl ⟨x, rfl⟩) + +@[simp] lemma func_iff {k f v : V} : + IsUTerm L (^func k f v) ↔ L.IsFunc k f ∧ IsUTermVec L k v := + ⟨by intro h + rcases h.case with (⟨_, h⟩ | ⟨x, h⟩ | ⟨k', f', w, hkf, ⟨hk, hv⟩, h⟩) + · simp [qqFunc, qqBvar] at h + · simp [qqFunc, qqFvar] at h + · rcases (show k = k' ∧ f = f' ∧ v = w by simpa [qqFunc] using h) with ⟨rfl, rfl, rfl⟩ + exact ⟨hkf, hk, hv⟩, + by rintro ⟨hkf, hk, hv⟩; exact mk <| Or.inr <| Or.inr ⟨k, f, v, hkf, ⟨hk, hv⟩, rfl⟩⟩ + +lemma func {k f v : V} (hkf : L.IsFunc k f) (hv : IsUTermVec L k v) : IsUTerm L (^func k f v) := + func_iff.mpr ⟨hkf, hv⟩ + +lemma induction (Γ) {P : V → Prop} (hP : Γ-[1]-Predicate P) (hbvar : ∀ z, P (^#z)) + (hfvar : ∀ x, P (^&x)) + (hfunc : ∀ k f v, L.IsFunc k f → IsUTermVec L k v → (∀ i < k, P v.[i]) → P (^func k f v)) : + ∀ t, IsUTerm L t → P t := + (construction L).induction (v := ![]) hP + (by + rintro C hC x (⟨z, rfl⟩ | ⟨x, rfl⟩ | ⟨k, f, v, hkf, hk, h, rfl⟩) + · exact hbvar z + · exact hfvar x + · exact + hfunc k f v hkf ⟨hk, fun i hi ↦ hC _ (h i hi) |>.1⟩ (fun i hi ↦ hC _ (h i hi) |>.2)) + +end IsUTerm + +end term + +namespace Language +namespace TermRec + +/-- Data specifying the encoded construction in +`FFL.FirstOrder.Arithmetic.Bootstrapping.Language.TermRec`. -/ +structure Blueprint (arity : ℕ) where + /-- The bvar construction in + `FFL.FirstOrder.Arithmetic.Bootstrapping.Language.TermRec.Blueprint`. -/ + bvar : Σ₁.Semisentence (arity + 2) + /-- The fvar construction in + `FFL.FirstOrder.Arithmetic.Bootstrapping.Language.TermRec.Blueprint`. -/ + fvar : Σ₁.Semisentence (arity + 2) + /-- The func construction in + `FFL.FirstOrder.Arithmetic.Bootstrapping.Language.TermRec.Blueprint`. -/ + func : Σ₁.Semisentence (arity + 5) + +namespace Blueprint + +variable {arity : ℕ} (L) (β : Blueprint arity) + +/-- The blueprint construction in +`FFL.FirstOrder.Arithmetic.Bootstrapping.Language.TermRec.Blueprint`. -/ +noncomputable def blueprint : Fixpoint.Blueprint arity := ⟨.mkDelta + (.mkSigma “pr C. + ∃ t <⁺ pr, ∃ y <⁺ pr, !pairDef pr t y ∧ !(isUTerm L).sigma t ∧ + ( (∃ z < t, !qqBvarDef t z ∧ !β.bvar y z ⋯) ∨ + (∃ x < t, !qqFvarDef t x ∧ !β.fvar y x ⋯) ∨ + (∃ k < t, ∃ f < t, ∃ v < t, ∃ rv, !repeatVecDef rv C k ∧ ∃ w <⁺ rv, + (!lenDef k w ∧ ∀ i < k, ∃ vi, !nthDef vi v i ∧ ∃ v'i, !nthDef v'i w i ∧ :⟪vi, v'i⟫:∈ C) ∧ + !qqFuncDef t k f v ∧ !β.func y k f v w ⋯) )”) + (.mkPi “pr C. + ∃ t <⁺ pr, ∃ y <⁺ pr, !pairDef pr t y ∧ !(isUTerm L).pi t ∧ + ( (∃ z < t, !qqBvarDef t z ∧ !β.bvar.graphDelta.pi y z ⋯) ∨ + (∃ x < t, !qqFvarDef t x ∧ !β.fvar.graphDelta.pi y x ⋯) ∨ + (∃ k < t, ∃ f < t, ∃ v < t, ∀ rv, !repeatVecDef rv C k → ∃ w <⁺ rv, + ((∀ l, !lenDef l w → k = l) ∧ ∀ i < k, ∀ vi, !nthDef vi v i → ∀ v'i, !nthDef v'i w i → + :⟪vi, v'i⟫:∈ C) ∧ + !qqFuncDef t k f v ∧ !β.func.graphDelta.pi y k f v w ⋯) )”)⟩ + + + +/-- The graph construction in +`FFL.FirstOrder.Arithmetic.Bootstrapping.Language.TermRec.Blueprint`. -/ +noncomputable def graph : Σ₁.Semisentence (arity + 2) := .mkSigma + “t y. ∃ pr <⁺ (t + y + 1)², !pairDef pr t y ∧ !(β.blueprint L).fixpointDef pr ⋯” + +/-- The result construction in +`FFL.FirstOrder.Arithmetic.Bootstrapping.Language.TermRec.Blueprint`. -/ +noncomputable def result : Σ₁.Semisentence (arity + 2) := .mkSigma + “y t. (!(isUTerm L).pi t → !(β.graph L) t y ⋯) ∧ (¬!(isUTerm L).sigma t → y = 0)” + +/-- The result Vec construction in +`FFL.FirstOrder.Arithmetic.Bootstrapping.Language.TermRec.Blueprint`. -/ +noncomputable def resultVec : Σ₁.Semisentence (arity + 3) := .mkSigma + “w' k w. + (!(isUTermVec L).pi k w → !lenDef k w' ∧ ∀ i < k, ∃ z, !nthDef z w i ∧ ∃ z', !nthDef z' w' i + ∧ !(β.graph L).val z z' ⋯) ∧ + (¬!(isUTermVec L).sigma k w → w' = 0)” + + + +end Blueprint + +variable (L V) + +/-- Data and laws for Construction in +`FFL.FirstOrder.Arithmetic.Bootstrapping.Language.TermRec`. -/ +structure Construction {k : ℕ} (φ : Blueprint k) where + /-- The bvar construction in + `FFL.FirstOrder.Arithmetic.Bootstrapping.Language.TermRec.Construction`. -/ + bvar : (Fin k → V) → V → V + /-- The fvar construction in + `FFL.FirstOrder.Arithmetic.Bootstrapping.Language.TermRec.Construction`. -/ + fvar : (Fin k → V) → V → V + /-- The func construction in + `FFL.FirstOrder.Arithmetic.Bootstrapping.Language.TermRec.Construction`. -/ + func : (Fin k → V) → V → V → V → V → V + bvar_defined : Σ₁.DefinedFunction (fun v ↦ bvar (v ·.succ) (v 0)) φ.bvar + fvar_defined : Σ₁.DefinedFunction (fun v ↦ fvar (v ·.succ) (v 0)) φ.fvar + func_defined : Σ₁.DefinedFunction (fun v ↦ func (v ·.succ.succ.succ.succ) (v 0) (v 1) (v 2) (v + 3)) φ.func + + + +variable {V} + +namespace Construction + +variable {arity : ℕ} {β : Blueprint arity} (c : Construction V β) + +/-- The Phi construction in +`FFL.FirstOrder.Arithmetic.Bootstrapping.Language.TermRec.Construction`. -/ +def Phi (param : Fin arity → V) (C : Set V) (pr : V) : Prop := + IsUTerm L (π₁ pr) ∧ + ((∃ z, pr = ⟪^#z, c.bvar param z⟫) ∨ + (∃ x, pr = ⟪^&x, c.fvar param x⟫) ∨ + (∃ k f v w, + (k = len w ∧ ∀ i < k, ⟪v.[i], w.[i]⟫ ∈ C) ∧ pr = ⟪^func k f v, c.func param k f v w⟫)) + +lemma seq_bound {k s m : V} (Ss : Seq s) (hk : k = lh s) (hs : ∀ i z, ⟪i, z⟫ ∈ s → z < m) : + s < Exp.exp ((k + m + 1) ^ 2) := + lt_exp_iff.mpr <| fun p hp ↦ + by + have : p < ⟪k, m⟫ := by + simpa [hk] using + pair_lt_pair (Ss.lt_lh_of_mem (show ⟪π₁ p, π₂ p⟫ ∈ s by simpa using hp)) + (hs (π₁ p) (π₂ p) (by simpa using hp)) + exact lt_of_lt_of_le this (by simp) + +private lemma phi_iff (param : Fin arity → V) (C pr : V) : + c.Phi L param {x | x ∈ C} pr ↔ + ∃ t ≤ pr, + ∃ y ≤ pr, + pr = ⟪t, y⟫ ∧ + IsUTerm L t ∧ + ((∃ z < t, t = ^#z ∧ y = c.bvar param z) ∨ + (∃ x < t, t = ^&x ∧ y = c.fvar param x) ∨ + (∃ k < t, + ∃ f < t, + ∃ v < t, + ∃ w ≤ repeatVec C k, + (k = len w ∧ ∀ i < k, ⟪v.[i], w.[i]⟫ ∈ C) ∧ + t = ^func k f v ∧ y = c.func param k f v w)) := + by + constructor + · rintro ⟨ht, H⟩ + refine ⟨π₁ pr, by simp, π₂ pr, by simp, by simp, ht, ?_⟩ + rcases H with (⟨z, rfl⟩ | ⟨x, rfl⟩ | ⟨k, f, v, w, ⟨hk, hw⟩, hk, rfl⟩) + · left; exact ⟨z, by simp⟩ + · right; left; exact ⟨x, by simp⟩ + · right; right + refine ⟨k, by simp, f, by simp, v, by simp, w, ?_, ⟨hk, hw⟩, by simp⟩ + · rcases hk; + apply len_repeatVec_of_nth_le (fun i hi ↦ le_of_lt <| lt_of_mem_rng <| hw i hi) + · rintro ⟨t, _, y, _, rfl, ht, H⟩ + refine ⟨by simpa using ht, ?_⟩ + rcases H with + (⟨z, _, rfl, rfl⟩ | ⟨x, _, rfl, rfl⟩ | ⟨k, _, f, _, v, _, w, _, ⟨hk, hw⟩, rfl, rfl⟩) + · left; exact ⟨z, rfl⟩ + · right; left; exact ⟨x, rfl⟩ + · right; right + exact ⟨k, f, v, w, ⟨hk, fun i hi ↦ hw i hi⟩, rfl⟩ + +/-- TODO: move -/ +@[simp] +lemma cons_app_9 {n : ℕ} (a : α) (s : Fin n.succ.succ.succ.succ.succ.succ.succ.succ.succ → α) : + (a :> s) 9 = s 8 := + rfl + +@[simp] +lemma cons_app_10 {n : ℕ} (a : α) + (s : Fin n.succ.succ.succ.succ.succ.succ.succ.succ.succ.succ → α) : (a :> s) 10 = s 9 := + rfl + +@[simp] +lemma cons_app_11 {n : ℕ} (a : α) + (s : Fin n.succ.succ.succ.succ.succ.succ.succ.succ.succ.succ.succ → α) : + (a :> s) 11 = s 10 := + rfl + +/-- The construction construction in +`FFL.FirstOrder.Arithmetic.Bootstrapping.Language.TermRec.Construction`. -/ +def construction : Fixpoint.Construction V (β.blueprint L) + where + Φ := c.Phi L + defined := + .mk <| by + constructor + · intro v + simp [Blueprint.blueprint, c.bvar_defined.iff, c.bvar_defined.graph_delta.iff_delta_pi, + c.fvar_defined.iff, c.fvar_defined.graph_delta.iff_delta_pi, c.func_defined.iff, + c.func_defined.graph_delta.iff_delta_pi] + · intro v + symm + simpa [Blueprint.blueprint, c.bvar_defined.iff, c.fvar_defined.iff, + c.func_defined.iff] using c.phi_iff L _ _ _ + monotone := by + unfold Phi + rintro C C' hC v pr ⟨ht, H⟩ + refine ⟨ht, ?_⟩ + rcases H with (⟨z, rfl⟩ | ⟨x, rfl⟩ | ⟨k, f, v, w, ⟨hk, hw⟩, rfl⟩) + · left; exact ⟨z, rfl⟩ + · right; left; exact ⟨x, rfl⟩ + · right; right; exact ⟨k, f, v, w, ⟨hk, fun i hi ↦ hC (hw i hi)⟩, rfl⟩ + +instance : (c.construction L).Finite where + finite + {C param pr + h} := by + rcases h with ⟨hp, (h | h | ⟨k, f, v, w, ⟨hk, hw⟩, rfl⟩)⟩ + · exact ⟨0, hp, Or.inl h⟩ + · exact ⟨0, hp, Or.inr <| Or.inl h⟩ + · exact + ⟨⟪v, w⟫ + 1, hp, + Or.inr <| + Or.inr + ⟨k, f, v, w, + ⟨hk, fun i hi ↦ + ⟨hw i hi, lt_succ_iff_le.mpr <| pair_le_pair (by simp) (by simp)⟩⟩, + rfl⟩⟩ + +/-- The Graph construction in +`FFL.FirstOrder.Arithmetic.Bootstrapping.Language.TermRec.Construction`. -/ +def Graph (param : Fin arity → V) (x y : V) : Prop := + (c.construction L).IsFixedPoint param ⟪x, y⟫ + +variable {param : Fin arity → V} {n : V} + +variable {L c} + +lemma Graph.case_iff {t y : V} : + c.Graph L param t y ↔ + IsUTerm L t ∧ + ((∃ z, t = ^#z ∧ y = c.bvar param z) ∨ + (∃ x, t = ^&x ∧ y = c.fvar param x) ∨ + (∃ k f v w, + (k = len w ∧ ∀ i < k, c.Graph L param v.[i] w.[i]) ∧ + t = ^func k f v ∧ y = c.func param k f v w)) := + Iff.trans (c.construction L).case (by apply and_congr (by simp); simp; rfl) + +variable (c) + +lemma graph_defined : Σ₁.Defined (fun v ↦ c.Graph L (v ·.succ.succ) (v 0) (v 1)) (β.graph L) := + .mk fun v ↦ by simp [Blueprint.graph, (c.construction L).fixpoint_defined.iff, Graph] + +lemma eval_graphDef (v : Fin (arity + 2) → V) : + (β.graph L).val.Evalb v ↔ c.Graph L (v ·.succ.succ) (v 0) (v 1) := + (graph_defined c).iff + +instance graph_definable : Σ₁.Definable fun v ↦ c.Graph L (v ·.succ.succ) (v 0) (v 1) := + (graph_defined c).to_definable + +instance graph_definable₂ (param) : Σ-[0 + 1]-Relation (c.Graph L param) := by + simpa using + HierarchySymbol.Definable.retractiont (n := 2) (graph_definable c) + (#0 :> #1 :> fun i ↦ &(param i)) + +lemma graph_dom_isUTerm {t y} : c.Graph L param t y → IsUTerm L t := fun h ↦ + Graph.case_iff.mp h |>.1 + +lemma graph_bvar_iff {z} : + c.Graph L param ^#z y ↔ y = c.bvar param z := by + constructor + · intro H + rcases Graph.case_iff.mp H with ⟨_, (⟨_, h, rfl⟩ | ⟨_, h, _⟩ | ⟨_, _, _, _, _, h, _⟩)⟩ + · rcases (by simpa using h); rfl + · simp [qqBvar, qqFvar] at h + · simp [qqBvar, qqFunc] at h + · rintro rfl; exact Graph.case_iff.mpr ⟨by simp, Or.inl ⟨z, by simp⟩⟩ + +lemma graph_fvar_iff (x) : + c.Graph L param ^&x y ↔ y = c.fvar param x := by + constructor + · intro H + rcases Graph.case_iff.mp H with ⟨_, (⟨_, h, _⟩ | ⟨_, h, rfl⟩ | ⟨_, _, _, _, _, h, _⟩)⟩ + · simp [qqFvar, qqBvar] at h + · rcases (by simpa using h); rfl + · simp [qqFvar, qqFunc] at h + · rintro rfl; exact Graph.case_iff.mpr ⟨by simp, Or.inr <| Or.inl ⟨x, by simp⟩⟩ + +lemma graph_func {k f v w} (hkr : L.IsFunc k f) (hv : IsUTermVec L k v) (hkw : k = len w) + (hw : ∀ i < k, c.Graph L param v.[i] w.[i]) : + c.Graph L param (^func k f v) (c.func param k f v w) := by + exact + Graph.case_iff.mpr ⟨by simp [hkr, hv], Or.inr <| Or.inr ⟨k, f, v, w, ⟨hkw, hw⟩, by simp⟩⟩ + +lemma graph_func_inv {k f v y} : + c.Graph L param (^func k f v) y → + ∃ w, (k = len w ∧ ∀ i < k, c.Graph L param v.[i] w.[i]) ∧ y = c.func param k f v w := + by + intro H + rcases Graph.case_iff.mp H with ⟨_, (⟨_, h, _⟩ | ⟨_, h, rfl⟩ | ⟨k', f', v', w, hw, h, rfl⟩)⟩ + · simp [qqFunc, qqBvar] at h + · simp [qqFunc, qqFvar] at h + · rcases show k = k' ∧ f = f' ∧ v = v' by simpa [qqFunc, qqFunc] using h with ⟨rfl, rfl, rfl⟩ + exact ⟨w, hw, by rfl⟩ + +variable {c} (param n) + +lemma graph_exists {t : V} : IsUTerm L t → ∃ y, c.Graph L param t y := + by + apply IsUTerm.induction Σ (P := fun t ↦ ∃ y, c.Graph L param t y) (by definability) + case hbvar => intro z; exact ⟨c.bvar param z, by simp [c.graph_bvar_iff]⟩ + case hfvar => intro x; exact ⟨c.fvar param x, by simp [c.graph_fvar_iff]⟩ + case hfunc => + intro k f v hkf hv ih + have : ∃ w, len w = k ∧ ∀ i < k, c.Graph L param v.[i] w.[i] := + sigmaOne_skolem_vec (by definability) ih + rcases this with ⟨w, hwk, hvw⟩ + exact ⟨c.func param k f v w, c.graph_func hkf hv (Eq.symm hwk) hvw⟩ + +lemma graph_unique {t y₁ y₂ : V} : c.Graph L param t y₁ → c.Graph L param t y₂ → y₁ = y₂ := + by + revert y₁ y₂ + suffices IsUTerm L t → ∀ y₁ y₂, c.Graph L param t y₁ → c.Graph L param t y₂ → y₁ = y₂ by + intro u₁ u₂ h₁ h₂; exact this (c.graph_dom_isUTerm h₁) u₁ u₂ h₁ h₂ + intro ht + apply IsUTerm.induction Π ?_ ?_ ?_ ?_ t ht + · definability + · intro z; simp [c.graph_bvar_iff] + · intro x; simp [c.graph_fvar_iff] + · intro k f v _ _ ih y₁ y₂ h₁ h₂ + rcases c.graph_func_inv h₁ with ⟨w₁, ⟨hk₁, hv₁⟩, rfl⟩ + rcases c.graph_func_inv h₂ with ⟨w₂, ⟨hk₂, hv₂⟩, rfl⟩ + have : w₁ = w₂ := + nth_ext (by simp [← hk₁, ← hk₂]) + (fun i hi ↦ + ih i (by simpa [hk₁] using hi) _ _ (hv₁ i (by simpa [hk₁] using hi)) + (hv₂ i (by simpa [hk₁] using hi))) + rw [this] + +variable (L c) + +lemma graph_existsUnique {t : V} (ht : IsUTerm L t) : ∃! y, c.Graph L param t y := + by + rcases graph_exists param ht with ⟨y, hy⟩ + exact ExistsUnique.intro y hy (fun y' h' ↦ graph_unique param h' hy) + +lemma graph_existsUnique_total (t : V) : + ∃! y, (IsUTerm L t → c.Graph L param t y) ∧ (¬IsUTerm L t → y = 0) := by + by_cases ht : IsUTerm L t <;> simp [ht, c.graph_existsUnique L param] + +/-- The result construction in +`FFL.FirstOrder.Arithmetic.Bootstrapping.Language.TermRec.Construction`. -/ +noncomputable def result (t : V) : V := + Classical.chooseUnique (c.graph_existsUnique_total L param t) + +theorem result_prop {t : V} (ht : IsUTerm L t) : c.Graph L param t (c.result L param t) := + Classical.chooseUnique_spec (c.graph_existsUnique_total L param t) |>.1 ht + +theorem result_prop_not {t : V} (ht : ¬IsUTerm L t) : c.result L param t = 0 := + Classical.chooseUnique_spec (c.graph_existsUnique_total L param t) |>.2 ht + +variable {L c param} + +lemma result_eq_of_graph {t y} (ht : IsUTerm L t) (h : c.Graph L param t y) : + c.result L param t = y := + Eq.symm <| Classical.choose_uniq (c.graph_existsUnique_total L param t) (by simp [h, ht]) + +@[simp] +lemma result_bvar (z) : c.result L param (^#z) = c.bvar param z := + c.result_eq_of_graph (by simp) (by simp [c.graph_bvar_iff]) + +@[simp] +lemma result_fvar (x) : c.result L param (^&x) = c.fvar param x := + c.result_eq_of_graph (by simp) (by simp [c.graph_fvar_iff]) + +lemma result_func {k f v w} (hkf : L.IsFunc k f) (hv : IsUTermVec L k v) (hkw : k = len w) + (hw : ∀ i < k, c.result L param v.[i] = w.[i]) : + c.result L param (^func k f v) = c.func param k f v w := + c.result_eq_of_graph (by simp [hkf, hv]) + (c.graph_func hkf hv hkw + (fun i hi ↦ by simpa [hw i hi] using c.result_prop L param (hv.nth hi))) + +section vec + +lemma graph_existsUnique_vec {k w : V} (hw : IsUTermVec L k w) : + ∃! w' : V, k = len w' ∧ ∀ i < k, c.Graph L param w.[i] w'.[i] := by + have : ∀ i < k, ∃ y, c.Graph L param w.[i] y := by + intro i hi; exact ⟨c.result L param w.[i], c.result_prop L param (hw.nth hi)⟩ + rcases sigmaOne_skolem_vec (by definability) this + with ⟨w', hw'k, hw'⟩ + refine ExistsUnique.intro w' ⟨hw'k.symm, hw'⟩ ?_ + intro w'' ⟨hkw'', hw''⟩ + refine nth_ext (by simp [hw'k, ←hkw'']) (by + intro i hi; + exact c.graph_unique param (hw'' i (by simpa [hkw''] using hi)) (hw' i (by simpa [hkw''] + using hi))) + +variable (L c param) + +lemma graph_existsUnique_vec_total (k w : V) : + ∃! w', + (IsUTermVec L k w → k = len w' ∧ ∀ i < k, c.Graph L param w.[i] w'.[i]) ∧ + (¬IsUTermVec L k w → w' = 0) := + by by_cases h : IsUTermVec L k w <;> simp [h, c.graph_existsUnique_vec] + +/-- The result Vec construction in +`FFL.FirstOrder.Arithmetic.Bootstrapping.Language.TermRec.Construction`. -/ +noncomputable def resultVec (k w : V) : V := + Classical.chooseUnique (c.graph_existsUnique_vec_total L param k w) + +@[simp] +lemma resultVec_lh {k w : V} (hw : IsUTermVec L k w) : len (c.resultVec L param k w) = k := + Eq.symm <| + Classical.chooseUnique_spec (c.graph_existsUnique_vec_total L param k w) |>.1 hw |>.1 + +lemma graph_of_mem_resultVec {k w : V} (hw : IsUTermVec L k w) {i : V} (hi : i < k) : + c.Graph L param w.[i] (c.resultVec L param k w).[i] := + Classical.chooseUnique_spec (c.graph_existsUnique_vec_total L param k w) |>.1 hw |>.2 i hi + +lemma nth_resultVec {k w i : V} (hw : IsUTermVec L k w) (hi : i < k) : + (c.resultVec L param k w).[i] = c.result L param w.[i] := + c.result_eq_of_graph (hw.nth hi) (c.graph_of_mem_resultVec L param hw hi) |>.symm + +@[simp] +theorem resultVec_of_not {k w : V} (hw : ¬IsUTermVec L k w) : c.resultVec L param k w = 0 := + Classical.chooseUnique_spec (c.graph_existsUnique_vec_total L param k w) |>.2 hw + +@[simp] +lemma resultVec_nil : c.resultVec L param 0 0 = 0 := + len_zero_iff_eq_nil.mp (by simp) + +lemma resultVec_cons {k w t : V} (hw : IsUTermVec L k w) (ht : IsUTerm L t) : + c.resultVec L param (k + 1) (t ∷ w) = c.result L param t ∷ c.resultVec L param k w := + nth_ext (by simp [hw, hw.adjoin ht]) + (by + intro i hi + have hi : i < k + 1 := by simpa [hw.adjoin ht, resultVec_lh] using hi + rw [c.nth_resultVec L param (hw.adjoin ht) hi] + rcases zero_or_succ i with (rfl | ⟨i, rfl⟩) + · simp + · simp [c.nth_resultVec L param hw (by simpa using hi)]) + +end vec + +variable (c) + +@[simp] +lemma result_func' {k f v} (hkf : L.IsFunc k f) (hv : IsUTermVec L k v) : + c.result L param (^func k f v) = c.func param k f v (c.resultVec L param k v) := + c.result_func hkf hv (by simp [hv]) (fun i hi ↦ c.nth_resultVec L param hv hi |>.symm) + +section + +lemma result_defined : Σ₁.DefinedFunction (fun v ↦ c.result L (v ·.succ) (v 0)) (β.result L) := + .mk fun v ↦ by + simp [Blueprint.result, HierarchySymbol.Semiformula.val_sigma, IsUTerm.defined.proper.iff', + c.eval_graphDef, result, Classical.chooseUnique_eq_iff_right] + +lemma result_graphDef (v : Fin (arity + 2) → V) : + (β.result L).val.Evalb v ↔ v 0 = c.result L (v ·.succ.succ) (v 1) := + (result_defined c).iff + +private lemma resultVec_graph {w' k w} : + w' = c.resultVec L param k w ↔ + ((IsUTermVec L k w → k = len w' ∧ ∀ i < k, c.Graph L param w.[i] w'.[i]) ∧ + (¬IsUTermVec L k w → w' = 0)) := + Classical.chooseUnique_eq_iff_right (c.graph_existsUnique_vec_total L param k w) + +lemma resultVec_defined : + Σ₁.DefinedFunction (fun v ↦ c.resultVec L (v ·.succ.succ) (v 0) (v 1)) (β.resultVec L) := + .mk fun v ↦ by + symm + simpa [Blueprint.resultVec, HierarchySymbol.Semiformula.val_sigma, + IsUTermVec.defined.proper.iff', c.eval_graphDef] using c.resultVec_graph + +lemma eval_resultVec (v : Fin (arity + 3) → V) : + (β.resultVec L).val.Evalb v ↔ v 0 = c.resultVec L (v ·.succ.succ.succ) (v 1) (v 2) := + c.resultVec_defined.iff + +end + +end Construction + +end TermRec +end Language + +namespace IsUTerm +namespace BV + +/-- The blueprint construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.IsUTerm.BV`. -/ +def blueprint : Language.TermRec.Blueprint 0 where + bvar := .mkSigma “y z. y = z + 1” + fvar := .mkSigma “y x. y = 0” + func := .mkSigma “y k f v v'. !listMaxDef y v'” + +omit [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] in +/-- The construction Func Assignment construction in +`FFL.FirstOrder.Arithmetic.Bootstrapping.IsUTerm.BV`. -/ +def constructionFuncAssignment (v : Fin 5 → V) : Fin 2 → V := + ![v 0, v 4] + +omit [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] in +lemma constructionFuncTerms_val (v : Fin 5 → V) : + FirstOrder.Semiterm.val v Empty.elim ∘ + ((![FirstOrder.Semiterm.bvar 0, FirstOrder.Semiterm.bvar 4]) : + Fin 2 → ArithmeticSemiterm Empty 5) = + constructionFuncAssignment v := + by + apply Fin.funext_two + · rfl + · rfl + · intro i + exact Fin.elim0 i + +omit [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] in +lemma constructionFuncSubstitution_eval (v : Fin 5 → V) : + (FirstOrder.Semiformula.Evalb v) + ((↑Arithmetic.listMaxDef : ArithmeticSemisentence 2) ↜ + ((![FirstOrder.Semiterm.bvar 0, FirstOrder.Semiterm.bvar 4]) : + Fin 2 → ArithmeticSemiterm Empty 5)) ↔ + (FirstOrder.Semiformula.Evalb (constructionFuncAssignment v)) + (↑Arithmetic.listMaxDef : ArithmeticSemisentence 2) := + Iff.trans + (FirstOrder.Semiformula.eval_substs + ((![FirstOrder.Semiterm.bvar 0, FirstOrder.Semiterm.bvar 4]) : + Fin 2 → ArithmeticSemiterm Empty 5) + (↑Arithmetic.listMaxDef : ArithmeticSemisentence 2)) + (Iff.of_eq + (congrArg + (fun e ↦ + (FirstOrder.Semiformula.Evalb e) (↑Arithmetic.listMaxDef : ArithmeticSemisentence 2)) + (constructionFuncTerms_val v))) + +lemma constructionFuncResult (v : Fin 5 → V) : + (FirstOrder.Semiformula.Evalb (constructionFuncAssignment v)) + (↑Arithmetic.listMaxDef : ArithmeticSemisentence 2) ↔ + v 0 = + (fun u : Fin (0 + 1 + 1 + 1 + 1) → V ↦ Arithmetic.listMax (u 3)) + (fun x : Fin (0 + 1 + 1 + 1 + 1) ↦ v x.succ) := + by + have hDefined : + (FirstOrder.Semiformula.Evalb (constructionFuncAssignment v)) + (↑Arithmetic.listMaxDef : ArithmeticSemisentence 2) ↔ + constructionFuncAssignment v 0 = + (fun u : Fin 1 → V ↦ Arithmetic.listMax (u 0)) + (fun x : Fin 1 ↦ constructionFuncAssignment v x.succ) := + Arithmetic.listMax_defined.iff + have hResult : + constructionFuncAssignment v 0 = + (fun u : Fin 1 → V ↦ Arithmetic.listMax (u 0)) + (fun x : Fin 1 ↦ constructionFuncAssignment v x.succ) ↔ + v 0 = + (fun u : Fin (0 + 1 + 1 + 1 + 1) → V ↦ Arithmetic.listMax (u 3)) + (fun x : Fin (0 + 1 + 1 + 1 + 1) ↦ v x.succ) := + by + change (v 0 = Arithmetic.listMax (v 4)) ↔ (v 0 = Arithmetic.listMax (v 4)) + exact Iff.rfl + exact hDefined.trans hResult + +theorem constructionFuncDefined : + Σ₁.DefinedFunction (fun v : Fin (0 + 1 + 1 + 1 + 1) → V ↦ Arithmetic.listMax (v 3)) + blueprint.func := + .mk fun v ↦ by + unfold blueprint + dsimp only [Language.TermRec.Blueprint.func] + rw [HierarchySymbol.Semiformula.val_mkSigma] + exact (constructionFuncSubstitution_eval v).trans (constructionFuncResult v) + +variable (L) + +/-- The construction construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.IsUTerm.BV`. -/ +noncomputable def construction : Language.TermRec.Construction V blueprint + where + bvar (_ z) := z + 1 + fvar (_ _) := 0 + func (_ _ _ _ v') := listMax v' + bvar_defined := .mk fun v ↦ by simp [blueprint] + fvar_defined := .mk fun v ↦ by simp [blueprint] + func_defined := constructionFuncDefined + +end BV +end IsUTerm + +section bv + +open IsUTerm.BV + +variable (L) + +/-- The term BV construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def termBV (t : V) : V := + construction.result L ![] t + +/-- The term BVVec construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def termBVVec (k v : V) : V := + construction.resultVec L ![] k v + +/-- The term BVGraph construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def termBVGraph : Σ₁.Semisentence 2 := + blueprint.result L + +/-- The term BVVec Graph construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def termBVVecGraph : Σ₁.Semisentence 3 := + blueprint.resultVec L + +variable {L} + +@[simp] +lemma termBV_bvar (z : V) : termBV L ^#z = z + 1 := by simp [termBV, construction] + +@[simp] +lemma termBV_fvar (x : V) : termBV L ^&x = 0 := by simp [termBV, construction] + +@[simp] +lemma termBV_func {k f v : V} (hkf : L.IsFunc k f) (hv : IsUTermVec L k v) : + termBV L (^func k f v) = listMax (termBVVec L k v) := by + simp [termBV, construction, hkf, hv]; rfl + +@[simp] +lemma len_termBVVec {v : V} (hv : IsUTermVec L k v) : len (termBVVec L k v) = k := + construction.resultVec_lh L _ hv + +@[simp] +lemma nth_termBVVec {v : V} (hv : IsUTermVec L k v) {i} (hi : i < k) : + (termBVVec L k v).[i] = termBV L v.[i] := + construction.nth_resultVec L _ hv hi + +@[simp] +lemma termBVVec_nil : termBVVec L 0 0 = 0 := + construction.resultVec_nil L _ + +lemma termBVVec_cons {k t ts : V} (ht : IsUTerm L t) (hts : IsUTermVec L k ts) : + termBVVec L (k + 1) (t ∷ ts) = termBV L t ∷ termBVVec L k ts := + construction.resultVec_cons L ![] hts ht + +section + +instance termBV.defined : Σ₁-Function₁ (termBV (V := V) L) via (termBVGraph L) := + construction.result_defined + +instance termBV.definable : Σ₁-Function₁ (termBV (V := V) L) := + termBV.defined.to_definable + +instance termBV.definable' : Γ-[k + 1]-Function₁ (termBV (V := V) L) := + termBV.definable.of_sigmaOne + +instance termBVVec.defined : Σ₁-Function₂ (termBVVec (V := V) L) via (termBVVecGraph L) := + construction.resultVec_defined + +instance termBVVec.definable : Σ₁-Function₂ (termBVVec (V := V) L) := + termBVVec.defined.to_definable + +instance termBVVec.definable' : Γ-[i + 1]-Function₂ (termBVVec (V := V) L) := + termBVVec.definable.of_sigmaOne + +end + +end bv + +section isSemiterm + +variable (L) + +/-- Data and laws for Is Semiterm in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +class IsSemiterm (n t : V) : Prop where + isUTerm : IsUTerm L t + bv : termBV L t ≤ n + +/-- Data and laws for Is Semiterm Vec in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +class IsSemitermVec (k n v : V) : Prop where + isUTermVec : IsUTermVec L k v + bv : ∀ {i}, i < k → termBV L v.[i] ≤ n + +/-- The is Semiterm construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def isSemiterm : ∆₁.Semisentence 2 := .mkDelta + (.mkSigma “n p. !(isUTerm L).sigma p ∧ ∃ b, !(termBVGraph L) b p ∧ b ≤ n”) + (.mkPi “n p. !(isUTerm L).pi p ∧ ∀ b, !(termBVGraph L) b p → b ≤ n”) + +/-- The is Semiterm Vec construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def isSemitermVec : ∆₁.Semisentence 3 := .mkDelta + (.mkSigma “k n ps. !(isUTermVec L).sigma k ps ∧ ∀ i < k, ∃ p, !nthDef p ps i ∧ ∃ b, + !(termBVGraph L) b p ∧ b ≤ n”) + (.mkPi “k n ps. !(isUTermVec L).pi k ps ∧ ∀ i < k, ∀ p, !nthDef p ps i → ∀ b, !(termBVGraph L) + b p → b ≤ n”) + + + +/-- The Is Term construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +abbrev IsTerm (t : V) : Prop := + IsSemiterm L 0 t + +/-- The Is Term Vec construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +abbrev IsTermVec (k v : V) : Prop := + IsSemitermVec L k 0 v + +variable {L} + +lemma IsSemiterm.def {n} {t : V} : IsSemiterm L n t ↔ IsUTerm L t ∧ termBV L t ≤ n := + ⟨by rintro ⟨h, bv⟩; exact ⟨h, bv⟩, by rintro ⟨h, bv⟩; exact ⟨h, bv⟩⟩ + +lemma IsSemitermVec.def {n} {v : V} : + IsSemitermVec L k n v ↔ IsUTermVec L k v ∧ ∀ i < k, termBV (V := V) L v.[i] ≤ n := + ⟨by rintro ⟨h, bv⟩; exact ⟨h, fun _ ↦ bv⟩, by rintro ⟨h, bv⟩; exact ⟨h, bv _⟩⟩ + +lemma IsSemitermVec.isUTerm {k n v : V} (h : IsSemitermVec L k n v) : IsUTermVec L k v := + h.1 + +lemma IsSemitermVec.lh {k n v : V} (h : IsSemitermVec L k n v) : len v = k := + h.isUTerm.lh.symm + +lemma IsSemitermVec.nth {k n v : V} (h : IsSemitermVec L k n v) {i} (hi : i < k) : + IsSemiterm L n v.[i] := + ⟨h.isUTerm.nth hi, h.bv hi⟩ + +lemma IsUTerm.isSemiterm {t : V} (h : IsUTerm L t) : IsSemiterm L (termBV L t) t := + ⟨h, by simp⟩ + +lemma IsUTermVec.isSemitermVec {k v : V} (h : IsUTermVec L k v) : + IsSemitermVec L k (listMax (termBVVec L k v)) v := + ⟨h, fun {i} hi ↦ + le_trans (by rw [nth_termBVVec h hi]) (nth_le_listMax (i := i) (by simp [h, hi]))⟩ + +lemma IsSemitermVec.iff {k n v : V} : + IsSemitermVec L k n v ↔ (len v = k ∧ ∀ i < k, IsSemiterm L n v.[i]) := + by + constructor + · intro h; exact ⟨h.lh, fun i hi ↦ h.nth hi⟩ + · intro ⟨hk, h⟩; exact ⟨⟨hk.symm, fun i hi ↦ h i hi |>.isUTerm⟩, fun hi ↦ h _ hi |>.bv⟩ + +@[simp] +lemma IsSemiterm.bvar {n z : V} : IsSemiterm L n ^#z ↔ z < n := by + simp [IsSemiterm.def, succ_le_iff_lt] + +@[simp] +lemma IsSemiterm.fvar (n x : V) : IsSemiterm L n ^&x := by simp [IsSemiterm.def] + +@[simp] +lemma IsSemiterm.func {n k f v : V} : + IsSemiterm L n (^func k f v) ↔ L.IsFunc k f ∧ IsSemitermVec L k n v := + by + simp only [IsSemiterm.def, IsUTerm.func_iff] + constructor + · rintro ⟨⟨hf, hbv⟩, hv⟩ + exact + ⟨hf, hbv, by + intro i hi + have : listMax (termBVVec L k v) ≤ n := by simpa [termBV_func, hf, hbv] using hv + simpa [hbv, hi] using listMaxss_le_iff.mp this i (by simp [hbv, hi])⟩ + · rintro ⟨hf, h⟩ + exact + ⟨⟨hf, h.isUTerm⟩, by + simp only [hf, h.isUTerm, termBV_func] + apply listMaxss_le_iff.mpr + intro i hi + have hi : i < k := by simpa [hf, h.isUTerm] using hi + simpa [hf, h.isUTerm, hi] using (h.nth hi).bv⟩ + +lemma IsSemitermVec.empty (n : V) : IsSemitermVec L 0 n 0 := + ⟨by simp, by simp⟩ + +@[simp] +lemma IsSemitermVec.empty_iff {n : V} : IsSemitermVec L 0 n v ↔ v = 0 := + by + constructor + · intro h; exact len_zero_iff_eq_nil.mp h.lh + · rintro rfl; exact IsSemitermVec.empty n + +@[simp] +lemma IsSemitermVec.cons_iff {n w t : V} : + IsSemitermVec L (k + 1) n (t ∷ w) ↔ IsSemiterm L n t ∧ IsSemitermVec L k n w := + by + constructor + · intro h + exact + ⟨by simpa using h.nth (i := 0) (by simp), + IsSemitermVec.iff.mpr + ⟨by simpa using h.lh, fun i hi ↦ by + simpa using h.nth (show i + 1 < k + 1 by simp [hi])⟩⟩ + · rintro ⟨ht, hw⟩ + exact + ⟨hw.isUTerm.adjoin ht.isUTerm, by + intro i hi + rcases zero_or_succ i with (rfl | ⟨i, rfl⟩) + · simp [ht.bv] + · simpa using hw.nth (by simpa using hi) |>.bv⟩ + +lemma SemitermVec.adjoin {n m w t : V} (h : IsSemitermVec L n m w) (ht : IsSemiterm L m t) : + IsSemitermVec L (n + 1) m (t ∷ w) := + IsSemitermVec.cons_iff.mpr ⟨ht, h⟩ + +@[simp] +lemma IsSemitermVec.singleton {n t : V} : IsSemitermVec L 1 n ?[t] ↔ IsSemiterm L n t := by + rw [show (1 : V) = 0 + 1 by simp, IsSemitermVec.cons_iff]; simp + +@[simp] +lemma IsSemitermVec.doubleton {n t₁ t₂ : V} : + IsSemitermVec L 2 n ?[t₁, t₂] ↔ IsSemiterm L n t₁ ∧ IsSemiterm L n t₂ := by + rw [show (2 : V) = 1 + 1 by simp [one_add_one_eq_two], IsSemitermVec.cons_iff]; simp + +section + +instance IsSemiterm.defined : ∆₁-Relation (IsSemiterm (V := V) L) via (isSemiterm L) := + .mk <| by + refine ⟨?_, ?_⟩ + · intro v + simp [isSemiterm, HierarchySymbol.Semiformula.val_sigma] + · intro v + simp [isSemiterm, IsSemiterm.def, HierarchySymbol.Semiformula.val_sigma] + +instance IsSemiterm.definable : ∆₁-Relation (IsSemiterm (V := V) L) := + IsSemiterm.defined.to_definable + +instance IsSemiterm.definable' (Γ m) : Γ-[m + 1]-Relation (IsSemiterm (V := V) L) := + IsSemiterm.definable.of_deltaOne + +instance IsSemitermVec.defined : + ∆₁-Relation₃ (IsSemitermVec (V := V) L) via (isSemitermVec L) := + .mk <| by + refine ⟨?_, ?_⟩ + · intro v + simp [isSemitermVec, HierarchySymbol.Semiformula.val_sigma] + · intro v + simp [isSemitermVec, IsSemitermVec.def, HierarchySymbol.Semiformula.val_sigma] + +instance IsSemitermVec.definable : ∆₁-Relation₃ (IsSemitermVec (V := V) L) := + IsSemitermVec.defined.to_definable + +instance IsSemitermVec.definable' (Γ m) : Γ-[m + 1]-Relation₃ (IsSemitermVec (V := V) L) := + IsSemitermVec.definable.of_deltaOne + +end + +lemma IsSemiterm.case_iff {n t : V} : + IsSemiterm L n t ↔ + (∃ z < n, t = ^#z) ∨ + (∃ x, t = ^&x) ∨ + (∃ k f v : V, L.IsFunc k f ∧ IsSemitermVec L k n v ∧ t = ^func k f v) := + by + constructor + · intro h + rcases h.isUTerm.case with (⟨z, rfl⟩ | ⟨x, rfl⟩ | ⟨k, f, v, hf, _, rfl⟩) + · left; exact ⟨z, by simpa [succ_le_iff_lt] using h.bv, rfl⟩ + · right; left; exact ⟨x, rfl⟩ + · right; right; exact ⟨k, f, v, hf, by simp_all, rfl⟩ + · rintro (⟨z, hz, rfl⟩ | ⟨x, rfl⟩ | ⟨k, f, v, hf, hv, rfl⟩) + · simp [hz] + · simp + · simp [hf, hv] + +alias ⟨IsSemiterm.case, IsSemiterm.mk'⟩ := IsSemiterm.case_iff + +lemma IsSemiterm.induction (Γ) {P : V → Prop} (hP : Γ-[1]-Predicate P) + (hbvar : ∀ z < n, P (^#z)) (hfvar : ∀ x, P (^&x)) + (hfunc : + ∀ k f v, L.IsFunc k f → IsSemitermVec L k n v → (∀ i < k, P v.[i]) → P (^func k f v)) : + ∀ t, IsSemiterm L n t → P t := by + intro t ht + suffices IsSemiterm L n t → P t by exact this ht + apply IsUTerm.induction Γ ?_ ?_ ?_ ?_ t ht.isUTerm + · definability + · intro z; simp only [bvar]; exact hbvar z + · intro x _; exact hfvar x + · intro k f v hf _ ih h + have hv : IsSemitermVec L k n v := by simp_all + exact hfunc k f v hf hv (fun i hi ↦ ih i hi (hv.nth hi)) + +lemma IsSemitermVec.nil (k : V) : IsSemitermVec L 0 k 0 := + ⟨by simp, by simp⟩ + +lemma IsSemitermVec.adjoin {k n w t : V} (h : IsSemitermVec L n k w) (ht : IsSemiterm L k t) : + IsSemitermVec L (n + 1) k (t ∷ w) := + ⟨h.isUTerm.adjoin ht.isUTerm, by + intro i hi + rcases zero_or_succ i with (rfl | ⟨i, rfl⟩) + · simp [ht.bv] + · simp [h.bv (by simpa using hi)]⟩ + +lemma IsSemiterm.sigma1_induction {P : V → Prop} (hP : Σ₁-Predicate P) + (hbvar : ∀ z < n, P (^#z)) (hfvar : ∀ x, P (^&x)) + (hfunc : + ∀ k f v, L.IsFunc k f → IsSemitermVec L k n v → (∀ i < k, P v.[i]) → P (^func k f v)) : + ∀ t, IsSemiterm L n t → P t := + IsSemiterm.induction _ hP hbvar hfvar hfunc + +end isSemiterm + +end Bootstrapping +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Term/Coding.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Term/Coding.lean new file mode 100644 index 000000000..05386c95c --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Term/Coding.lean @@ -0,0 +1,346 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Term.Typed +public import Mathlib.Combinatorics.Colex + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +open Encodable FFL FirstOrder Arithmetic PeanoMinus Bootstrapping + +namespace FFL +namespace FirstOrder +namespace Semiterm + +variable {V : Type*} [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +variable {L : Language} [L.Encodable] [L.LORDefinable] + +variable (V) {n : ℕ} + +/-- The typed Quote construction in `FFL.FirstOrder.Semiterm`. -/ +noncomputable def typedQuote : SyntacticSemiterm L n → Bootstrapping.Semiterm V L n + | #x => Bootstrapping.Semiterm.bvar x + | &x => Bootstrapping.Semiterm.fvar x + | func f v => Bootstrapping.Semiterm.func f fun i ↦ (v i).typedQuote + +noncomputable instance : GödelQuote (SyntacticSemiterm L n) (Bootstrapping.Semiterm V L n) where + quote := typedQuote V + +variable {V} + +@[simp] +lemma typed_quote_bvar (x : Fin n) : + (⌜(#x : SyntacticSemiterm L n)⌝ : Bootstrapping.Semiterm V L n) = + Bootstrapping.Semiterm.bvar x := + rfl + +@[simp] +lemma typed_quote_fvar (x : ℕ) : + (⌜(&x : SyntacticSemiterm L n)⌝ : Bootstrapping.Semiterm V L n) = + Bootstrapping.Semiterm.fvar ↑x := + rfl + +@[simp] +lemma typed_quote_func (f : L.Func k) (v : Fin k → SyntacticSemiterm L n) : + (⌜func f v⌝ : Bootstrapping.Semiterm V L n) = Bootstrapping.Semiterm.func f fun i ↦ ⌜v i⌝ := + rfl + +@[simp] +lemma typed_quote_shift (t : SyntacticSemiterm L n) : + (⌜Rew.shift t⌝ : Bootstrapping.Semiterm V L n) = + Bootstrapping.Semiterm.shift (⌜t⌝ : Bootstrapping.Semiterm V L n) := + by induction t <;> simp [Rew.func, *]; rfl + +@[simp] +lemma typed_quote_bShift (t : SyntacticSemiterm L n) : + (⌜Rew.bShift t⌝ : Bootstrapping.Semiterm V L (n + 1)) = + Bootstrapping.Semiterm.bShift (⌜t⌝ : Bootstrapping.Semiterm V L n) := + by induction t <;> simp [Rew.func, *]; rfl + +@[simp] +lemma typed_quote_substs {n m} (t : SyntacticSemiterm L n) (w : Fin n → SyntacticSemiterm L m) : + (⌜Rew.subst w t⌝ : Bootstrapping.Semiterm V L m) = + Bootstrapping.Semiterm.subst (fun i ↦ ⌜w i⌝) ⌜t⌝ := + by induction t <;> simp [Rew.func, *]; rfl + +open Bootstrapping.ObjectArithmetic + +@[simp] +lemma typed_quote_add (t u : SyntacticSemiterm ℒₒᵣ n) : + (⌜(‘!!t + !!u’ : SyntacticSemiterm ℒₒᵣ n)⌝ : Bootstrapping.Semiterm V ℒₒᵣ n) = ⌜t⌝ + ⌜u⌝ := + rfl + +@[simp] +lemma typed_quote_mul (t u : SyntacticSemiterm ℒₒᵣ n) : + (⌜(‘!!t * !!u’ : SyntacticSemiterm ℒₒᵣ n)⌝ : Bootstrapping.Semiterm V ℒₒᵣ n) = ⌜t⌝ * ⌜u⌝ := + rfl + +lemma typed_quote_numeral_eq_numeral_one : + (⌜((1 : ℕ) : SyntacticSemiterm ℒₒᵣ n)⌝ : Bootstrapping.Semiterm V ℒₒᵣ n) = typedNumeral 1 := + by + simp [Bootstrapping.ObjectArithmetic.typedNumeral, Bootstrapping.ObjectArithmetic.one, + Bootstrapping.ObjectArithmetic.qqFunc_absolute, qqFuncN_eq_qqFunc] + rfl + +@[simp] +lemma typed_quote_numeral_eq_numeral (k : ℕ) : + (⌜(↑k : SyntacticSemiterm ℒₒᵣ n)⌝ : Bootstrapping.Semiterm V ℒₒᵣ n) = typedNumeral ↑k := by + match k with + | + 0 => + simp [Bootstrapping.ObjectArithmetic.typedNumeral, Bootstrapping.ObjectArithmetic.zero, + Bootstrapping.ObjectArithmetic.qqFunc_absolute, qqFuncN_eq_qqFunc] + rfl + | 1 => simp [typed_quote_numeral_eq_numeral_one] + | k + 1 + 1 => + calc + (⌜(↑(k + 1 + 1) : SyntacticSemiterm ℒₒᵣ n)⌝ : Bootstrapping.Semiterm V ℒₒᵣ n) + _ = ⌜(↑(k + 1) : SyntacticSemiterm ℒₒᵣ n)⌝ + ⌜((1 : ℕ) : SyntacticSemiterm ℒₒᵣ n)⌝ := rfl + _ = typedNumeral ↑(k + 1) + typedNumeral 1 := by + simp [typed_quote_numeral_eq_numeral (k + 1), typed_quote_numeral_eq_numeral_one] + _ = typedNumeral (↑k + 1 + 1) := by simp + +lemma typed_quote_inj {t u : SyntacticSemiterm L n} : + (⌜t⌝ : Bootstrapping.Semiterm V L n) = ⌜u⌝ → t = u := + match t, u with + | #x, #y => by simp + | &x, &y => by simp + | func f₁ v₁, func f₂ v₂ => + by + simp only [typed_quote_func, Bootstrapping.Semiterm.func, Semiterm.mk.injEq, qqFunc_inj, + Nat.cast_inj, func.injEq, and_imp] + rintro rfl + simp only [quote_func_inj, heq_eq_eq, true_and] + rintro rfl + suffices ((fun i ↦ ⌜v₁ i⌝) = fun i ↦ ⌜v₂ i⌝) → v₁ = v₂ by simpa [← SemitermVec.val_inj] + intro h + ext i + exact typed_quote_inj (congr_fun h i) + | #_, &_ | #_, func _ _ | &_, #_ | &_, func _ _ | func _ _, #_ | func _ _, &_ => by + simp [Bootstrapping.Semiterm.bvar, Bootstrapping.Semiterm.fvar, Bootstrapping.Semiterm.func, + qqBvar, qqFvar, qqFunc] + +@[simp] +lemma typed_quote_inj_iff {t u : SyntacticSemiterm L n} : + (⌜t⌝ : Bootstrapping.Semiterm V L n) = ⌜u⌝ ↔ t = u := + ⟨typed_quote_inj, by rintro rfl; rfl⟩ + +noncomputable instance : GödelQuote (SyntacticSemiterm L n) V where + quote t := (⌜t⌝ : Bootstrapping.Semiterm V L n).val + +theorem quote_def (t : SyntacticSemiterm L n) : + (⌜t⌝ : V) = (⌜t⌝ : Bootstrapping.Semiterm V L n).val := + rfl + +private lemma quote_eq_encode'_aux (v : Fin k → Semiterm L ℕ n) + (H : ∀ i, (⌜v i⌝ : Bootstrapping.Semiterm V L n).val = encode ↑(v i)) : + (SemitermVec.val fun i ↦ (⌜v i⌝ : Bootstrapping.Semiterm V L n)) = + ↑(Matrix.vecToNat fun i ↦ encode (v i)) := + by + induction k + case zero => simp + case succ k + ih => + suffices + (⌜v 0⌝ : Bootstrapping.Semiterm V L n).val = encode ↑(v 0) ∧ + SemitermVec.val (fun i ↦ ⌜v i.succ⌝) = ↑(Matrix.vecToNat fun i ↦ encode (v i.succ) : V) + by + simpa [Matrix.vecToNat, coe_pair_eq_pair_coe, adjoin_def, Matrix.vecHead, Matrix.vecTail, + Function.comp_def] + constructor + · exact H 0 + · exact ih (fun i ↦ v i.succ) (fun i ↦ by simpa using H i.succ) + +lemma quote_eq_encode (t : SyntacticSemiterm L n) : (⌜t⌝ : V) = ↑(encode t) := by + match t with + | #x => simp [quote_def, encode_eq_toNat, toNat, qqBvar, coe_pair_eq_pair_coe] + | &x => simp [quote_def, encode_eq_toNat, toNat, qqFvar, coe_pair_eq_pair_coe] + | + func f + v => + suffices + (⌜f⌝ : V) = ↑(encode f) ∧ + (SemitermVec.val (V := V) fun i ↦ ⌜v i⌝) = ↑(Matrix.vecToNat fun i ↦ encode (v i)) + by + simpa [quote_def, encode_eq_toNat, toNat, Bootstrapping.Semiterm.func, qqFunc, + coe_pair_eq_pair_coe] + constructor + · rfl + · exact quote_eq_encode'_aux _ fun i ↦ quote_eq_encode (v i) + +lemma quote_eq_encode' (v : Fin k → Semiterm L ℕ n) : + (SemitermVec.val fun i ↦ (⌜v i⌝ : Bootstrapping.Semiterm V L n)) = + ↑(Matrix.vecToNat fun i ↦ encode (v i)) := + quote_eq_encode'_aux _ fun i ↦ quote_eq_encode (v i) + +lemma quote_eq_encode_standard (t : SyntacticSemiterm L n) : (⌜t⌝ : ℕ) = encode t := by + simp [quote_eq_encode] + +lemma coe_quote_eq_quote (t : SyntacticSemiterm L n) : (↑(⌜t⌝ : ℕ) : V) = ⌜t⌝ := by + simp [quote_eq_encode] + +lemma coe_quote_eq_quote' (t : SyntacticSemiterm L n) : + (↑(⌜t⌝ : Bootstrapping.Semiterm ℕ L n).val : V) = + (⌜t⌝ : Bootstrapping.Semiterm V L n).val := + coe_quote_eq_quote t + +@[simp] +lemma quote_bvar (x : Fin n) : (⌜(#x : SyntacticSemiterm L n)⌝ : V) = ^#↑x := + rfl + +@[simp] +lemma quote_fvar (x : ℕ) : (⌜(&x : SyntacticSemiterm L n)⌝ : V) = ^&↑x := + rfl + +@[simp] +lemma quote_func (f : L.Func k) (v : Fin k → SyntacticSemiterm L n) : + (⌜func f v⌝ : V) = + ^func ↑k ⌜f⌝ (SemitermVec.val fun i ↦ (⌜v i⌝ : Bootstrapping.Semiterm V L n)) := + rfl + +variable (V) + +noncomputable instance : GödelQuote (ClosedSemiterm L n) (Bootstrapping.Semiterm V L n) where + quote t := ⌜(Rew.emb t : SyntacticSemiterm L n)⌝ + +variable {V} + +theorem empty_typed_quote_def (t : ClosedSemiterm L n) : + (⌜t⌝ : Bootstrapping.Semiterm V L n) = ⌜(Rew.emb t : SyntacticSemiterm L n)⌝ := + rfl + +@[simp] +lemma empty_typed_quote_bvar (x : Fin n) : + (⌜(#x : ClosedSemiterm L n)⌝ : Bootstrapping.Semiterm V L n) = + Bootstrapping.Semiterm.bvar x := + rfl + +@[simp] +lemma empty_typed_quote_func (f : L.Func k) (v : Fin k → ClosedSemiterm L n) : + (⌜func f v⌝ : Bootstrapping.Semiterm V L n) = Bootstrapping.Semiterm.func f fun i ↦ ⌜v i⌝ := + rfl + +@[simp] +lemma empty_typed_quote_add (t u : ClosedSemiterm ℒₒᵣ n) : + (⌜(‘!!t + !!u’ : ClosedSemiterm ℒₒᵣ n)⌝ : Bootstrapping.Semiterm V ℒₒᵣ n) = ⌜t⌝ + ⌜u⌝ := + rfl + +@[simp] +lemma empty_typed_quote_mul (t u : ClosedSemiterm ℒₒᵣ n) : + (⌜(‘!!t * !!u’ : ClosedSemiterm ℒₒᵣ n)⌝ : Bootstrapping.Semiterm V ℒₒᵣ n) = ⌜t⌝ * ⌜u⌝ := + rfl + +@[simp] +lemma empty_typed_quote_numeral_eq_numeral (k : ℕ) : + (⌜(↑k : ClosedSemiterm ℒₒᵣ n)⌝ : Bootstrapping.Semiterm V ℒₒᵣ n) = typedNumeral ↑k := by + simp [empty_typed_quote_def] + +noncomputable instance : GödelQuote (ClosedSemiterm L n) V where + quote t := ⌜(Rew.emb t : SyntacticSemiterm L n)⌝ + +lemma empty_quote_def (t : ClosedSemiterm L n) : + (⌜t⌝ : V) = ⌜(Rew.emb t : SyntacticSemiterm L n)⌝ := + rfl + +theorem empty_quote_eq (t : ClosedSemiterm L n) : + (⌜t⌝ : V) = (⌜t⌝ : Bootstrapping.Semiterm V L n).val := + rfl + +lemma empty_quote_eq_encode (t : ClosedSemiterm L n) : (⌜t⌝ : V) = ↑(encode t) := by + simp [empty_quote_def, quote_eq_encode] + +@[simp] +lemma coe_quote {ξ n} (t : SyntacticSemiterm L n) : + ↑(⌜t⌝ : ℕ) = (⌜t⌝ : ArithmeticSemiterm ξ m) := by simp [gödelNumber'_def, quote_eq_encode] + +@[simp] +lemma coe_empty_quote {ξ n} (t : ClosedSemiterm L n) : + ↑(⌜t⌝ : ℕ) = (⌜t⌝ : ArithmeticSemiterm ξ m) := by + simp [gödelNumber'_def, empty_quote_eq_encode] + +end Semiterm +end FirstOrder +end FFL + +namespace FFL +namespace FirstOrder +namespace Arithmetic +namespace Bootstrapping + +open Encodable FirstOrder + +lemma mem_iff_mem_bitIndices {x s : ℕ} : x ∈ s ↔ x ∈ s.bitIndices := + by + induction s using Nat.binaryRec generalizing x + case zero => simp + case bit b s ih => + cases b <;> simp only [Nat.bit_false_apply, Nat.bitIndices_two_mul, List.mem_map, + Nat.mem_bitIndices, Nat.bit_true_apply, Nat.bitIndices_two_mul_add_one, List.mem_cons] + · rcases x with _ | x <;> simp only [Nat.add_eq_zero_iff, _root_.one_ne_zero, and_false, + exists_const, iff_false, Nat.add_right_cancel_iff, exists_eq_right] + · exact zero_not_mem s + · refine (succ_mem_two_mul_iff (i := x) (a := s)).trans ?_ + simpa using (ih (x := x)) + · rcases x with _ | x <;> simp only [Nat.add_eq_zero_iff, _root_.one_ne_zero, and_false, + exists_const, or_false, iff_true, Nat.add_right_cancel_iff, exists_eq_right, false_or] + · exact zero_mem_double_add_one s + · refine (succ_mem_two_mul_succ_iff (i := x) (a := s)).trans ?_ + simpa using (ih (x := x)) + +lemma nat_mem_iff {x s : ℕ} : x ∈ s ↔ s / 2 ^ x % 2 = 1 := by + simp [mem_iff_mem_bitIndices, Nat.testBit_eq_decide_div_mod_eq] + +lemma nat_insert_eq (x s : ℕ) : (insert x s : ℕ) = if s / 2 ^ x % 2 = 1 then s else s + 2 ^ x := + by simp [insert_eq, bitInsert, exp_nat_eq_two_pow, nat_mem_iff] + +variable {L : Language} [L.Encodable] [L.LORDefinable] + +lemma IsSemiterm.sound {n t : ℕ} (ht : IsSemiterm L n t) : + ∃ T : FirstOrder.SyntacticSemiterm L n, ⌜T⌝ = t := + by + induction t using Nat.strongRec + case ind t + ih => + rcases ht.case with (⟨z, hz, rfl⟩ | ⟨x, rfl⟩ | ⟨k, f, v, hf, hv, rfl⟩) + · exact ⟨#⟨z, hz⟩, by simp⟩ + · exact ⟨&x, by simp [Semiterm.quote_fvar]⟩ + · have : ∀ i : Fin k, ∃ t : FirstOrder.SyntacticSemiterm L n, ⌜t⌝ = v.[i] := fun i ↦ + ih v.[i] (nth_lt_qqFunc_of_lt (by simp [hv.lh])) (hv.nth i.prop) + choose v' hv' using this + have : ∃ F, encode F = f := + isFunc_quote_quote (V := ℕ) (L := L) (x := f) (k := k) |>.mp (by simp [hf]) + rcases this with ⟨f, rfl⟩ + refine ⟨FirstOrder.Semiterm.func f v', ?_⟩ + suffices SemitermVec.val (fun i ↦ ⌜v' i⌝) = v by + simpa [Semiterm.quote_func, quote_func_def] + apply nth_ext' k (by simp) (by simp [hv.lh]) + intro i hik + let j : Fin k := ⟨i, hik⟩ + calc + (SemitermVec.val fun i ↦ ⌜v' i⌝).[i] = (SemitermVec.val fun i ↦ ⌜v' i⌝).[↑j] := rfl + _ = ⌜v' j⌝ := by + simpa [Semiterm.quote_def] using + SemitermVec.val_nth_eq (fun i ↦ (⌜v' i⌝ : Bootstrapping.Semiterm ℕ L n)) j + _ = v.[i] := hv' j + +end Bootstrapping +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Term/Functions.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Term/Functions.lean new file mode 100644 index 000000000..0d987f10c --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Term/Functions.lean @@ -0,0 +1,1108 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Term.Basic + +/-! Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section +namespace FFL +namespace FirstOrder +namespace Arithmetic +namespace Bootstrapping + +variable {V : Type*} [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +section + +variable {L : Language} [L.Encodable] [L.LORDefinable] + +namespace TermSubst + +/-- The blueprint construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TermSubst`. -/ +def blueprint : Language.TermRec.Blueprint 1 where + bvar := .mkSigma “y z w. !nthDef y w z” + fvar := .mkSigma “y x w. !qqFvarDef y x” + func := .mkSigma “y k f v v' w. !qqFuncDef y k f v'” + +omit [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] in +/-- The construction Bvar Assignment construction in +`FFL.FirstOrder.Arithmetic.Bootstrapping.TermSubst`. -/ +def constructionBvarAssignment (v : Fin 3 → V) : Fin 3 → V := + ![v 0, v 2, v 1] + +omit [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] in +lemma constructionBvarTerms_val (v : Fin 3 → V) : + FirstOrder.Semiterm.val v Empty.elim ∘ + ((![FirstOrder.Semiterm.bvar 0, FirstOrder.Semiterm.bvar 2, + FirstOrder.Semiterm.bvar 1]) : + Fin 3 → ArithmeticSemiterm Empty 3) = + constructionBvarAssignment v := + by + apply Fin.funext_two + · rfl + · rfl + · intro i + exact Fin.cases rfl (fun j ↦ Fin.elim0 j) i + +omit [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] in +lemma constructionBvarSubstitution_eval (v : Fin 3 → V) : + (FirstOrder.Semiformula.Evalb v) + ((↑Arithmetic.nthDef : ArithmeticSemisentence 3) ↜ + ((![FirstOrder.Semiterm.bvar 0, FirstOrder.Semiterm.bvar 2, + FirstOrder.Semiterm.bvar 1]) : + Fin 3 → ArithmeticSemiterm Empty 3)) ↔ + (FirstOrder.Semiformula.Evalb (constructionBvarAssignment v)) + (↑Arithmetic.nthDef : ArithmeticSemisentence 3) := + Iff.trans + (FirstOrder.Semiformula.eval_substs + ((![FirstOrder.Semiterm.bvar 0, FirstOrder.Semiterm.bvar 2, FirstOrder.Semiterm.bvar 1]) : + Fin 3 → ArithmeticSemiterm Empty 3) + (↑Arithmetic.nthDef : ArithmeticSemisentence 3)) + (Iff.of_eq + (congrArg + (fun e ↦ + (FirstOrder.Semiformula.Evalb e) (↑Arithmetic.nthDef : ArithmeticSemisentence 3)) + (constructionBvarTerms_val v))) + +lemma constructionBvarResult (v : Fin 3 → V) : + (FirstOrder.Semiformula.Evalb (constructionBvarAssignment v)) + (↑Arithmetic.nthDef : ArithmeticSemisentence 3) ↔ + v 0 = + (fun w : Fin (1 + 1) → V ↦ Arithmetic.nth ((fun x : Fin 1 ↦ w x.succ) 1) (w 0)) + (fun x : Fin (1 + 1) ↦ v x.succ) := + by + have hDefined : + (FirstOrder.Semiformula.Evalb (constructionBvarAssignment v)) + (↑Arithmetic.nthDef : ArithmeticSemisentence 3) ↔ + constructionBvarAssignment v 0 = + (fun w : Fin (1 + 1) → V ↦ Arithmetic.nth (w 0) (w 1)) + (fun x : Fin (1 + 1) ↦ (constructionBvarAssignment v) x.succ) := + Arithmetic.nth_defined.iff + have hResult : + constructionBvarAssignment v 0 = + (fun w : Fin (1 + 1) → V ↦ Arithmetic.nth (w 0) (w 1)) + (fun x : Fin (1 + 1) ↦ (constructionBvarAssignment v) x.succ) ↔ + v 0 = + (fun w : Fin (1 + 1) → V ↦ Arithmetic.nth ((fun x : Fin 1 ↦ w x.succ) 1) (w 0)) + (fun x : Fin (1 + 1) ↦ v x.succ) := + by + change (v 0 = Arithmetic.nth (v 2) (v 1)) ↔ (v 0 = Arithmetic.nth (v 2) (v 1)) + exact Iff.rfl + exact hDefined.trans hResult + +lemma constructionBvarEvaluation (v : Fin (1 + 1 + 1) → V) : + (FirstOrder.Semiformula.Evalb v) blueprint.bvar.val ↔ + v 0 = + (fun w : Fin (1 + 1) → V ↦ Arithmetic.nth ((fun x : Fin 1 ↦ w x.succ) 1) (w 0)) + (fun x : Fin (1 + 1) ↦ v x.succ) := + by + unfold blueprint + dsimp only [Language.TermRec.Blueprint.bvar] + rw [HierarchySymbol.Semiformula.val_mkSigma] + exact (constructionBvarSubstitution_eval v).trans (constructionBvarResult v) + +theorem constructionBvarDefined : + Σ₁.DefinedFunction + (fun w : Fin (1 + 1) → V ↦ Arithmetic.nth ((fun x : Fin 1 ↦ w x.succ) 1) (w 0)) + blueprint.bvar := + .mk constructionBvarEvaluation + +/-- The construction construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TermSubst`. -/ +noncomputable def construction : Language.TermRec.Construction V blueprint + where + bvar (param z) := (param 1).[z] + fvar (_ x) := ^&x + func (_ k f _ v') := ^func k f v' + bvar_defined := constructionBvarDefined + fvar_defined := .mk fun v ↦ by simp [blueprint] + func_defined := .mk fun v ↦ by simp [blueprint] + +end TermSubst + +section termSubst + +open TermSubst + +variable (L) + +/-- The term Subst construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def termSubst (w t : V) : V := + construction.result L ![w] t + +/-- The term Subst Vec construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def termSubstVec (k w v : V) : V := + construction.resultVec L ![w] k v + +/-- The term Subst Graph construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def termSubstGraph : Σ₁.Semisentence 3 := + (blueprint.result L).rew <| Rew.subst ![#0, #2, #1] + +/-- The term Subst Vec Graph construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def termSubstVecGraph : Σ₁.Semisentence 4 := + (blueprint.resultVec L).rew <| Rew.subst ![#0, #1, #3, #2] + +variable {L} + +variable {n m w : V} + +@[simp] +lemma termSubst_bvar (z) : termSubst L w ^#z = w.[z] := by simp [termSubst, construction] + +@[simp] +lemma termSubst_fvar (x) : termSubst L w ^&x = ^&x := by simp [termSubst, construction] + +@[simp] +lemma termSubst_func {k f v} (hkf : L.IsFunc k f) (hv : IsUTermVec L k v) : + termSubst L w (^func k f v) = ^func k f (termSubstVec L k w v) := by + simp [termSubst, construction, hkf, hv]; rfl + +section + +instance termSubst.defined : Σ₁-Function₂ termSubst (V := V) L via termSubstGraph L := + .mk fun v ↦ by + simpa [termSubstGraph, termSubst, Matrix.constant_eq_singleton, Matrix.comp_vecCons'] using + construction.result_defined.defined ![v 0, v 2, v 1] + +instance termSubst.definable : Σ₁-Function₂ termSubst (V := V) L := + termSubst.defined.to_definable + +instance termSubst.definable' : Γ-[k + 1]-Function₂ termSubst (V := V) L := + termSubst.definable.of_sigmaOne + +instance termSubstVec.defined : Σ₁-Function₃ termSubstVec (V := V) L via termSubstVecGraph L := + .mk fun v ↦ by + simpa [termSubstVecGraph, termSubstVec, Matrix.constant_eq_singleton, + Matrix.comp_vecCons'] using construction.resultVec_defined.defined ![v 0, v 1, v 3, v 2] + +instance termSubstVec.definable : Σ₁-Function₃ termSubstVec (V := V) L := + termSubstVec.defined.to_definable + +instance termSubstVec.definable' : Γ-[i + 1]-Function₃ termSubstVec (V := V) L := + termSubstVec.definable.of_sigmaOne + +end + +@[simp] +lemma len_termSubstVec {k ts : V} (hts : IsUTermVec L k ts) : len (termSubstVec L k w ts) = k := + construction.resultVec_lh L _ hts + +@[simp] +lemma nth_termSubstVec {k ts i : V} (hts : IsUTermVec L k ts) (hi : i < k) : + (termSubstVec L k w ts).[i] = termSubst L w ts.[i] := + construction.nth_resultVec L _ hts hi + +@[simp] +lemma termSubstVec_nil (w : V) : termSubstVec L 0 w 0 = 0 := + construction.resultVec_nil L _ + +lemma termSubstVec_cons {k t ts : V} (ht : IsUTerm L t) (hts : IsUTermVec L k ts) : + termSubstVec L (k + 1) w (t ∷ ts) = termSubst L w t ∷ termSubstVec L k w ts := + construction.resultVec_cons L ![w] hts ht + +@[simp] +lemma termSubstVec_cons₁ {t : V} (ht : IsUTerm L t) : + termSubstVec L 1 w ?[t] = ?[termSubst L w t] := by + rw [show (1 : V) = 0 + 1 by simp, termSubstVec_cons] <;> simp [*] + +@[simp] +lemma termSubstVec_cons₂ {t₁ t₂ : V} (ht₁ : IsUTerm L t₁) (ht₂ : IsUTerm L t₂) : + termSubstVec L 2 w ?[t₁, t₂] = ?[termSubst L w t₁, termSubst L w t₂] := by + rw [show (2 : V) = 0 + 1 + 1 by simp [one_add_one_eq_two], termSubstVec_cons] <;> simp [*] + +lemma IsSemitermVec.termSubst {t} (hw : IsSemitermVec L n m w) (ht : IsSemiterm L n t) : + IsSemiterm L m (termSubst L w t) := + by + apply IsSemiterm.induction Σ ?_ ?_ ?_ ?_ t ht + · definability + · intro z hz; simpa using hw.nth hz + · intro x; simp + · intro k f v hkf hv ih + simp only [hkf, hv.isUTerm, termSubst_func, IsSemiterm.func, true_and] + exact + IsSemitermVec.iff.mpr + ⟨by simp [hv.isUTerm], fun i hi ↦ by rw [nth_termSubstVec hv.isUTerm hi]; exact ih i hi⟩ + +lemma IsUTermVec.termSubst {t} (hw : IsUTermVec L n w) (ht : IsSemiterm L n t) : + IsUTerm L (termSubst L w t) := + IsSemitermVec.termSubst hw.isSemitermVec ht |>.isUTerm + +lemma IsSemitermVec.termSubstVec {k n m v} (hw : IsSemitermVec L n m w) + (hv : IsSemitermVec L k n v) : IsSemitermVec L k m (termSubstVec L k w v) := + IsSemitermVec.iff.mpr ⟨by simp [hv.isUTerm], fun i hi ↦ by + rw [nth_termSubstVec hv.isUTerm hi] + exact hw.termSubst (hv.nth hi)⟩ + +@[simp] +lemma substs_nil {t : V} (ht : IsSemiterm L 0 t) : termSubst L 0 t = t := + by + apply IsSemiterm.induction Σ ?_ ?_ ?_ ?_ t ht + · definability + · intro z; simp + · intro x; simp + · intro k f v hf hv ih + simp only [hf, hv.isUTerm, termSubst_func, qqFunc_inj, true_and] + apply nth_ext' k (by simp [hv.isUTerm]) (by simp [hv.lh]) + intro i hi + simp [nth_termSubstVec hv.isUTerm hi, ih i hi] + +lemma termSubst_termSubst {l n w v t : V} (hv : IsSemitermVec L l n v) (ht : IsSemiterm L l t) : + termSubst L w (termSubst L v t) = termSubst L (termSubstVec L l w v) t := + by + apply IsSemiterm.induction Σ ?_ ?_ ?_ ?_ t ht + · definability + · intro z hz + rw [termSubst_bvar z, termSubst_bvar z, nth_termSubstVec hv.isUTerm hz] + · intro x; simp + · intro k f ts hf hts ih + rw [termSubst_func hf hts.isUTerm, termSubst_func hf (hv.termSubstVec hts).isUTerm, + termSubst_func hf hts.isUTerm] + simp only [qqFunc_inj, true_and] + apply + nth_ext' k (by rw [len_termSubstVec (hv.termSubstVec hts).isUTerm]) + (by rw [len_termSubstVec hts.isUTerm]) + intro i hi + rw [nth_termSubstVec (hv.termSubstVec hts).isUTerm hi, nth_termSubstVec hts.isUTerm hi, + nth_termSubstVec hts.isUTerm hi, ih i hi] + +lemma termSubst_eq_self {n w t : V} (ht : IsSemiterm L n t) (H : ∀ i < n, w.[i] = ^#i) : + termSubst L w t = t := + by + apply IsSemiterm.induction Σ ?_ ?_ ?_ ?_ t ht + · definability + · intro z hz; simp [hz, H] + · intro x; simp + · intro k f v hf hv ih + rw [termSubst_func hf hv.isUTerm] + simp only [qqFunc_inj, true_and] + apply nth_ext' k (by rw [len_termSubstVec hv.isUTerm]) (by simp [hv.lh]) + intro i hi + rw [nth_termSubstVec hv.isUTerm hi, ih i hi] + +end termSubst + +namespace TermShift + +/-- The blueprint construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TermShift`. -/ +def blueprint : Language.TermRec.Blueprint 0 where + bvar := .mkSigma “y z. !qqBvarDef y z” + fvar := .mkSigma “y x. !qqFvarDef y (x + 1)” + func := .mkSigma “y k f v v'. !qqFuncDef y k f v'” + +/-- The construction construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TermShift`. -/ +noncomputable def construction : Language.TermRec.Construction V blueprint + where + bvar (_ z) := ^#z + fvar (_ x) := ^&(x + 1) + func (_ k f _ v') := ^func k f v' + bvar_defined := .mk fun v ↦ by simp [blueprint] + fvar_defined := .mk fun v ↦ by simp [blueprint] + func_defined := .mk fun v ↦ by simp [blueprint] + +end TermShift + +section termShift + +open TermShift + +variable (L) + +/-- The term Shift construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def termShift (t : V) : V := + construction.result L ![] t + +/-- The term Shift Vec construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def termShiftVec (k v : V) : V := + construction.resultVec L ![] k v + +/-- The term Shift Graph construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def termShiftGraph : Σ₁.Semisentence 2 := + blueprint.result L + +/-- The term Shift Vec Graph construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def termShiftVecGraph : Σ₁.Semisentence 3 := + blueprint.resultVec L + +variable {L} + +variable {n : V} + +@[simp] +lemma termShift_bvar (z : V) : termShift L ^#z = ^#z := by simp [termShift, construction] + +@[simp] +lemma termShift_fvar (x : V) : termShift L ^&x = ^&(x + 1) := by simp [termShift, construction] + +@[simp] +lemma termShift_func {k f v : V} (hkf : L.IsFunc k f) (hv : IsUTermVec L k v) : + termShift L (^func k f v) = ^func k f (termShiftVec L k v) := by + simp [termShift, construction, hkf, hv]; rfl + +section + +instance termShift.defined : Σ₁-Function₁ termShift (V := V) L via termShiftGraph L := + .mk fun v ↦ by simpa [termShiftGraph, termShift] using! construction.result_defined.defined v + +instance termShift.definable : Σ₁-Function₁ termShift (V := V) L := + termShift.defined.to_definable + +instance termShift.definable' : Γ-[i + 1]-Function₁ termShift (V := V) L := + termShift.definable.of_sigmaOne + +instance termShiftVec.defined : Σ₁-Function₂ termShiftVec (V := V) L via termShiftVecGraph L := + .mk fun v ↦ by + simpa [termShiftVecGraph, termShiftVec] using! construction.resultVec_defined.defined v + +instance termShiftVec.definable : Σ₁-Function₂ termShiftVec (V := V) L := + termShiftVec.defined.to_definable + +instance termShiftVec.definable' : Γ-[i + 1]-Function₂ termShiftVec (V := V) L := + termShiftVec.definable.of_sigmaOne + +end + +@[simp] +lemma len_termShiftVec {k ts : V} (hts : IsUTermVec L k ts) : len (termShiftVec L k ts) = k := + construction.resultVec_lh L _ hts + +@[simp] +lemma nth_termShiftVec {k ts i : V} (hts : IsUTermVec L k ts) (hi : i < k) : + (termShiftVec L k ts).[i] = termShift L ts.[i] := + construction.nth_resultVec L _ hts hi + +@[simp] +lemma termShiftVec_nil : termShiftVec (V := V) L 0 0 = 0 := + construction.resultVec_nil L ![] + +lemma termShiftVec_cons {k t ts : V} (ht : IsUTerm L t) (hts : IsUTermVec L k ts) : + termShiftVec L (k + 1) (t ∷ ts) = termShift L t ∷ termShiftVec L k ts := + construction.resultVec_cons L ![] hts ht + +@[simp] +lemma termShiftVec_cons₁ {t₁ : V} (ht₁ : IsUTerm L t₁) : + termShiftVec L 1 (?[t₁] : V) = ?[termShift L t₁] := by + rw [show (1 : V) = 0 + 1 by simp, termShiftVec_cons] <;> simp [*] + +@[simp] +lemma termShiftVec_cons₂ {t₁ t₂ : V} (ht₁ : IsUTerm L t₁) (ht₂ : IsUTerm L t₂) : + termShiftVec L 2 (?[t₁, t₂] : V) = ?[termShift L t₁, termShift L t₂] := by + rw [show (2 : V) = 0 + 1 + 1 by simp [one_add_one_eq_two], termShiftVec_cons] <;> + simp [ht₁, ht₂] + +@[simp] +lemma IsUTerm.termShift {t} (ht : IsUTerm L t) : IsUTerm L (termShift L t : V) := + by + apply IsUTerm.induction Σ ?_ ?_ ?_ ?_ t ht + · definability + · intro z; simp + · intro x; simp + · intro k f v hkf hv ih; simp only [hkf, hv, termShift_func, func_iff, true_and] + exact ⟨by simp [hv], by intro i hi; rw [nth_termShiftVec hv hi]; exact ih i hi⟩ + +@[simp] +lemma IsSemiterm.termShift {t : V} (ht : IsSemiterm L n t) : IsSemiterm L n (termShift L t) := + by + apply IsSemiterm.induction Σ ?_ ?_ ?_ ?_ t ht + · definability + · intro z hz; simp [hz] + · intro x; simp + · intro k f v hkf hv ih; simp only [hkf, hv.isUTerm, termShift_func, func, true_and] + refine IsSemitermVec.iff.mpr ⟨?_, ?_⟩ + · simp [termShiftVec, hv.isUTerm] + · intro i hi + rw [nth_termShiftVec hv.isUTerm hi] + exact ih i hi + +@[simp] +lemma IsUTermVec.termShiftVec {k v : V} (hv : IsUTermVec L k v) : + IsUTermVec L k (termShiftVec L k v) := + ⟨by simp [hv], fun i hi ↦ by rw [nth_termShiftVec hv hi]; exact (hv.nth hi).termShift⟩ + +@[simp] lemma IsSemitermVec.termShiftVec {k n v : V} (hv : IsSemitermVec L k n v) : + IsSemitermVec L k n (termShiftVec L k v) := + IsSemitermVec.iff.mpr + ⟨by simp [hv.isUTerm], fun i hi ↦ by + rw [nth_termShiftVec hv.isUTerm hi]; exact (hv.nth hi).termShift⟩ + +@[simp] +lemma IsUTerm.termBVtermShift {t : V} (ht : IsUTerm L t) : + termBV L (Bootstrapping.termShift L t) = termBV L t := + by + apply IsUTerm.induction Σ ?_ ?_ ?_ ?_ t ht + · definability + · simp + · simp + · intro k f v hf hv ih + rw [termShift_func hf hv, termBV_func hf hv.termShiftVec, termBV_func hf hv] + congr 1 + apply nth_ext' k (by simp [*]) (by simp [*]) + intro i hi + simp [*] + +@[simp] +lemma IsUTermVec.termBVVectermShiftVec {v : V} (hv : IsUTermVec L k v) : + termBVVec L k (Bootstrapping.termShiftVec L k v) = termBVVec L k v := + by + apply nth_ext' k (by simp [*]) (by simp [*]) + intro i hi + simp [*, IsUTerm.termBVtermShift (hv.nth hi)] + +end termShift + +namespace TermBShift + +/-- The blueprint construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TermBShift`. -/ +def blueprint : Language.TermRec.Blueprint 0 where + bvar := .mkSigma “y z. !qqBvarDef y (z + 1)” + fvar := .mkSigma “y x. !qqFvarDef y x” + func := .mkSigma “y k f v v'. !qqFuncDef y k f v'” + +/-- The construction construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.TermBShift`. -/ +noncomputable def construction : Language.TermRec.Construction V blueprint + where + bvar (_ z) := ^#(z + 1) + fvar (_ x) := ^&x + func (_ k f _ v') := ^func k f v' + bvar_defined := .mk fun v ↦ by simp [blueprint] + fvar_defined := .mk fun v ↦ by simp [blueprint] + func_defined := .mk fun v ↦ by simp [blueprint] + +end TermBShift + +section termBShift + +open TermBShift + +variable (L) + +/-- The term BShift construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def termBShift (t : V) : V := + construction.result L ![] t + +/-- The term BShift Vec construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def termBShiftVec (k v : V) : V := + construction.resultVec L ![] k v + +/-- The term BShift Graph construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def termBShiftGraph : Σ₁.Semisentence 2 := + blueprint.result L + +/-- The term BShift Vec Graph construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def termBShiftVecGraph : Σ₁.Semisentence 3 := + blueprint.resultVec L + +variable {L} + +@[simp] +lemma termBShift_bvar (z : V) : termBShift L ^#z = ^#(z + 1) := by + simp [termBShift, construction] + +@[simp] +lemma termBShift_fvar (x : V) : termBShift L ^&x = ^&x := by simp [termBShift, construction] + +@[simp] +lemma termBShift_func {k f v : V} (hkf : L.IsFunc k f) (hv : IsUTermVec L k v) : + termBShift L (^func k f v) = ^func k f (termBShiftVec L k v) := by + simp [termBShift, construction, hkf, hv]; rfl + +section + +instance termBShift.defined : Σ₁-Function₁ termBShift (V := V) L via termBShiftGraph L := + .mk fun v ↦ by simpa using! construction.result_defined.defined v + +instance termBShift.definable : Σ₁-Function₁ termBShift (V := V) L := + termBShift.defined.to_definable + +instance termBShift.definable' : Γ-[i + 1]-Function₁ termBShift (V := V) L := + termBShift.definable.of_sigmaOne + +instance termBShiftVec.defined : + Σ₁-Function₂ termBShiftVec (V := V) L via termBShiftVecGraph L := + .mk fun v ↦ by simpa using! construction.resultVec_defined.defined v + +instance termBShiftVec.definable : Σ₁-Function₂ termBShiftVec (V := V) L := + termBShiftVec.defined.to_definable + +instance termBShiftVec.definable' : Γ-[i + 1]-Function₂ termBShiftVec (V := V) L := + termBShiftVec.definable.of_sigmaOne + +end + +@[simp] +lemma len_termBShiftVec {k ts : V} (hts : IsUTermVec L k ts) : len (termBShiftVec L k ts) = k := + construction.resultVec_lh L _ hts + +@[simp] +lemma nth_termBShiftVec {k ts i : V} (hts : IsUTermVec L k ts) (hi : i < k) : + (termBShiftVec L k ts).[i] = termBShift L ts.[i] := + construction.nth_resultVec L _ hts hi + +@[simp] +lemma termBShiftVec_nil : termBShiftVec (V := V) L 0 0 = 0 := + construction.resultVec_nil L ![] + +lemma termBShiftVec_cons {k t ts : V} (ht : IsUTerm L t) (hts : IsUTermVec L k ts) : + termBShiftVec L (k + 1) (t ∷ ts) = termBShift L t ∷ termBShiftVec L k ts := + construction.resultVec_cons L ![] hts ht + +@[simp] +lemma termBShiftVec_cons₁ {t₁ : V} (ht₁ : IsUTerm L t₁) : + termBShiftVec L 1 (?[t₁] : V) = ?[termBShift L t₁] := by + rw [show (1 : V) = 0 + 1 by simp, termBShiftVec_cons] <;> simp [*] + +@[simp] +lemma termBShiftVec_cons₂ {t₁ t₂ : V} (ht₁ : IsUTerm L t₁) (ht₂ : IsUTerm L t₂) : + termBShiftVec L 2 (?[t₁, t₂] : V) = ?[termBShift L t₁, termBShift L t₂] := by + rw [show (2 : V) = 0 + 1 + 1 by simp [one_add_one_eq_two], termBShiftVec_cons] <;> simp [*] + +@[simp] +lemma IsSemiterm.termBShift {t : V} (ht : IsSemiterm L n t) : + IsSemiterm L (n + 1) (termBShift L t) := + by + apply IsSemiterm.induction Σ ?_ ?_ ?_ ?_ t ht + · definability + · intro z hz; simp [hz] + · intro x; simp + · intro k f v hkf hv ih; simp only [hkf, hv.isUTerm, termBShift_func, func, true_and] + refine IsSemitermVec.iff.mpr ⟨?_, ?_⟩ + · simp [hv.isUTerm] + · intro i hi + rw [nth_termBShiftVec hv.isUTerm hi] + exact ih i hi + +@[simp] lemma IsSemitermVec.termBShiftVec {k n v : V} (hv : IsSemitermVec L k n v) : + IsSemitermVec L k (n + 1) (termBShiftVec L k v) := + IsSemitermVec.iff.mpr + ⟨by simp [hv.isUTerm], fun i hi ↦ by + rw [nth_termBShiftVec hv.isUTerm hi]; exact (hv.nth hi).termBShift⟩ + +lemma termBShift_termShift {t : V} (ht : IsSemiterm L n t) : + termBShift L (termShift L t) = termShift L (termBShift L t) := + by + apply IsSemiterm.induction Σ ?_ ?_ ?_ ?_ t ht + · definability + · intro z hz; simp + · intro x; simp + · intro k f v hkf hv ih + rw [termShift_func hkf hv.isUTerm, termBShift_func hkf hv.termShiftVec.isUTerm, + termBShift_func hkf hv.isUTerm, termShift_func hkf hv.termBShiftVec.isUTerm] + simp only [qqFunc_inj, true_and] + apply + nth_ext' k (by rw [len_termBShiftVec hv.termShiftVec.isUTerm]) + (by rw [len_termShiftVec hv.termBShiftVec.isUTerm]) + intro i hi + rw [nth_termBShiftVec hv.termShiftVec.isUTerm hi, nth_termShiftVec hv.isUTerm hi, + nth_termShiftVec hv.termBShiftVec.isUTerm hi, nth_termBShiftVec hv.isUTerm hi, ih i hi] + +end termBShift + +/- +namespace TermFreeAt + +def blueprint : Language.TermRec.Blueprint 1 where + bvar := .mkSigma “y z m. (z < m → !qqBvarDef y z) ∧ (¬z < m → !qqFvarDef y 0)” + fvar := .mkSigma “y x m. !qqFvarDef y (x + 1)” + func := .mkSigma “y k f v v' m. !qqFuncDef y k f v'” + +noncomputable def construction : Language.TermRec.Construction V blueprint where + bvar param z := if z < param 0 then ^#z else ^&0 + fvar param x := ^&(x + 1) + func param k f _ v' := ^func k f v' + bvar_defined := by + intro v + by_cases C : v 1 < v 2 <;> simp [blueprint, C] + fvar_defined := by intro v; simp [blueprint] + func_defined := by intro v; simp [blueprint] + +end TermFreeAt + +section termFreeAt + +open TermFreeAt + +variable (L) + +noncomputable def termFreeAt (m t : V) : V := construction.result L ![m] t + +noncomputable def termFreeAtVec (m k v : V) : V := construction.resultVec L ![m] k v + +def termFreeAtGraph : Σ₁.Semisentence 3 := (blueprint.result L).rew <| Rew.subst ![#0, #2, #1] + +def termFreeAtVecGraph : Σ₁.Semisentence 4 := (blueprint.resultVec L).rew <| Rew.subst ![#0, #1, +#3, #2] + +variable {L} + +@[simp] lemma termFreeAt_bvar (m z : V) : + termFreeAt L m ^#z = if z < m then ^#z else ^&0 := by simp [termFreeAt, construction] + +@[simp] lemma termFreeAt_fvar (m x : V) : + termFreeAt L m ^&x = ^&(x + 1) := by simp [termFreeAt, construction] + +@[simp] lemma termFreeAt_func {m k f v : V} (hkf : L.IsFunc k f) (hv : IsUTermVec L k v) : + termFreeAt L m (^func k f v) = ^func k f (termFreeAtVec L m k v) := by + simp [termFreeAt, construction, hkf, hv]; rfl + +section + +lemma termFreeAt.defined : Σ₁-Function₂[V] termFreeAt L via termFreeAtGraph L := by + intro v + simpa [termFreeAtGraph, termFreeAt, Matrix.constant_eq_singleton, Matrix.comp_vecCons'] + using construction.result_defined (L := L) ![v 0, v 2, v 1] + +end + +end termFreeAt +-/ +variable (L) + +/-- The q Vec construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def qVec (w : V) : V := + ^#0 ∷ termBShiftVec L (len w) w + +/-- The q Vec Graph construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +noncomputable def qVecGraph : Σ₁.Semisentence 2 := .mkSigma + “w' w. ∃ k, !lenDef k w ∧ ∃ sw, !(termBShiftVecGraph L) sw k w ∧ ∃ t, !qqBvarDef t 0 ∧ + !adjoinDef w' t sw” + + + +variable {L} + +section + +instance qVec.defined : Σ₁-Function₁[V] qVec L via qVecGraph L := + .mk fun v ↦ by simp [qVecGraph]; rfl + +instance qVec.definable : Σ₁-Function₁[V] qVec L := + qVec.defined.to_definable + +instance qVec.definable' : Γ-[m + 1]-Function₁[V] qVec L := + qVec.definable.of_sigmaOne + +end + +lemma len_qVec {k w : V} (h : IsUTermVec L k w) : len (qVec L w) = k + 1 := by + rcases h.lh; simp [qVec, h] + +lemma IsSemitermVec.qVec {k n w : V} (h : IsSemitermVec L k n w) : + IsSemitermVec L (k + 1) (n + 1) (qVec L w) := + by + rcases h.lh + refine IsSemitermVec.iff.mpr ⟨?_, ?_⟩ + · simp [h.isUTerm, Bootstrapping.qVec] + · intro i hi + rcases zero_or_succ i with (rfl | ⟨i, rfl⟩) + · simp [Bootstrapping.qVec] + · simpa [Bootstrapping.qVec, nth_termBShiftVec h.isUTerm (by simpa using hi)] using + h.nth (by simpa using hi) |>.termBShift + +lemma substs_cons_bShift {u t w : V} (ht : IsSemiterm L n t) : + termSubst L (u ∷ w) (termBShift L t) = termSubst L w t := + by + apply IsSemiterm.induction Σ ?_ ?_ ?_ ?_ t ht + · definability + · intro z hz; simp + · intro x; simp + · intro k f v hf hv ih + rw [termBShift_func hf hv.isUTerm, termSubst_func hf hv.termBShiftVec.isUTerm, + termSubst_func hf hv.isUTerm] + simp only [qqFunc_inj, true_and] + apply + nth_ext' k (by rw [len_termSubstVec hv.termBShiftVec.isUTerm]) + (by rw [len_termSubstVec hv.isUTerm]) + intro i hi + rw [nth_termSubstVec hv.termBShiftVec.isUTerm hi, nth_termSubstVec hv.isUTerm hi, + nth_termBShiftVec hv.isUTerm hi, ih i hi] + +lemma termShift_termSubsts {n m w t : V} (ht : IsSemiterm L n t) (hw : IsSemitermVec L n m w) : + termShift L (termSubst L w t) = termSubst L (termShiftVec L n w) (termShift L t) := + by + apply IsSemiterm.induction Σ ?_ ?_ ?_ ?_ t ht + · definability + · intro z hz; simp [nth_termShiftVec hw.isUTerm hz] + · intro x; simp + · intro k f v hf hv ih + rw [termSubst_func hf hv.isUTerm, termShift_func hf (hw.termSubstVec hv).isUTerm, + termShift_func hf hv.isUTerm, termSubst_func hf hv.termShiftVec.isUTerm] + simp only [qqFunc_inj, true_and] + apply + nth_ext' k (by rw [len_termShiftVec (hw.termSubstVec hv).isUTerm]) + (by rw [len_termSubstVec hv.termShiftVec.isUTerm]) + intro i hi + rw [nth_termShiftVec (hw.termSubstVec hv).isUTerm hi, nth_termSubstVec hv.isUTerm hi, + nth_termSubstVec hv.termShiftVec.isUTerm hi, nth_termShiftVec hv.isUTerm hi, ih i hi] + +lemma bShift_substs {n m w t : V} (ht : IsSemiterm L n t) (hw : IsSemitermVec L n m w) : + termBShift L (termSubst L w t) = termSubst L (termBShiftVec L n w) t := + by + apply IsSemiterm.induction Σ ?_ ?_ ?_ ?_ t ht + · definability + · intro z hz; simp [nth_termBShiftVec hw.isUTerm hz] + · intro x; simp + · intro k f v hf hv ih + rw [termSubst_func hf hv.isUTerm, termBShift_func hf (hw.termSubstVec hv).isUTerm, + termSubst_func hf hv.isUTerm] + simp only [qqFunc_inj, true_and] + apply + nth_ext' k (by rw [len_termBShiftVec (hw.termSubstVec hv).isUTerm]) + (by rw [len_termSubstVec hv.isUTerm]) + intro i hi + simp [nth_termBShiftVec (hw.termSubstVec hv).isUTerm hi, nth_termSubstVec hv.isUTerm hi, + ih i hi] + +lemma substs_qVec_bShift {n t m w : V} (ht : IsSemiterm L n t) (hw : IsSemitermVec L n m w) : + termSubst L (qVec L w) (termBShift L t) = termBShift L (termSubst L w t) := + by + rcases hw.lh + simp [qVec, substs_cons_bShift ht, bShift_substs ht hw] + +lemma termSubstVec_qVec_qVec {l n m : V} (hv : IsSemitermVec L l n v) + (hw : IsSemitermVec L n m w) : + termSubstVec L (l + 1) (qVec L w) (qVec L v) = qVec L (termSubstVec L l w v) := + by + apply + nth_ext' (len v + 1) (by rw [len_termSubstVec hv.qVec.isUTerm, hv.lh]) + (by rw [len_qVec (hw.termSubstVec hv).isUTerm, hv.lh]) + intro i hi + unfold qVec + rcases hv.lh; rcases hw.lh + rw [(hw.termSubstVec hv).lh] + rw [termSubstVec_cons (by simp) (by rcases hv.lh; exact hv.termBShiftVec.isUTerm)] + rcases zero_or_succ i with (rfl | ⟨i, rfl⟩) + · simp + · have hi : i < len v := by simpa using hi + simp [nth_termSubstVec hv.termBShiftVec.isUTerm hi, nth_termBShiftVec hv.isUTerm hi, + nth_termBShiftVec (hw.termSubstVec hv).isUTerm hi, nth_termSubstVec hv.isUTerm hi, + substs_cons_bShift (hv.nth hi), bShift_substs (hv.nth hi) hw] + +lemma termShift_qVec {n m w : V} (hw : IsSemitermVec L n m w) : + termShiftVec L (n + 1) (qVec L w) = qVec L (termShiftVec L n w) := + by + apply + nth_ext' (n + 1) (by rw [len_termShiftVec hw.qVec.isUTerm]) + (by rw [len_qVec hw.termShiftVec.isUTerm]) + intro i hi + rw [nth_termShiftVec hw.qVec.isUTerm hi] + unfold qVec + rcases zero_or_succ i with (rfl | ⟨i, rfl⟩) + · simp + · rcases hw.lh + rw [nth_adjoin_succ, nth_adjoin_succ, nth_termBShiftVec hw.isUTerm (by simpa using hi), + nth_termBShiftVec (by simp [hw.isUTerm]) (by simpa [hw.isUTerm] using hi), + nth_termShiftVec hw.isUTerm (by simpa using hi), + termBShift_termShift (hw.nth (by simpa using hi))] + +section fvfree + +variable (L) + +/-- The Is Term FVFree construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +def IsTermFVFree (n t : V) : Prop := + IsSemiterm L n t ∧ termShift L t = t + +variable {L} + +@[simp] +lemma IsTermFVFree.bvar (x : V) : IsTermFVFree L n ^#x ↔ x < n := by simp [IsTermFVFree] + +@[simp] +lemma IsTermFVFree.fvar (x : V) : ¬IsTermFVFree L n ^&x := by simp [IsTermFVFree] + +end fvfree + +end + +namespace ObjectArithmetic + +-- `Arithmetic` is intentionally re-opened here even though the ambient namespace +-- already contains it; renaming would break the widely-used public API +-- (`Bootstrapping.ObjectArithmetic.*`). Suppress the new dupNamespace linter for the +-- declarations in this namespace (the option is scoped by `namespace`/`end` and +-- reverts automatically at `end Arithmetic`). + +/-- The 𝟘 construction in `𝟘`. -/ +protected def zero : ℕ := + qqFuncN 0 zeroIndex 0 + +/-- The 𝟙 construction in `𝟙`. -/ +protected def one : ℕ := + qqFuncN 0 oneIndex 0 + +/-- The qq Add construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic`. -/ +noncomputable def qqAdd (x y : V) : V := + ^func 2 (addIndex : V) ?[x, y] + +/-- The qq Mul construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic`. -/ +noncomputable def qqMul (x y : V) : V := + ^func 2 (mulIndex : V) ?[x, y] + +/-- The «term𝟘» construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic`. -/ +notation "𝟘" => ObjectArithmetic.zero + +/-- The «term𝟙» construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic`. -/ +notation "𝟙" => ObjectArithmetic.one + +/-- +The «term ^+ » construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic`. -/ +infixl:80 " ^+ " => qqAdd + +/-- +The «term ^* » construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic`. -/ +infixl:82 " ^* " => qqMul + +section + +/-- The qq Add Graph construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic`. -/ +def qqAddGraph : Σ₁.Semisentence 3 := + .mkSigma “t x y. ∃ v, !mkVec₂Def v x y ∧ !qqFuncDef t 2 ↑addIndex v” + +/-- The qq Mul Graph construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic`. -/ +def qqMulGraph : Σ₁.Semisentence 3 := + .mkSigma “t x y. ∃ v, !mkVec₂Def v x y ∧ !qqFuncDef t 2 ↑mulIndex v” + +instance qqAdd_defined : Σ₁-Function₂ (qqAdd : V → V → V) via qqAddGraph := + .mk fun v ↦ by simp [qqAddGraph, numeral_eq_natCast, qqAdd] + +instance qqMul_defined : Σ₁-Function₂ (qqMul : V → V → V) via qqMulGraph := + .mk fun v ↦ by simp [qqMulGraph, numeral_eq_natCast, qqMul] + +instance : Γ-[m + 1]-Function₂ (qqAdd : V → V → V) := + .of_sigmaOne qqAdd_defined.to_definable + +instance : Γ-[m + 1]-Function₂ (qqMul : V → V → V) := + .of_sigmaOne qqMul_defined.to_definable + +end + +@[simp] +lemma lt_qqAdd_left (x y : V) : x < x ^+ y := by + simpa using! + nth_lt_qqFunc_of_lt (i := 0) (k := 2) (f := (addIndex : V)) (v := ?[x, y]) (by simp) + +@[simp] +lemma lt_qqAdd_right (x y : V) : y < x ^+ y := by + simpa using! + nth_lt_qqFunc_of_lt (i := 1) (k := 2) (f := (addIndex : V)) (v := ?[x, y]) (by simp) + +@[simp] +lemma lt_qqMul_left (x y : V) : x < x ^* y := by + simpa using! + nth_lt_qqFunc_of_lt (i := 0) (k := 2) (f := (mulIndex : V)) (v := ?[x, y]) (by simp) + +@[simp] +lemma lt_qqMul_right (x y : V) : y < x ^* y := by + simpa using! + nth_lt_qqFunc_of_lt (i := 1) (k := 2) (f := (mulIndex : V)) (v := ?[x, y]) (by simp) + +private lemma natural_two_cast : ((2 : ℕ) : V) = 2 := + (numeral_eq_natCast_app (M := V) 2).symm.trans numeral_two_eq_two + +lemma qqFunc_absolute (k f v : ℕ) : ((^func k f v : ℕ) : V) = ^func (k : V) (f : V) (v : V) := + by + simp only [qqFunc, Nat.cast_add, nat_cast_pair, Nat.cast_one, add_left_inj, pair_ext_iff, + and_true] + exact natural_two_cast + +@[simp] +lemma zero_semiterm : IsSemiterm ℒₒᵣ n (𝟘 : V) := by + simp [ObjectArithmetic.zero, qqFunc_absolute, qqFuncN_eq_qqFunc] + +@[simp] +lemma one_semiterm : IsSemiterm ℒₒᵣ n (𝟙 : V) := by + simp [ObjectArithmetic.one, qqFunc_absolute, qqFuncN_eq_qqFunc] + +lemma coe_zero_eq : (𝟘 : V) = (^func 0 ⌜(Language.Zero.zero : (ℒₒᵣ).Func 0)⌝ 0) := + by + simp only [ObjectArithmetic.zero, qqFuncN_eq_qqFunc, qqFunc, Nat.cast_add, nat_cast_pair, + Nat.cast_zero, Nat.cast_one, add_left_inj, pair_ext_iff, and_true, true_and] + exact ⟨natural_two_cast, rfl⟩ + +lemma coe_one_eq : (𝟙 : V) = (^func 0 ⌜(Language.One.one : (ℒₒᵣ).Func 0)⌝ 0) := + by + simp only [ObjectArithmetic.one, qqFuncN_eq_qqFunc, qqFunc, Nat.cast_add, nat_cast_pair, + Nat.cast_zero, Nat.cast_one, add_left_inj, pair_ext_iff, and_true, true_and] + exact ⟨natural_two_cast, rfl⟩ + +namespace Numeral + +/-- The blueprint construction in +`FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic.Numeral`. -/ +def blueprint : PR.Blueprint 0 where + zero := .mkSigma “y. y = ↑ObjectArithmetic.one” + succ := .mkSigma “y t n. !qqAddGraph y t ↑ObjectArithmetic.one” + +/-- The construction construction in +`FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic.Numeral`. -/ +noncomputable def construction : PR.Construction V blueprint + where + zero := fun _ ↦ 𝟙 + succ := fun _ _ t ↦ t ^+ 𝟙 + zero_defined := .mk fun v ↦ by simp [blueprint, numeral_eq_natCast] + succ_defined := .mk fun v ↦ by simp [qqAdd, blueprint, numeral_eq_natCast] + +/-- The numeral Aux construction in +`FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic.Numeral`. -/ +noncomputable def numeralAux (x : V) : V := + construction.result ![] x + +@[simp] +lemma numeralAux_zero : numeralAux (0 : V) = 𝟙 := by simp [numeralAux, construction] + +@[simp] +lemma numeralAux_succ (x : V) : numeralAux (x + 1) = numeralAux x ^+ 𝟙 := by + simp [numeralAux, construction] + +section + +/-- The numeral Aux Graph construction in +`FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic.Numeral`. -/ +def numeralAuxGraph : Σ₁.Semisentence 2 := + blueprint.resultDef + +instance numeralAux.defined : Σ₁-Function₁ (numeralAux : V → V) via numeralAuxGraph := + .mk fun v ↦ by simp [construction.result_defined_iff, numeralAuxGraph]; rfl + +instance numeralAux.definable : Σ-[0 + 1]-Function₁ (numeralAux : V → V) := + numeralAux.defined.to_definable + +end + +@[simp] +lemma lt_numeralAux_self (n : V) : n < numeralAux n := + by + induction n using ISigma1.sigma1_succ_induction + · definability + case zero => simp [ObjectArithmetic.one, qqFuncN_eq_qqFunc] + case succ n ih => + refine lt_of_lt_of_le ((add_lt_add_iff_right 1).mpr ih) (by simp [succ_le_iff_lt]) + +@[simp] +lemma numeralAux_semiterm (n x : V) : IsSemiterm ℒₒᵣ n (numeralAux x) := + by + induction x using ISigma1.sigma1_succ_induction + · definability + case zero => simp + case succ x ih => simp [qqAdd, ih] + +end Numeral + +section numeral + +open Numeral + +/-- The numeral construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic`. -/ +noncomputable def numeral (x : V) : V := + if x = 0 then 𝟘 else numeralAux (x - 1) + +/-- The numeral Graph construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic`. -/ +def numeralGraph : Σ₁.Semisentence 2 := .mkSigma + “t x. + (x = 0 → t = ↑ObjectArithmetic.zero) ∧ + (x ≠ 0 → ∃ x', !subDef x' x 1 ∧ !numeralAuxGraph t x')” + +@[simp] +lemma numeral_zero : numeral (0 : V) = 𝟘 := by simp [numeral] + +@[simp] +lemma numeral_one : numeral (1 : V) = 𝟙 := by simp [numeral] + +@[simp] +lemma numeral_add_two : numeral (n + 1 + 1 : V) = numeral (n + 1) ^+ 𝟙 := by simp [numeral] + +lemma numeral_succ_pos (pos : 0 < n) : numeral (n + 1 : V) = numeral n ^+ 𝟙 := + by + rcases zero_or_succ n with (rfl | ⟨n, rfl⟩) + · simp at pos + simp [numeral] + +@[simp] +lemma numeral_semiterm (n x : V) : IsSemiterm ℒₒᵣ n (numeral x) := by + by_cases hx : x = 0 <;> simp [hx, numeral] + +@[simp] +lemma numeral_uterm (x : V) : IsUTerm ℒₒᵣ (numeral x) := + (numeral_semiterm 0 x).isUTerm + +@[simp] +lemma le_numeral_self (n : V) : n ≤ numeral n := + by + rcases zero_or_succ n with (rfl | ⟨n, rfl⟩) + · simp + · simp [numeral, succ_le_iff_lt] + +section + +instance numeral_defined : Σ₁-Function₁ (numeral : V → V) via numeralGraph := + .mk fun v ↦ by + simp [numeralGraph, numeral_eq_natCast] + by_cases hv1 : v 1 = 0 <;> simp [hv1, numeral] + +instance numeral_definable : Σ₁-Function₁ (numeral : V → V) := + numeral_defined.to_definable + +instance numeral_definable' : Γ-[m + 1]-Function₁ (numeral : V → V) := + .of_sigmaOne numeral_definable + +end + +lemma numeral_substs {w : V} (_ : IsSemitermVec ℒₒᵣ n m w) (x : V) : + termSubst ℒₒᵣ w (numeral x) = numeral x := + by + induction x using ISigma1.sigma1_succ_induction + · definability + case zero => simp [ObjectArithmetic.zero, qqFunc_absolute, qqFuncN_eq_qqFunc] + case succ x ih => + rcases zero_or_succ x with (rfl | ⟨x, rfl⟩) + · simp [ObjectArithmetic.one, qqFunc_absolute, qqFuncN_eq_qqFunc] + · simp only [numeral_add_two, qqAdd] + rw [termSubst_func (L := ℒₒᵣ) (by simp) + (by simp [ObjectArithmetic.one, qqFunc_absolute, qqFuncN_eq_qqFunc])] + simp [ih, ObjectArithmetic.one, qqFunc_absolute, qqFuncN_eq_qqFunc] + +@[simp] +lemma numeral_shift (x : V) : termShift ℒₒᵣ (numeral x) = numeral x := + by + induction x using ISigma1.sigma1_succ_induction + · definability + case zero => simp [ObjectArithmetic.zero, qqFunc_absolute, qqFuncN_eq_qqFunc] + case succ x ih => + rcases zero_or_succ x with (rfl | ⟨x, rfl⟩) + · simp [ObjectArithmetic.one, qqFunc_absolute, qqFuncN_eq_qqFunc] + · simp only [numeral_add_two, qqAdd] + rw [termShift_func (L := ℒₒᵣ) (by simp) + (by simp [ObjectArithmetic.one, qqFunc_absolute, qqFuncN_eq_qqFunc])] + simp [ih, ObjectArithmetic.one, qqFunc_absolute, qqFuncN_eq_qqFunc] + +@[simp] +lemma numeral_bShift (x : V) : termBShift ℒₒᵣ (numeral x) = numeral x := + by + induction x using ISigma1.sigma1_succ_induction + · definability + case zero => simp [ObjectArithmetic.zero, qqFunc_absolute, qqFuncN_eq_qqFunc] + case succ x ih => + rcases zero_or_succ x with (rfl | ⟨x, rfl⟩) + · simp [ObjectArithmetic.one, qqFunc_absolute, qqFuncN_eq_qqFunc] + · simp [qqAdd, ih, ObjectArithmetic.one, qqFunc_absolute, qqFuncN_eq_qqFunc] + +end numeral + +end ObjectArithmetic + +end Bootstrapping +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Term/Typed.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Term/Typed.lean new file mode 100644 index 000000000..3e97922a9 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Term/Typed.lean @@ -0,0 +1,565 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Term.Functions + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +/-! +# Typed Formalized IsSemiterm/Term + +-/ + +namespace FFL +namespace FirstOrder +namespace Arithmetic + +variable {V : Type*} [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +/-- The matrix To Vec construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def matrixToVec (v : Fin k → V) : V := + Matrix.foldr (fun t w ↦ t ∷ w) 0 v + +@[simp] +lemma matrixToVec_nil (v : Fin 0 → V) : matrixToVec v = 0 := + rfl + +@[simp] +lemma matrixToVec_succ (v : Fin (k + 1) → V) : + matrixToVec v = Matrix.vecHead v ∷ matrixToVec (Matrix.vecTail v) := + rfl + +@[simp] +lemma matrixToVec_len (v : Fin k → V) : len (matrixToVec v) = k := by induction k <;> simp [*] + +@[simp] +lemma matrixToVec_nth (v : Fin k → V) (i : Fin k) : (matrixToVec v).[↑i] = v i := + by + induction k + · exact i.elim0 + · cases i using Fin.cases + · simp; rfl + · simp [*]; rfl + +namespace Bootstrapping + +variable {L : Language} [L.Encodable] [L.LORDefinable] + +section typed_term + +variable (V L) + +/-- First-order terms with separate bound and free variables. -/ +structure Semiterm (n : ℕ) where + /-- The val construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.Semiterm`. -/ + val : V + isSemiterm : IsSemiterm (V := V) L n val + +/-- The Semiterm Vec construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +abbrev SemitermVec (m n : ℕ) := + Fin m → Semiterm V L (n : ℕ) + +attribute [simp] Semiterm.isSemiterm + +/-- The Term construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +abbrev Term := + Semiterm (V := V) L 0 + +/-- The Term Vec construction in `FFL.FirstOrder.Arithmetic.Bootstrapping`. -/ +abbrev TermVec (m : ℕ) := + SemitermVec (V := V) L m 0 + +variable {V L} {k n m : ℕ} + +@[ext] +lemma Semiterm.ext (t u : Semiterm V L n) (h : t.val = u.val) : t = u := by + rcases t; rcases u; + simpa using h + +@[simp] +lemma Semiterm.isSemiterm_zero (t : Term V L) : IsSemiterm L 0 t.val := by + simpa using t.isSemiterm + +@[simp] +lemma Semiterm.isSemiterm_one (t : Semiterm V L 1) : IsSemiterm L 1 t.val := by + simpa using t.isSemiterm + +@[simp] +lemma Semiterm.isSemiterm_succ (t : Semiterm V L (n + 1)) : IsSemiterm L (↑n + 1 : V) t.val := + by simpa using t.isSemiterm + +@[simp] +lemma Semiterm.isUTerm (t : Semiterm V L n) : IsUTerm L t.val := + t.isSemiterm.isUTerm + +/-- The val construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.SemitermVec`. -/ +noncomputable def SemitermVec.val (v : SemitermVec V L k n) : V := + matrixToVec ((fun t ↦ t.val)↗ v) + +@[simp] +lemma SemitermVec.val_nil (v : SemitermVec V L 0 n) : v.val = 0 := + rfl + +lemma SemitermVec.val_cons (t : Semiterm V L n) (v : SemitermVec V L k n) : + SemitermVec.val (t :> v : SemitermVec V L (k + 1) n) = t.val ∷ v.val := by rfl + +@[simp] +lemma SemitermVec.val_succ (v : SemitermVec V L (k + 1) n) : + SemitermVec.val (v : SemitermVec V L (k + 1) n) = + (Matrix.vecHead v).val ∷ SemitermVec.val (Matrix.vecTail v) := + by rfl + +lemma SemitermVec.val_inj (v₁ v₂ : SemitermVec V L k n) : v₁ = v₂ ↔ v₁.val = v₂.val := + by + induction k + · simp [Matrix.empty_eq] + case succ k ih => simp [← Semiterm.ext_iff, ← ih, Matrix.eq_iff_eq_vecHead_of_eq_vecTail] + +@[simp] +lemma SemitermVec.isSemitermVec {k} (v : SemitermVec V L k n) : + IsSemitermVec (V := V) L k n v.val := by induction k <;> simp [*] + +@[simp] +lemma SemitermVec.isUTermVec {k} (v : SemitermVec V L k n) : IsUTermVec (V := V) L k v.val := by + induction k <;> simp [*] + +@[simp] +lemma SemitermVec.len_eq (v : SemitermVec V L k n) : len v.val = ↑k := by + induction k <;> simp [*] + +@[simp] +lemma SemitermVec.val_nth_eq (v : SemitermVec V L k n) (i : Fin k) : + v.val.[(i : V)] = (v i).val := by + induction k + · apply finZeroElim i + · cases i using Fin.cases + · simp; rfl + · simp [*]; rfl + +/-- The bvar construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.Semiterm`. -/ +noncomputable def Semiterm.bvar (z : Fin n) : Semiterm V L n := + ⟨^#z, by simp⟩ + +/-- The fvar construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.Semiterm`. -/ +noncomputable def Semiterm.fvar (x : V) : Semiterm V L n := + ⟨^&x, by simp⟩ + +/-- The func construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.Semiterm`. -/ +noncomputable def Semiterm.func (f : L.Func k) (v : SemitermVec V L k n) : Semiterm V L n := + ⟨^func ↑k ⌜f⌝ v.val, by simp⟩ + +/-- The bv construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.Semiterm`. -/ +noncomputable abbrev Semiterm.bv (x : Fin n) : Semiterm V L n := + Semiterm.bvar x + +/-- The fv construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.Semiterm`. -/ +noncomputable abbrev Semiterm.fv (x : V) : Semiterm V L n := + Semiterm.fvar x + +@[simp] +lemma Semiterm.bvar_val (z : Fin n) : (Semiterm.bvar z : Semiterm V L n).val = ^#(z : V) := + rfl + +@[simp] +lemma Semiterm.fvar_val (x : V) : (Semiterm.fvar x : Semiterm V L n).val = ^&x := + rfl + +@[simp] +lemma Semiterm.func_val (f : L.Func k) (v : SemitermVec V L k n) : + (Semiterm.func f v).val = ^func ↑k ⌜f⌝ v.val := + rfl + +namespace Semiterm + +@[simp] +lemma bvar_inj_iff (z x : Fin n) : (bvar z : Semiterm V L n) = bvar x ↔ z = x := + ⟨by simpa [bvar] using Fin.eq_of_val_eq, by rintro rfl; rfl⟩ + +@[simp] +lemma fvar_inj_iff (z x : V) : (fvar z : Semiterm V L n) = fvar x ↔ z = x := by simp [fvar] + +@[simp] +lemma func_inj_iff (f₁ f₂ : L.Func k) (v₁ v₂ : SemitermVec V L k n) : + func f₁ v₁ = func f₂ v₂ ↔ f₁ = f₂ ∧ v₁ = v₂ := + by + simp only [func, Semiterm.ext_iff, qqFunc_inj, quote_func_inj, true_and, and_congr_right_iff] + rintro rfl + symm; exact SemitermVec.val_inj v₁ v₂ + +/-- The shift construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.Semiterm`. -/ +noncomputable def shift (t : Semiterm V L n) : Semiterm V L n := + ⟨termShift L t.val, IsSemiterm.termShift t.isSemiterm⟩ + +/-- The b Shift construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.Semiterm`. -/ +noncomputable def bShift (t : Semiterm V L n) : Semiterm V L (n + 1) := + ⟨termBShift L t.val, IsSemiterm.termBShift t.isSemiterm⟩ + +/-- The subst construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.Semiterm`. -/ +noncomputable def subst (w : SemitermVec V L n m) (t : Semiterm V L n) : Semiterm V L m := + ⟨termSubst L w.val t.val, w.isSemitermVec.termSubst t.isSemiterm⟩ + +/-- The free construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.Semiterm`. -/ +noncomputable def free (t : Semiterm V L 1) : Semiterm V L 0 := + t.shift.subst ![fvar 0] + +@[simp] +lemma val_shift (t : Semiterm V L n) : t.shift.val = termShift L t.val := + rfl + +@[simp] +lemma val_bShift (t : Semiterm V L n) : t.bShift.val = termBShift L t.val := + rfl + +@[simp] +lemma val_substs (w : SemitermVec V L n m) (t : Semiterm V L n) : + (t.subst w).val = termSubst L w.val t.val := + rfl + +end Semiterm + +namespace SemitermVec + +@[simp] +lemma val_shift (v : SemitermVec V L k n) : + val (Semiterm.shift↗ v) = termShiftVec L (↑k) v.val := by + induction k <;> simp [termShiftVec_cons, *] + +@[simp] +lemma val_bShift (v : SemitermVec V L k n) : + val (Semiterm.bShift↗ v) = termBShiftVec L (↑k) v.val := by + induction k <;> simp [termBShiftVec_cons, *] + +@[simp] +lemma val_substs (v : SemitermVec V L k n) (w : SemitermVec V L n m) : + val ((Semiterm.subst w)↗ v) = termSubstVec L (↑k) w.val v.val := by + induction k <;> simp [termSubstVec_cons, *] + +/-- The q construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.SemitermVec`. -/ +noncomputable def q (w : SemitermVec V L k n) : SemitermVec V L (k + 1) (n + 1) := + Semiterm.bvar 0 :> Semiterm.bShift↗ w + +@[simp] +lemma q_zero (w : SemitermVec V L k n) : w.q 0 = Semiterm.bvar 0 := + rfl + +@[simp] +lemma q_succ (w : SemitermVec V L k n) (i : Fin k) : w.q i.succ = Semiterm.bShift (w i) := + rfl + +lemma q_val_eq_qVec (w : SemitermVec V L k n) : w.q.val = qVec L w.val := by simp [q, qVec] + +@[simp] +lemma q_vecHead (w : SemitermVec V L k n) : Matrix.vecHead w.q = Semiterm.bvar 0 := + rfl + +@[simp] +lemma q_vecTail (w : SemitermVec V L k n) : Matrix.vecTail w.q = Semiterm.bShift↗ w := + rfl + +end SemitermVec + +namespace Semiterm + +@[simp] +lemma shift_bvar (z : Fin n) : shift (Semiterm.bvar z : Semiterm V L n) = Semiterm.bvar z := by + ext; simp [Semiterm.bvar, shift] + +@[simp] +lemma shift_fvar (x : V) : shift (Semiterm.fvar x : Semiterm V L n) = Semiterm.fvar (x + 1) := + by ext; simp [Semiterm.fvar, shift] + +@[simp] +lemma shift_func (f : L.Func k) (v : SemitermVec V L k n) : + shift (func f v) = func f (shift↗ v) := by ext; simp [Semiterm.func, shift] + +@[simp] +lemma bShift_bvar (z : Fin n) : + bShift (Semiterm.bvar z : Semiterm V L n) = Semiterm.bvar z.succ := by + ext; + simp [Semiterm.bvar, bShift] + +@[simp] +lemma bShift_fvar (x : V) : bShift (Semiterm.fvar x : Semiterm V L n) = Semiterm.fvar x := by + ext; simp [Semiterm.fvar, bShift] + +@[simp] +lemma bShift_func (f : L.Func k) (v : SemitermVec V L k n) : + bShift (func f v) = func f (bShift↗ v) := by ext; simp [Semiterm.func, bShift] + +@[simp] +lemma substs_bvar (z : Fin n) (w : SemitermVec V L n m) : (Semiterm.bvar z).subst w = w z := by + ext; simp [subst] + +@[simp] +lemma substs_fvar (w : SemitermVec V L n m) (x : V) : + (Semiterm.fvar x : Semiterm V L n).subst w = Semiterm.fvar x := by + ext; + simp [Semiterm.fvar, subst] + +@[simp] +lemma substs_func (f : L.Func k) (w : SemitermVec V L n m) (v : SemitermVec V L k n) : + (func f v).subst w = func f ((subst w)↗ v) := by ext; simp [Semiterm.func, subst] + +@[simp] +lemma free_bvar (z : Fin 1) : free (bvar z : Semiterm V L 1) = fvar 0 := by simp [free] + +@[simp] +lemma free_fvar (x : V) : free (Semiterm.fvar x : Semiterm V L 1) = fvar (x + 1) := by + simp [free] + +@[simp] +lemma bShift_substs_q (t : Semiterm V L n) (w : SemitermVec V L n m) : + t.bShift.subst w.q = (t.subst w).bShift := by + ext; + simp only [subst, SemitermVec.q_val_eq_qVec, bShift, + substs_qVec_bShift t.isSemiterm w.isSemitermVec] + +@[simp] +lemma bShift_substs_sing (t u : Term V L) : t.bShift.subst ![u] = t := by + ext; + simp [subst, bShift, substs_cons_bShift t.isSemiterm, substs_nil t.isSemiterm] + +lemma bShift_substs_succ (w : SemitermVec V L (n + 1) m) (t : Semiterm V L n) : + t.bShift.subst w = t.subst (Matrix.vecTail w) := by + ext; + simp [subst, bShift, substs_cons_bShift t.isSemiterm] + +@[simp] +lemma bShift_substs_zero (t : Term V L) : t.subst ![] = t := by ext; simp [subst] + +lemma bShift_shift_comm (t : Semiterm V L n) : t.shift.bShift = t.bShift.shift := by + ext; + simp [termBShift_termShift t.isSemiterm] + +lemma shift_substs (w : SemitermVec V L n m) (t : Semiterm V L n) : + (t.subst w).shift = t.shift.subst (Semiterm.shift↗ w) := by + ext; + simp [Bootstrapping.termShift_termSubsts t.isSemiterm w.isSemitermVec] + +lemma substs_substs {n m l : ℕ} (v : SemitermVec V L m l) (w : SemitermVec V L n m) + (t : Semiterm V L n) : (t.subst w).subst v = t.subst ((Semiterm.subst v)↗ w) := by + ext; + simp [Bootstrapping.termSubst_termSubst w.isSemitermVec t.isSemiterm] + +end Semiterm + +end typed_term + +section typed_isfvfree + +variable {k n m : ℕ} + +namespace Semiterm + +/-- The FVFree construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.Semiterm`. -/ +def FVFree (t : Semiterm V L n) : Prop := + IsTermFVFree L (↑n) t.val + +lemma FVFree.iff {t : Semiterm V L n} : t.FVFree ↔ t.shift = t := by + simp [FVFree, IsTermFVFree, Semiterm.ext_iff] + +@[simp] +lemma FVFree.bvar (i : Fin n) : (Semiterm.bvar i : Semiterm V L n).FVFree := by simp [FVFree] + +@[simp] +lemma FVFree.bShift (t : Semiterm V L n) (ht : t.FVFree) : t.bShift.FVFree := by + simp [FVFree.iff, ← bShift_shift_comm, FVFree.iff.mp ht] + +end Semiterm + +end typed_isfvfree + +namespace ObjectArithmetic + +variable {k n m : ℕ} + +/-- +The typed Numeral construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic`. -/ +noncomputable def typedNumeral (m : V) : Semiterm V ℒₒᵣ n := + ⟨numeral m, by simp⟩ + +/-- The «termℕᵗ » construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic`. -/ +scoped prefix:max "ℕᵗ" => typedNumeral + +/-- The add construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic`. -/ +noncomputable def add (t u : Semiterm V ℒₒᵣ n) : Semiterm V ℒₒᵣ n := + ⟨t.val ^+ u.val, by simp [qqAdd]⟩ + +/-- The mul construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.ObjectArithmetic`. -/ +noncomputable def mul (t u : Semiterm V ℒₒᵣ n) : Semiterm V ℒₒᵣ n := + ⟨t.val ^* u.val, by simp [qqMul]⟩ + +noncomputable instance (n : ℕ) : Add (Semiterm V ℒₒᵣ n) := + ⟨add⟩ + +noncomputable instance (n : ℕ) : Mul (Semiterm V ℒₒᵣ n) := + ⟨mul⟩ + +@[simp] +lemma val_numeral (x : V) : (ℕᵗx : Semiterm V ℒₒᵣ n).val = numeral x := + rfl + +@[simp] +lemma val_add (t₁ t₂ : Semiterm V ℒₒᵣ n) : (t₁ + t₂).val = t₁.val ^+ t₂.val := + rfl + +@[simp] +lemma val_mul (t₁ t₂ : Semiterm V ℒₒᵣ n) : (t₁ * t₂).val = t₁.val ^* t₂.val := + rfl + +@[simp] +lemma zero_eq (v) : + Semiterm.func (V := V) (n := n) (Language.Zero.zero : (ℒₒᵣ).Func 0) v = typedNumeral 0 := by + ext; simp [coe_zero_eq] + +@[simp] +lemma one_eq (v) : + Semiterm.func (V := V) (n := n) (Language.One.one : (ℒₒᵣ).Func 0) v = typedNumeral 1 := by + ext; simp [coe_one_eq] + +@[simp] +lemma add_eq (v : Fin 2 → Semiterm V ℒₒᵣ n) : + Semiterm.func (Language.Add.add : (ℒₒᵣ).Func 2) v = v 0 + v 1 := by ext; rfl + +@[simp] +lemma mul_eq (v : Fin 2 → Semiterm V ℒₒᵣ n) : + Semiterm.func (Language.Mul.mul : (ℒₒᵣ).Func 2) v = v 0 * v 1 := by ext; rfl + +@[simp] +lemma add_inj_iff {t₁ t₂ u₁ u₂ : Semiterm V ℒₒᵣ n} : t₁ + t₂ = u₁ + u₂ ↔ t₁ = u₁ ∧ t₂ = u₂ := by + simp [Semiterm.ext_iff, qqAdd] + +@[simp] +lemma mul_inj_iff {t₁ t₂ u₁ u₂ : Semiterm V ℒₒᵣ n} : t₁ * t₂ = u₁ * u₂ ↔ t₁ = u₁ ∧ t₂ = u₂ := by + simp [Semiterm.ext_iff, qqMul] + +@[simp] +lemma numeral_add_two' (x : V) : + (typedNumeral (x + 1 + 1) : Semiterm V ℒₒᵣ n) = typedNumeral (x + 1) + typedNumeral 1 := by + ext; simp [numeral] + +lemma numeral_succ_pos' {x : V} (pos : 0 < x) : + (typedNumeral (x + 1) : Semiterm V ℒₒᵣ n) = typedNumeral x + typedNumeral 1 := by + ext; + simp [numeral_succ_pos pos] + +@[simp] +lemma subst_numeral (w : SemitermVec V ℒₒᵣ n m) (x : V) : + (ℕᵗ x : Semiterm V ℒₒᵣ n).subst w = ℕᵗ x := by + ext; + simp [Semiterm.subst, numeral_substs w.isSemitermVec] + +@[simp] +lemma subst_add (w : SemitermVec V ℒₒᵣ n m) (t₁ t₂ : Semiterm V ℒₒᵣ n) : + (t₁ + t₂).subst w = t₁.subst w + t₂.subst w := by ext; simp [qqAdd, Semiterm.subst] + +@[simp] +lemma subst_mul (w : SemitermVec V ℒₒᵣ n m) (t₁ t₂ : Semiterm V ℒₒᵣ n) : + (t₁ * t₂).subst w = t₁.subst w * t₂.subst w := by ext; simp [qqMul, Semiterm.subst] + +@[simp] +lemma shift_numeral (x : V) : (ℕᵗ x : Semiterm V ℒₒᵣ n).shift = ℕᵗ x := by + ext; + simp [Semiterm.shift] + +@[simp] +lemma shift_add (t₁ t₂ : Semiterm V ℒₒᵣ n) : (t₁ + t₂).shift = t₁.shift + t₂.shift := by + ext; + simp [qqAdd, Semiterm.shift] + +@[simp] +lemma shift_mul (t₁ t₂ : Semiterm V ℒₒᵣ n) : (t₁ * t₂).shift = t₁.shift * t₂.shift := by + ext; + simp [qqMul, Semiterm.shift] + +@[simp] +lemma bShift_numeral (x : V) : (ℕᵗ x : Semiterm V ℒₒᵣ n).bShift = ℕᵗ x := by + ext; + simp [Semiterm.bShift] + +@[simp] +lemma bShift_add (t₁ t₂ : Semiterm V ℒₒᵣ n) : (t₁ + t₂).bShift = t₁.bShift + t₂.bShift := by + ext; simp [qqAdd, Semiterm.bShift] + +@[simp] +lemma bShift_mul (t₁ t₂ : Semiterm V ℒₒᵣ n) : (t₁ * t₂).bShift = t₁.bShift * t₂.bShift := by + ext; simp [qqMul, Semiterm.bShift] + +@[simp] +lemma fvFree_numeral (x : V) : (ℕᵗx : Semiterm V ℒₒᵣ n).FVFree := by simp [Semiterm.FVFree.iff] + +@[simp] +lemma fvFree_add (t₁ t₂ : Semiterm V ℒₒᵣ n) : (t₁ + t₂).FVFree ↔ t₁.FVFree ∧ t₂.FVFree := by + simp [Semiterm.FVFree.iff] + +@[simp] +lemma fvFree_mul (t₁ t₂ : Semiterm V ℒₒᵣ n) : (t₁ * t₂).FVFree ↔ t₁.FVFree ∧ t₂.FVFree := by + simp [Semiterm.FVFree.iff] + +@[simp] +lemma free_add (t₁ t₂ : Semiterm V ℒₒᵣ 1) : (t₁ + t₂).free = t₁.free + t₂.free := by + simp [Semiterm.free] + +@[simp] +lemma free_mul (t₁ t₂ : Semiterm V ℒₒᵣ 1) : (t₁ * t₂).free = t₁.free * t₂.free := by + simp [Semiterm.free] + +@[simp] +lemma free_numeral (x : V) : (ℕᵗ x : Semiterm V ℒₒᵣ 1).free = ℕᵗ x := by + simp [Semiterm.free] + /- + lemma replace {P : α → isSemiterm} {x y} (hx : P x) (h : x = y) : P y := h ▸ hx + + lemma semiterm_induction (Γ) {n : V} {P : Semiterm V ℒₒᵣ n → isSemiterm} + (hP : Γ-[1]-Predicate (fun x ↦ (h : IsSemiterm ℒₒᵣ n x) → P ⟨x, h⟩)) + (hBvar : ∀ (z : V) (h : z < n), P (bvar ℒₒᵣ z h)) + (hFvar : ∀ x, P (⌜ℒₒᵣ⌝.fvar x)) + (hZero : P ((0 : V) : Semiterm V ℒₒᵣ n)) + (hOne : P ((1 : V) : Semiterm V ℒₒᵣ n)) + (hAdd : ∀ t₁ t₂, P t₁ → P t₂ → P (t₁ + t₂)) + (hMul : ∀ t₁ t₂, P t₁ → P t₂ → P (t₁ * t₂)) : + ∀ (t : ⌜ℒₒᵣ⌝[V].Semiterm n), P t := by + let Q := fun x ↦ (h : IsSemiterm ℒₒᵣ n x) → P ⟨x, h⟩ + suffices ∀ t, IsSemiterm ℒₒᵣ n t → Q t by intro t; exact this t.val t.isSemiterm t.isSemiterm + apply IsSemiterm.induction Γ hP + case hbvar => intro z hz _; exact hBvar z hz + case hfvar => intro x _; exact hFvar x + case hfunc => + intro k f v hf hv ih _ + rcases (by simpa [func_iff] using hf) with (⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | ⟨rfl, rfl⟩ | ⟨rfl, + rfl⟩) + · rcases (by simpa using hv) + exact replace hZero (by ext; simp [Formalized.zero, qqFunc_absolute]) + · rcases (by simpa using hv) + exact replace hOne (by ext; simp [Formalized.one, qqFunc_absolute]) + · rcases IsSemitermVec.two_iff.mp hv with ⟨t₁, t₂, ht₁, ht₂, rfl⟩ + exact hAdd ⟨t₁, ht₁⟩ ⟨t₂, ht₂⟩ + (by simpa using ih 0 (by simp) (by simp [ht₁])) + (by simpa using ih 1 (by simp) (by simp [ht₂])) + · rcases IsSemitermVec.two_iff.mp hv with ⟨t₁, t₂, ht₁, ht₂, rfl⟩ + exact hMul ⟨t₁, ht₁⟩ ⟨t₂, ht₂⟩ + (by simpa using ih 0 (by simp) (by simp [ht₁])) + (by simpa using ih 1 (by simp) (by simp [ht₂])) + -/ + +end ObjectArithmetic +end Bootstrapping +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Theory.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Theory.lean new file mode 100644 index 000000000..c39d5f2c8 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Theory.lean @@ -0,0 +1,226 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Formula.Coding +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Syntax.Classical.PrimrecCoding +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Computability + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace FFL +namespace FirstOrder +namespace Theory + +variable {L : Language} [L.Encodable] [L.LORDefinable] + +/-- +TODO: define predicate `VariableFree` and make `mem_iff` `∀ φ : Sentence, ℕ ⊧/![⌜φ⌝] ch.val ↔ φ +∈ T` -/ +class Δ₁ (T : Theory L) where + /-- The ch construction in `FFL.FirstOrder.Theory.Δ₁`. -/ + ch : ∆₁.Semisentence 1 + mem_iff : ∀ φ : Proposition L, ℕ ⊧/![⌜φ⌝] ch.val ↔ ∃ σ ∈ T, φ = σ + isDelta1 : ch.ProvablyProperOn 𝐈Σ₁ + +/-- The Δ₁ch construction in `FFL.FirstOrder.Theory`. -/ +abbrev Δ₁ch (T : Theory L) [T.Δ₁] : ∆₁.Semisentence 1 := + Δ₁.ch T + +variable [L.Primcodable] + +/-- Data and laws for RE in `FFL.FirstOrder.Theory`. -/ +class RE (T : Theory L) : Prop where + re : REPred (· ∈ T) + +/-- Data and laws for Primrec in `FFL.FirstOrder.Theory`. -/ +protected class Primrec (T : Theory L) : Prop where + primrec : PrimrecPred (· ∈ T) + +instance {T : Theory L} [T.Primrec] : T.RE := + ⟨Theory.Primrec.primrec.computablePred.to_re⟩ + +namespace RE + +variable {T U : Theory L} + +omit [L.LORDefinable] in +lemma add (hT : T.RE) (hU : U.RE) : (T ∪ U).RE := + ⟨(REPred.or hT.re hU.re).of_eq fun _ ↦ Iff.rfl⟩ + +variable [L.DecidableEq] + +omit [L.LORDefinable] in +lemma ofFinite (hT : Set.Finite T) : T.RE := by + constructor; + simpa using + show REPred (· ∈ hT.toFinset) by + induction hT.toFinset using Finset.induction_on with + | empty => exact (REPred.const False).of_eq fun _ ↦ by simp + | @insert σ s _ ih => + exact + ((PointwiseComposition.REPred.or + (PrimrecPred.computablePred + (Primrec.eq.comp Primrec.id (Primrec.const σ))).to_re) + ih).of_eq + fun _ ↦ by simp + +end RE + +end Theory +end FirstOrder +end FFL + +namespace FFL +namespace FirstOrder +namespace Arithmetic +namespace Bootstrapping + +variable {V : Type*} [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +variable {L : Language} [L.Encodable] [L.LORDefinable] + +/-- The Δ₁Class construction in `FFL.FirstOrder.Theory`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Theory.Δ₁Class (T : Theory L) [T.Δ₁] : Set V := + {φ : V | V ⊧/![φ] T.Δ₁ch.val} + +variable {T : Theory L} [T.Δ₁] + +instance Δ₁Class.defined : ∆₁-Predicate[V] (· ∈ T.Δ₁Class) via T.Δ₁ch := + .mk <| by + constructor + · intro v + have : V ⊧/![v 0] (Theory.Δ₁.ch T).sigma.val ↔ V ⊧/![v 0] (Theory.Δ₁.ch T).pi.val := + by + have := + (consequence_iff (T := 𝐈Σ₁)).mp + (Theory.Proof.sound <| FirstOrder.Theory.Δ₁.isDelta1 (T := T)) V inferInstance + simp [models_iff] at this ⊢ + simpa [Matrix.constant_eq_singleton, Function.comp_def] using this ![v 0] + rwa [Matrix.fun_eq_vec_one v] + · intro v; simp [← Matrix.fun_eq_vec_one, Theory.Δ₁Class] + +instance Δ₁Class.definable : ∆₁-Predicate[V] (· ∈ T.Δ₁Class) := + Δ₁Class.defined.to_definable + +lemma Δ₁Class.proper : T.Δ₁ch.ProperOn V := + (Theory.Δ₁.isDelta1 (T := T)).properOn V + +@[simp] +lemma Δ₁Class.mem_iff_s {φ : Proposition L} : (⌜φ⌝ : V) ∈ T.Δ₁Class ↔ ∃ σ ∈ T, φ = σ := + have : V ⊧/![⌜φ⌝] T.Δ₁ch.val ↔ ℕ ⊧/![⌜φ⌝] T.Δ₁ch.val := by + simpa [Semiformula.coe_quote_eq_quote, Matrix.constant_eq_singleton] using + FirstOrder.Arithmetic.models_iff_of_Delta1 (V := V) (σ := T.Δ₁ch) (by simp) (by simp) + (e := ![⌜φ⌝]) + Iff.trans this (Theory.Δ₁.mem_iff _) + +@[simp] +lemma Δ₁Class.mem_iff {φ : Sentence L} : (⌜φ⌝ : V) ∈ T.Δ₁Class ↔ φ ∈ T := by + simp [Sentence.quote_def, Δ₁Class.mem_iff_s] + +lemma Δ₁Class.mem_iff' {φ : Sentence L} : V ⊧/![⌜φ⌝] T.Δ₁ch.val ↔ φ ∈ T := + Δ₁Class.mem_iff + +lemma Δ₁Class.mem_iff'_s {φ : Proposition L} : V ⊧/![⌜φ⌝] T.Δ₁ch.val ↔ ∃ σ ∈ T, φ = σ := + Δ₁Class.mem_iff_s + +@[simp] +lemma Δ₁Class.mem_iff'' {φ : Sentence L} : + ((⌜φ⌝ : Bootstrapping.Formula V L).val : V) ∈ T.Δ₁Class ↔ φ ∈ T := + Δ₁Class.mem_iff + +end Bootstrapping +end Arithmetic +end FirstOrder +end FFL + +namespace FFL +namespace FirstOrder +namespace Theory + +variable {L : Language} [L.Encodable] [L.LORDefinable] + +variable {T U : Theory L} + +namespace Δ₁ + +open Arithmetic.HierarchySymbol.Semiformula FFL.FirstOrder.Theory + +/-- The add construction in `FFL.FirstOrder.Theory.Δ₁`. -/ +abbrev add (dT : T.Δ₁) (dU : U.Δ₁) : (T ∪ U).Δ₁ + where + ch := T.Δ₁ch ⋎ U.Δ₁ch + mem_iff + {φ} := + by + simp only [Nat.succ_eq_add_one, Nat.reduceAdd, val_or, LogicalConnective.HomClass.map_or, + FirstOrder.Arithmetic.Bootstrapping.Δ₁Class.mem_iff'_s, LogicalConnective.Prop.or_eq, + Set.mem_union] + grind + isDelta1 := ProvablyProperOn.ofProperOn.{0} _ fun V _ _ ↦ ProperOn.or (by simp) (by simp) + +/-- The of Eq construction in `FFL.FirstOrder.Theory.Δ₁`. -/ +abbrev ofEq (dT : T.Δ₁) (h : T = U) : U.Δ₁ + where + ch := dT.ch + mem_iff := by rcases h; exact dT.mem_iff + isDelta1 := by rcases h; exact dT.isDelta1 + +instance empty : Theory.Δ₁ (∅ : Theory L) + where + ch := ⊥ + mem_iff {ψ} := by simp + isDelta1 := ProvablyProperOn.ofProperOn.{0} _ fun V _ _ ↦ by simp + +/-- The singleton construction in `FFL.FirstOrder.Theory.Δ₁`. -/ +abbrev singleton (φ : Sentence L) : Theory.Δ₁ { φ } + where + ch := .ofZero (.mkSigma (“x. x = ↑(Encodable.encode φ)”)) _ + mem_iff {ψ} := by simp [Semiformula.quote_eq_encode] + isDelta1 := ProvablyProperOn.ofProperOn.{0} _ fun V _ _ ↦ by simp + +@[simp] +lemma singleton_toTDef_ch_val (φ : Sentence L) : + letI := Δ₁.singleton φ + ({ φ } : Theory L).Δ₁ch.val = (“x. x = ↑(Encodable.encode φ)”) := + by rfl + +/-- The of List construction in `FFL.FirstOrder.Theory.Δ₁`. -/ +abbrev ofList (l : List (Sentence L)) : Δ₁ {φ | φ ∈ l} := + match l with + | [] => empty.ofEq (by ext; simp) + | φ :: l => ((singleton φ).add (ofList l)).ofEq (by ext; simp) + +/-- The of Finite construction in `FFL.FirstOrder.Theory.Δ₁`. -/ +noncomputable abbrev ofFinite (T : Theory L) (h : Set.Finite T) : T.Δ₁ := + (ofList h.toFinset.toList).ofEq (by ext; simp) + +instance [T.Δ₁] [U.Δ₁] : (T ∪ U).Δ₁ := + add inferInstance inferInstance + +instance (φ : Sentence L) : Theory.Δ₁ { φ } := + singleton φ + +instance insert [d : T.Δ₁] : (insert φ T).Δ₁ := + (d.add (singleton φ)).ofEq (by ext; simp) + +end Δ₁ + +end Theory +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/BoundedCollection.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/BoundedCollection.lean new file mode 100644 index 000000000..099f5cea1 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/BoundedCollection.lean @@ -0,0 +1,125 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Schemata + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# Σ_{s+1}-collection + +Every `Σ_{s+1}` predicate bounded pointwise by a witness admits a single bound `w` that +witnesses all instances at once (`sigma_exists_bound_witness`). +-/ + +@[expose] public section + +open FFL + +open FFL.FirstOrder + +noncomputable section + +namespace FFL +namespace FirstOrder +namespace Arithmetic + +variable {V : Type*} {n s : ℕ} (e : Fin n → V) + +private def collectionCore (θ : ArithmeticSemisentence (n + 2)) : ArithmeticSemiformula V 4 := + Rew.embSubsts (#0 :> #1 :> fun i => (&(e i) : ArithmeticSemiterm V 4)) ▹ θ + +private def collectionMotive (θ : ArithmeticSemisentence (n + 2)) (a : V) : + ArithmeticSemiformula V 1 := + let cond : ArithmeticSemiformula V 3 := + Semiformula.rel Language.LT.lt + ![(#0 : ArithmeticSemiterm V 3), (&a : ArithmeticSemiterm V 3)] + let inner : ArithmeticSemiformula V 3 := + (collectionCore e θ).bexsLTSucc (#1 : ArithmeticSemiterm V 3) + ∃¹ ((cond ⇒ₗ inner).ballLT (#1 : ArithmeticSemiterm V 2)) + +variable {θ : ArithmeticSemisentence (n + 2)} + +private lemma hierarchy_collectionCore (hθ : Hierarchy Σ (s + 1) θ) : + Hierarchy Σ (s + 1) (collectionCore e θ) := by simp [collectionCore, hθ] + +private lemma hierarchy_collectionMotive (hθ : Hierarchy Σ (s + 1) θ) (a : V) : + Hierarchy Σ (s + 1) (collectionMotive e θ a) := + by + have : Hierarchy Σ (s + 1) (collectionCore e θ) := hierarchy_collectionCore e hθ + simp [collectionMotive, this] + +variable [ORingStructure V] + +private lemma eval_collectionCore (u x w y : V) : + (collectionCore e θ).Eval (u :> x :> w :> ![y]) id ↔ V ⊧/(u :> x :> e) θ := + by + simp only [collectionCore, Semiformula.eval_embSubsts, Function.comp_def] + exact + Iff.of_eq + (congrArg (fun b => Semiformula.Evalb (M := V) b θ) + (Fin.funext_two (by simp) (by simp) fun i => by simp)) + +private lemma eval_collectionMotive [V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] (a : V) (v : Fin 1 → V) : + (collectionMotive e θ a).Eval v id ↔ ∃ w, ∀ x < v 0, x < a → ∃ u ≤ w, V ⊧/(u :> x :> e) θ := + by + rw [Matrix.fun_eq_vec_one v] + simp [collectionMotive, Semiformula.eval_ballLT, Semiformula.eval_bexsLTSucc, + Arithmetic.lt_succ_iff_le, eval_collectionCore, Function.comp_def] + +variable [V↓[ℒₒᵣ] ⊧* 𝐈Σ(s + 1)] + +private lemma collectionMotive_definable (hθ : Hierarchy Σ (s + 1) θ) (a : V) : + Σ-[s + 1].DefinablePred (fun y => ∃ w, ∀ x < y, x < a → ∃ u ≤ w, V ⊧/(u :> x :> e) θ) := + by + have := mod_paMinus_of_ISigma (V := V) (s := s + 1) + exact + HierarchySymbol.Definable.mkPolarity (collectionMotive e θ a) + (hierarchy_collectionMotive e hθ a) (fun v => (eval_collectionMotive e a v).symm) + +theorem sigma_exists_bound_witness {θ : ArithmeticSemisentence (n + 2)} + (hθ : Hierarchy Σ (s + 1) θ) (e : Fin n → V) (a : V) + (h : ∀ x < a, ∃ u, V ⊧/(u :> x :> e) θ) : ∃ w, ∀ x < a, ∃ u ≤ w, V ⊧/(u :> x :> e) θ := + by + have := mod_paMinus_of_ISigma (V := V) (s := s + 1) + have key : ∀ y : V, ∃ w, ∀ x < y, x < a → ∃ u ≤ w, V ⊧/(u :> x :> e) θ := + by + apply + InductionOnHierarchy.succ_induction_sigma Σ (s + 1) (P := fun y => + ∃ w, ∀ x < y, x < a → ∃ u ≤ w, V ⊧/(u :> x :> e) θ) (hP := + collectionMotive_definable e hθ a) + · exact ⟨0, fun x hx _ => absurd hx (by simp)⟩ + · rintro y ⟨w, hw⟩ + rcases lt_or_ge y a with hya | hya + · obtain ⟨u₀, hu₀⟩ := h y hya + use max w u₀; intro x hx _ + rcases le_iff_lt_or_eq.mp (Arithmetic.lt_succ_iff_le.mp hx) with hx | rfl + · obtain ⟨u, hu, hPu⟩ := hw x hx (lt_trans hx hya) + exact ⟨u, le_trans hu (le_max_left w u₀), hPu⟩ + · exact ⟨u₀, le_max_right w u₀, hu₀⟩ + · use w; intro x hx hxa + rcases le_iff_lt_or_eq.mp (Arithmetic.lt_succ_iff_le.mp hx) with hx | rfl + · exact hw x hx hxa + · exact absurd hxa (not_lt.mpr hya) + obtain ⟨w, hw⟩ := key (a + 1) + exact ⟨w, fun x hx => hw x (lt_trans hx (lt_add_one a)) hx⟩ + +end Arithmetic +end FirstOrder +end FFL + +end + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Definability.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Definability.lean new file mode 100644 index 000000000..10c003b0b --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Definability.lean @@ -0,0 +1,21 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Definability.Hierarchy +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Definability.Definable +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Definability.BoundedDefinable +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Definability.Absoluteness + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Definability/Absoluteness.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Definability/Absoluteness.lean new file mode 100644 index 000000000..a31b74d69 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Definability/Absoluteness.lean @@ -0,0 +1,147 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Definability.BoundedDefinable + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace FFL +namespace FirstOrder +namespace Arithmetic + +open PeanoMinus R0 + +lemma nat_modelsWithParam_iff_models_substs {v : Fin k → ℕ} {φ : ArithmeticSemisentence k} : + φ.Evalb v ↔ ℕ↓[ℒₒᵣ] ⊧ (φ ↜ (fun i ↦ Semiterm.Operator.numeral ℒₒᵣ (v i))) := by + simp [models_iff, Function.comp_def, Matrix.empty_eq] + +variable (V : Type*) [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] + +lemma modelsWithParam_iff_models_substs {v : Fin k → ℕ} {φ : ArithmeticSemisentence k} : + φ.Evalb (M := V) (Nat.cast ∘ v) ↔ + V↓[ℒₒᵣ] ⊧ (φ ↜ (fun i ↦ Semiterm.Operator.numeral ℒₒᵣ (v i))) := + by simp [models_iff, Function.comp_def, Matrix.empty_eq, numeral_eq_natCast] + +lemma shigmaZero_absolute {k} (φ : Σ₀.Semisentence k) (v : Fin k → ℕ) : + φ.val.Evalb v ↔ φ.val.Evalb (M := V) (Nat.cast ∘ v) := + ⟨by + simpa [nat_modelsWithParam_iff_models_substs, modelsWithParam_iff_models_substs] using + nat_extention_sigmaOne V (by simp), + by + simpa [nat_modelsWithParam_iff_models_substs, modelsWithParam_iff_models_substs] using + nat_extention_piOne V (by simp)⟩ + +lemma Defined.shigmaZero_absolute {k} {R : (Fin k → ℕ) → Prop} {R' : (Fin k → V) → Prop} + {φ : Σ₀.Semisentence k} (hR : Σ₀.Defined R φ) (hR' : Σ₀.Defined R' φ) (v : Fin k → ℕ) : + R v ↔ R' (Nat.cast ∘ v) := by + simpa [hR.iff, hR'.iff] using Arithmetic.shigmaZero_absolute V φ v + +lemma DefinedFunction.shigmaZero_absolute_func {k} {f : (Fin k → ℕ) → ℕ} {f' : (Fin k → V) → V} + {φ : Σ₀.Semisentence (k + 1)} (hf : Σ₀.DefinedFunction f φ) (hf' : Σ₀.DefinedFunction f' φ) + (v : Fin k → ℕ) : (f v : V) = f' (Nat.cast ∘ v) := by + simpa [Function.comp_def] using Defined.shigmaZero_absolute V hf hf' (f v :> v) + +lemma sigmaOne_upward_absolute {k} (φ : Σ₁.Semisentence k) (v : Fin k → ℕ) : + φ.val.Evalb v → φ.val.Evalb (M := V) (Nat.cast ∘ v) := by + simpa [nat_modelsWithParam_iff_models_substs, modelsWithParam_iff_models_substs] using + nat_extention_sigmaOne V (by simp) + +lemma piOne_downward_absolute {k} (φ : Π₁.Semisentence k) (v : Fin k → ℕ) : + φ.val.Evalb (M := V) (Nat.cast ∘ v) → φ.val.Evalb v := by + simpa [nat_modelsWithParam_iff_models_substs, modelsWithParam_iff_models_substs] using + nat_extention_piOne V (by simp) + +lemma deltaOne_absolute {k} (φ : ∆₁.Semisentence k) (properNat : φ.ProperOn ℕ) + (proper : φ.ProperOn V) (v : Fin k → ℕ) : + φ.val.Evalb v ↔ φ.val.Evalb (M := V) (Nat.cast ∘ v) := + ⟨by simpa [HierarchySymbol.Semiformula.val_sigma] using sigmaOne_upward_absolute V φ.sigma v, + by simpa [proper.iff', properNat.iff'] using piOne_downward_absolute V φ.pi v⟩ + +lemma Defined.shigmaOne_absolute {k} {R : (Fin k → ℕ) → Prop} {R' : (Fin k → V) → Prop} + {φ : ∆₁.Semisentence k} (hR : ∆₁.Defined R φ) (hR' : ∆₁.Defined R' φ) (v : Fin k → ℕ) : + R v ↔ R' (Nat.cast ∘ v) := by simpa using deltaOne_absolute V φ hR.proper hR'.proper v + +lemma DefinedFunction.shigmaOne_absolute_func {k} {f : (Fin k → ℕ) → ℕ} {f' : (Fin k → V) → V} + {φ : Σ₁.Semisentence (k + 1)} (hf : Σ₁.DefinedFunction f φ) (hf' : Σ₁.DefinedFunction f' φ) + (v : Fin k → ℕ) : (f v : V) = f' (Nat.cast ∘ v) := by + simpa [Function.comp_def] using + Defined.shigmaOne_absolute V hf.graph_delta hf'.graph_delta (f v :> v) + +variable {V} + +lemma models_iff_of_Sigma0 {σ : ArithmeticSemisentence n} (hσ : Hierarchy Σ 0 σ) + {e : Fin n → ℕ} : σ.Evalb (M := V) (Nat.cast ∘ e) ↔ σ.Evalb e := + by + by_cases h : σ.Evalb e <;> simp [h] + · have : σ.Evalb (M := V) (Nat.cast ∘ e) := by + simpa [numeral_eq_natCast] using + bold_sigma_one_completeness' (M := V) (by simp [Hierarchy.of_zero hσ]) h + simpa [HierarchySymbol.Semiformula.val_sigma] using this + · have : (∼σ).Evalb (M := ℕ) e := by simpa using h + have : (∼σ).Evalb (M := V) (Nat.cast ∘ e) := by + simpa [numeral_eq_natCast] using + bold_sigma_one_completeness' (M := V) (by simp [Hierarchy.of_zero hσ]) this + simpa using this + +lemma models_iff_of_Delta1 {σ : ∆₁.Semisentence n} (hσ : σ.ProperOn ℕ) (hσV : σ.ProperOn V) + {e : Fin n → ℕ} : σ.val.Evalb (M := V) (Nat.cast ∘ e) ↔ σ.val.Evalb e := + by + by_cases h : σ.val.Evalb e <;> simp [h] + · have : σ.sigma.val.Evalb e := by simpa [HierarchySymbol.Semiformula.val_sigma] using h + have : σ.sigma.val.Evalb (M := V) (Nat.cast ∘ e) := by + simpa [numeral_eq_natCast] using bold_sigma_one_completeness' (M := V) (by simp) this + simpa [HierarchySymbol.Semiformula.val_sigma] using this + · have : (∼σ.pi.val).Evalb (M := ℕ) e := by simpa [hσ.iff'] using h + have : (∼σ.pi.val).Evalb (M := V) (Nat.cast ∘ e) := by + simpa [numeral_eq_natCast] using bold_sigma_one_completeness' (M := V) (by simp) this + simpa [hσV.iff'] using this + +variable {T : ArithmeticTheory} [𝐏𝐀⁻ ≼ T] [T.SoundOnHierarchy Σ 1] + +noncomputable instance : 𝐑₀ ≼ T := + Entailment.WeakerThan.trans (𝓣 := 𝐏𝐀⁻) inferInstance inferInstance + +theorem sigma_one_completeness_iff_param {σ : ArithmeticSemisentence n} (hσ : Hierarchy Σ 1 σ) + {e : Fin n → ℕ} : ℕ ⊧/e σ ↔ T ⊢ (σ ↜ fun x ↦ Semiterm.Operator.numeral ℒₒᵣ (e x)) := + Iff.trans (by simp [models_iff, Semiformula.eval_substs, Function.comp_def, Matrix.empty_eq]) + (sigma_one_completeness_iff (T := T) (by simp [hσ])) + +lemma models_iff_provable_of_Sigma0_param {σ : ArithmeticSemisentence n} (hσ : Hierarchy Σ 0 σ) + {e : Fin n → ℕ} : + V ⊧/(Nat.cast ∘ e) σ ↔ T ⊢ (σ ↜ fun x ↦ Semiterm.Operator.numeral ℒₒᵣ (e x)) := by + calc + V ⊧/(Nat.cast ∘ e) σ ↔ ℕ ⊧/e σ := by simp [models_iff_of_Sigma0 hσ] + _ ↔ T ⊢ (σ ↜ fun x ↦ Semiterm.Operator.numeral ℒₒᵣ (e x)) := by + apply sigma_one_completeness_iff_param (by simp [Hierarchy.of_zero hσ]) + +lemma models_iff_provable_of_Delta1_param {σ : ∆₁.Semisentence n} (hσ : σ.ProperOn ℕ) + (hσV : σ.ProperOn V) {e : Fin n → ℕ} : + V ⊧/(Nat.cast ∘ e) σ.val ↔ T ⊢ (σ.val ↜ fun x ↦ Semiterm.Operator.numeral ℒₒᵣ (e x)) := by + calc + V ⊧/(Nat.cast ∘ e) σ.val ↔ ℕ ⊧/e σ.val := by simp [models_iff_of_Delta1 hσ hσV] + _ ↔ ℕ ⊧/e σ.sigma.val := by simp [HierarchySymbol.Semiformula.val_sigma] + _ ↔ T ⊢ (σ.sigma.val ↜ fun x ↦ Semiterm.Operator.numeral ℒₒᵣ (e x)) := by + apply sigma_one_completeness_iff_param (by simp) + _ ↔ T ⊢ (σ.val ↜ fun x ↦ Semiterm.Operator.numeral ℒₒᵣ (e x)) := by + simp [HierarchySymbol.Semiformula.val_sigma] + +end Arithmetic + +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Definability/BoundedDefinable.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Definability/BoundedDefinable.lean new file mode 100644 index 000000000..a243e8d76 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Definability/BoundedDefinable.lean @@ -0,0 +1,521 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Definability.Definable + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace FFL +namespace FirstOrder +namespace Arithmetic + +open PeanoMinus + +variable {ξ : Type*} {n : ℕ} + +variable {V : Type*} [ORingStructure V] + +variable {ℌ : HierarchySymbol} {Γ Γ' : SigmaPiDelta} + +variable (ℌ) + +/-- Data and laws for Bounded in `FFL.FirstOrder.Arithmetic`. -/ +class Bounded (f : (Fin k → V) → V) : Prop where + bounded : ∃ t : ArithmeticSemiterm V k, ∀ v : Fin k → V, f v ≤ t.val v id + +/-- The Bounded₁ construction in `FFL.FirstOrder.Arithmetic`. -/ +abbrev Bounded₁ (f : V → V) : Prop := + Bounded (k := 1) (fun v ↦ f (v 0)) + +/-- The Bounded₂ construction in `FFL.FirstOrder.Arithmetic`. -/ +abbrev Bounded₂ (f : V → V → V) : Prop := + Bounded (k := 2) (fun v ↦ f (v 0) (v 1)) + +/-- The Bounded₃ construction in `FFL.FirstOrder.Arithmetic`. -/ +abbrev Bounded₃ (f : V → V → V → V) : Prop := + Bounded (k := 3) (fun v ↦ f (v 0) (v 1) (v 2)) + +instance (f : (Fin k → V) → V) [h : Bounded f] : Bounded f := + by + rcases h with ⟨t, ht⟩ + exact ⟨t, by simpa⟩ + +variable {ℌ} + +namespace Bounded + +@[simp] +lemma var [V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k} (i : Fin k) : Bounded fun v : Fin k → V ↦ v i := + ⟨#i, by intro _; simp⟩ + +@[simp] +lemma const [V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k} (c : V) : Bounded (fun _ : Fin k → V ↦ c) := + ⟨&c, by intro _; simp⟩ + +@[simp] +lemma term_retraction [V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] (t : ArithmeticSemiterm V n) (e : Fin n → Fin k) : + Bounded fun v : Fin k → V ↦ t.val (fun x ↦ v (e x)) id := + ⟨Rew.subst (fun x ↦ #(e x)) t, by intro _; simp [Semiterm.val_substs, Function.comp_def]⟩ + +lemma term [V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] (t : ArithmeticSemiterm V k) : + Bounded fun v : Fin k → V => t.val v id := + ⟨t, by intro _; simp⟩ + +lemma retraction {f : (Fin k → V) → V} (hf : Bounded f) (e : Fin k → Fin n) : + Bounded fun v ↦ f (fun i ↦ v (e i)) := + by + rcases hf with ⟨t, ht⟩ + refine ⟨Rew.subst (fun x ↦ #(e x)) t, ?_⟩ + intro v + simpa [Semiterm.val_substs, Function.comp_def] using ht (fun i => v (e i)) + +lemma comp [V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k} {f : (Fin l → V) → V} {g : Fin l → (Fin k → V) → V} + (hf : Bounded f) (hg : ∀ i, Bounded (g i)) : Bounded (fun v ↦ f (g · v)) where + bounded := by + rcases hf.bounded with ⟨tf, htf⟩ + choose tg htg using fun i ↦ (hg i).bounded + exact + ⟨Rew.subst tg tf, by + intro v + simpa [Semiterm.val_substs, Function.comp_def] using! + le_trans (htf (g · v)) + (Tarski.Structure.Monotone.term_monotone tf (fun i ↦ htg i v) (by simp))⟩ + +end Bounded + +lemma Bounded₁.comp [V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {f : V → V} {k} {g : (Fin k → V) → V} (hf : Bounded₁ f) + (hg : Bounded g) : Bounded (fun v ↦ f (g v)) := + Bounded.comp hf (l := 1) (fun _ ↦ hg) + +lemma Bounded₂.comp [V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {f : V → V → V} {k} {g₁ g₂ : (Fin k → V) → V} + (hf : Bounded₂ f) (hg₁ : Bounded g₁) (hg₂ : Bounded g₂) : + Bounded (fun v ↦ f (g₁ v) (g₂ v)) := + Bounded.comp hf (g := ![g₁, g₂]) (fun i ↦ by cases i using Fin.cases <;> simp [*]) + +lemma Bounded₃.comp [V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {f : V → V → V → V} {k} {g₁ g₂ g₃ : (Fin k → V) → V} + (hf : Bounded₃ f) (hg₁ : Bounded g₁) (hg₂ : Bounded g₂) (hg₃ : Bounded g₃) : + Bounded (fun v ↦ f (g₁ v) (g₂ v) (g₃ v)) := + Bounded.comp hf (g := ![g₁, g₂, g₃]) + (fun i ↦ by + refine Fin.cases ?_ (fun i => ?_) i <;> simp only [Nat.succ_eq_add_one, Nat.reduceAdd, + Fin.isValue, Matrix.cons_val_zero, hg₁, Matrix.cons_val_succ] + refine Fin.cases ?_ (fun i => ?_) i <;> simp [*]) + +namespace Bounded₂ + +variable [V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] + +instance add : Bounded₂ ((· + ·) : V → V → V) where bounded := ⟨‘x y. x + y’, by intro _; simp⟩ + +instance mul : Bounded₂ ((· * ·) : V → V → V) where bounded := ⟨‘x y. x * y’, by intro _; simp⟩ + +instance hAdd : Bounded₂ (HAdd.hAdd : V → V → V) where + bounded := ⟨‘x y. x + y’, by intro _; simp⟩ + +instance hMul : Bounded₂ (HMul.hMul : V → V → V) where + bounded := ⟨‘x y. x * y’, by intro _; simp⟩ + +end Bounded₂ + +/-- The Definable Bounded Function construction in `FFL.FirstOrder.Arithmetic`. -/ +def DefinableBoundedFunction {k} (f : (Fin k → V) → V) := + Bounded f ∧ Σ₀.DefinableFunction f + +/-- The Definable Bounded Function₁ construction in `FFL.FirstOrder.Arithmetic`. -/ +abbrev DefinableBoundedFunction₁ (f : V → V) : Prop := + DefinableBoundedFunction (k := 1) (fun v => f (v 0)) + +/-- The Definable Bounded Function₂ construction in `FFL.FirstOrder.Arithmetic`. -/ +abbrev DefinableBoundedFunction₂ (f : V → V → V) : Prop := + DefinableBoundedFunction (k := 2) (fun v => f (v 0) (v 1)) + +/-- The Definable Bounded Function₃ construction in `FFL.FirstOrder.Arithmetic`. -/ +abbrev DefinableBoundedFunction₃ (f : V → V → V → V) : Prop := + DefinableBoundedFunction (k := 3) (fun v => f (v 0) (v 1) (v 2)) + +lemma DefinableBoundedFunction.bounded {f : (Fin k → V) → V} (h : DefinableBoundedFunction f) : + Bounded f := + h.1 + +lemma DefinableBoundedFunction₁.bounded {f : V → V} (h : DefinableBoundedFunction₁ f) : + Bounded₁ f := + h.1 + +lemma DefinableBoundedFunction₂.bounded {f : V → V → V} (h : DefinableBoundedFunction₂ f) : + Bounded₂ f := + h.1 + +lemma DefinableBoundedFunction₃.bounded {f : V → V → V → V} (h : DefinableBoundedFunction₃ f) : + Bounded₃ f := + h.1 + +lemma DefinableBoundedFunction.definable {f : (Fin k → V) → V} + (h : DefinableBoundedFunction f) : ℌ.DefinableFunction f := + .of_zero h.2 + +lemma DefinableBoundedFunction₁.definable {f : V → V} (h : DefinableBoundedFunction₁ f) : + ℌ.DefinableFunction₁ f := + .of_zero h.2 + +lemma DefinableBoundedFunction₂.definable {f : V → V → V} (h : DefinableBoundedFunction₂ f) : + ℌ.DefinableFunction₂ f := + .of_zero h.2 + +lemma DefinableBoundedFunction₃.definable {f : V → V → V → V} + (h : DefinableBoundedFunction₃ f) : ℌ.DefinableFunction₃ f := + .of_zero h.2 + +namespace DefinableBoundedFunction + +lemma of_polybounded_of_definable (f : (Fin k → V) → V) [hb : Bounded f] + [hf : Σ₀.DefinableFunction f] : DefinableBoundedFunction f := + ⟨hb, hf⟩ + +@[simp] +lemma of_polybounded_of_definable₁ (f : V → V) [hb : Bounded₁ f] + [hf : Σ₀.DefinableFunction₁ f] : DefinableBoundedFunction₁ f := + ⟨hb, hf⟩ + +@[simp] +lemma of_polybounded_of_definable₂ (f : V → V → V) [hb : Bounded₂ f] + [hf : Σ₀.DefinableFunction₂ f] : DefinableBoundedFunction₂ f := + ⟨hb, hf⟩ + +@[simp] +lemma of_polybounded_of_definable₃ (f : V → V → V → V) [hb : Bounded₃ f] + [hf : Σ₀.DefinableFunction₃ f] : DefinableBoundedFunction₃ f := + ⟨hb, hf⟩ + +lemma retraction {f : (Fin k → V) → V} (hf : DefinableBoundedFunction f) (e : Fin k → Fin n) : + DefinableBoundedFunction fun v ↦ f (fun i ↦ v (e i)) := + ⟨hf.bounded.retraction e, hf.definable.retraction e⟩ + +end DefinableBoundedFunction + +namespace HierarchySymbol +namespace Definable + +variable [V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] + +variable {P Q : (Fin k → V) → Prop} + +lemma ball_blt {P : (Fin k → V) → V → Prop} {f : (Fin k → V) → V} + (hf : DefinableBoundedFunction f) (h : ℌ.Definable fun w ↦ P (w ·.succ) (w 0)) : + ℌ.Definable fun v ↦ ∀ x < f v, P v x := + by + rcases hf.bounded with ⟨bf, hbf⟩ + have : ℌ.Definable fun v ↦ ∃ x ≤ bf.val v id, x = f v ∧ ∀ y < x, P v y := + by + apply bexs'; apply and + · exact hf.definable + · suffices ℌ.Definable fun x ↦ ∀ y < (#0).val (L := ℒₒᵣ) x id, P (fun x_1 ↦ x x_1.succ) y by + simpa + apply ball ?_ #0 + simpa using h.retraction (0 :> (·.succ.succ)) + exact + this.of_iff <| fun v ↦ ⟨fun h ↦ ⟨f v, hbf v, rfl, h⟩, by rintro ⟨y, hy, rfl, h⟩; exact h⟩ + +lemma bexs_blt {P : (Fin k → V) → V → Prop} {f : (Fin k → V) → V} + (hf : DefinableBoundedFunction f) (h : ℌ.Definable fun w ↦ P (w ·.succ) (w 0)) : + ℌ.Definable fun v ↦ ∃ x < f v, P v x := + by + rcases hf.bounded with ⟨bf, hbf⟩ + have : ℌ.Definable fun v ↦ ∃ x ≤ bf.val v id, x = f v ∧ ∃ y < x, P v y := + by + apply bexs'; apply and + · exact hf.definable + · suffices ℌ.Definable fun x ↦ ∃ y < (#0).val (L := ℒₒᵣ) x id, P (fun x_1 ↦ x x_1.succ) y by + simpa + apply bexs ?_ #0 + simpa using h.retraction (0 :> (·.succ.succ)) + exact + this.of_iff <| fun v ↦ ⟨fun h ↦ ⟨f v, hbf v, rfl, h⟩, by rintro ⟨y, hy, rfl, h⟩; exact h⟩ + +lemma ball_ble {P : (Fin k → V) → V → Prop} {f : (Fin k → V) → V} + (hf : DefinableBoundedFunction f) (h : ℌ.Definable fun w ↦ P (w ·.succ) (w 0)) : + ℌ.Definable fun v ↦ ∀ x ≤ f v, P v x := + by + rcases hf.bounded with ⟨bf, hbf⟩ + have : ℌ.Definable fun v ↦ ∃ x ≤ bf.val v id, x = f v ∧ ∀ y ≤ x, P v y := + by + apply bexs'; apply and + · exact hf.definable + · suffices ℌ.Definable fun x ↦ ∀ y ≤ (#0).val (L := ℒₒᵣ) x id, P (fun x_1 ↦ x x_1.succ) y by + simpa + apply ball' ?_ #0 + simpa using h.retraction (0 :> (·.succ.succ)) + exact + this.of_iff <| fun v ↦ ⟨fun h ↦ ⟨f v, hbf v, rfl, h⟩, by rintro ⟨y, hy, rfl, h⟩; exact h⟩ + +lemma bexs_ble {P : (Fin k → V) → V → Prop} {f : (Fin k → V) → V} + (hf : DefinableBoundedFunction f) (h : ℌ.Definable fun w ↦ P (w ·.succ) (w 0)) : + ℌ.Definable fun v ↦ ∃ x ≤ f v, P v x := + by + rcases hf.bounded with ⟨bf, hbf⟩ + have : ℌ.Definable fun v ↦ ∃ x ≤ bf.val v id, x = f v ∧ ∃ y ≤ x, P v y := + by + apply bexs'; apply and + · exact hf.definable + · suffices ℌ.Definable fun x ↦ ∃ y ≤ (#0).val (L := ℒₒᵣ) x id, P (fun x_1 ↦ x x_1.succ) y by + simpa + apply bexs' ?_ #0 + simpa using h.retraction (0 :> (·.succ.succ)) + exact + this.of_iff <| fun v ↦ ⟨fun h ↦ ⟨f v, hbf v, rfl, h⟩, by rintro ⟨y, hy, rfl, h⟩; exact h⟩ + +lemma ball_blt_zero {P : (Fin k → V) → V → Prop} {f : (Fin k → V) → V} + (hf : DefinableBoundedFunction f) (h : Γ-[0].Definable fun w ↦ P (w ·.succ) (w 0)) : + Γ-[0].Definable fun v ↦ ∀ x < f v, P v x := + ball_blt hf h + +lemma bexs_blt_zero {P : (Fin k → V) → V → Prop} {f : (Fin k → V) → V} + (hf : DefinableBoundedFunction f) (h : Γ-[0].Definable fun w ↦ P (w ·.succ) (w 0)) : + Γ-[0].Definable fun v ↦ ∃ x < f v, P v x := + bexs_blt hf h + +lemma ball_ble_zero {P : (Fin k → V) → V → Prop} {f : (Fin k → V) → V} + (hf : DefinableBoundedFunction f) (h : Γ-[0].Definable fun w ↦ P (w ·.succ) (w 0)) : + Γ-[0].Definable fun v ↦ ∀ x ≤ f v, P v x := + ball_ble hf h + +lemma bexs_ble_zero {P : (Fin k → V) → V → Prop} {f : (Fin k → V) → V} + (hf : DefinableBoundedFunction f) (h : Γ-[0].Definable fun w ↦ P (w ·.succ) (w 0)) : + Γ-[0].Definable fun v ↦ ∃ x ≤ f v, P v x := + bexs_ble hf h + +lemma bexs_vec_le_boldfaceBoundedFunction {k} {φ : Fin l → (Fin k → V) → V} + {P : (Fin k → V) → (Fin l → V) → Prop} (pp : ∀ i, DefinableBoundedFunction (φ i)) + (hP : + ℌ.Definable fun w : Fin (k + l) → V ↦ + P (fun i ↦ w (i.castAdd l)) (fun j ↦ w (j.natAdd k))) : + ℌ.Definable fun v ↦ ∃ w ≤ (φ · v), P v w := + by + induction l generalizing k + case zero => simpa [Matrix.empty_eq (α := V)] using hP + case succ l ih => + simp only [Fin.exists_le_vec_iff_exists_le_exists_vec] + apply bexs_ble (pp 0) + apply ih + · intro i; apply DefinableBoundedFunction.retraction (pp i.succ) + · let g : Fin (k + (l + 1)) → Fin (k + 1 + l) := + Matrix.vecAppend rfl (fun x ↦ x.succ.castAdd l) + (Fin.castAdd l 0 :> fun j ↦ j.natAdd (k + 1)) + exact + of_iff (retraction hP g) <| by + intro v; simp only [g] + apply iff_of_eq; congr + · ext i; congr 1; ext; simp [Matrix.vecAppend_eq_ite] + · ext i + refine Fin.cases ?_ (fun i => ?_) i + · simp only [Matrix.cons_val_zero]; congr 1; ext; simp [Matrix.vecAppend_eq_ite] + · simp only [Matrix.cons_val_succ]; congr 1; ext; simp [Matrix.vecAppend_eq_ite] + +lemma substitution_boldfaceBoundedFunction {f : Fin k → (Fin l → V) → V} (hP : ℌ.Definable P) + (hf : ∀ i, DefinableBoundedFunction (f i)) : ℌ.Definable fun z ↦ P (f · z) := + by + have : ℌ.Definable fun v ↦ ∃ w ≤ (f · v), (∀ i, w i = f i v) ∧ P w := + by + apply bexs_vec_le_boldfaceBoundedFunction hf + apply and + · apply fintype_all; intro i + simpa using retraction (.of_zero (hf i).2) (i.natAdd l :> Fin.castAdd k) + · apply retraction hP + apply + of_iff this <| by + intro v; constructor + · intro h; exact ⟨(f · v), by intro i; simp, by simp, h⟩ + · rintro ⟨w, hw, e, h⟩ + rcases funext e + exact h + +end Definable +end HierarchySymbol + +namespace DefinableBoundedFunction + +lemma of_iff {f g : (Fin k → V) → V} (H : DefinableBoundedFunction f) (h : ∀ v, f v = g v) : + DefinableBoundedFunction g := + by + have : f = g := by funext v; simp [h] + rcases this; exact H + +variable [V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] + +@[simp] +lemma var {k} (i : Fin k) : DefinableBoundedFunction (fun v : Fin k → V ↦ v i) := + ⟨by simp, by simp⟩ + +@[simp] +lemma const {k} (c : V) : DefinableBoundedFunction (fun _ : Fin k → V ↦ c) := + ⟨by simp, by simp⟩ + +@[simp] +lemma term_retraction (t : ArithmeticSemiterm V n) (e : Fin n → Fin k) : + DefinableBoundedFunction fun v : Fin k → V ↦ t.val (fun x ↦ v (e x)) id := + ⟨by simp, by simp⟩ + +lemma term (t : ArithmeticSemiterm V k) : + DefinableBoundedFunction fun v : Fin k → V ↦ t.val v id := + ⟨by simp, by simp⟩ + +end DefinableBoundedFunction + +namespace HierarchySymbol +namespace Definable + +open DefinableBoundedFunction + +variable [V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] + +lemma bcomp₁ {k} {P : V → Prop} {f : (Fin k → V) → V} [hP : ℌ.DefinablePred P] + (hf : DefinableBoundedFunction f) : ℌ.Definable fun v ↦ P (f v) := + substitution_boldfaceBoundedFunction (f := ![f]) hP (by simp [*]) + +lemma bcomp₂ {k} {R : V → V → Prop} {f₁ f₂ : (Fin k → V) → V} [hR : ℌ.DefinableRel R] + (hf₁ : DefinableBoundedFunction f₁) (hf₂ : DefinableBoundedFunction f₂) : + ℌ.Definable fun v ↦ R (f₁ v) (f₂ v) := + substitution_boldfaceBoundedFunction (f := ![f₁, f₂]) hR + (by simp [Fin.forall_fin_iff_zero_and_forall_succ, *]) + +lemma bcomp₃ {k} {R : V → V → V → Prop} {f₁ f₂ f₃ : (Fin k → V) → V} [hR : ℌ.DefinableRel₃ R] + (hf₁ : DefinableBoundedFunction f₁) (hf₂ : DefinableBoundedFunction f₂) + (hf₃ : DefinableBoundedFunction f₃) : ℌ.Definable fun v ↦ R (f₁ v) (f₂ v) (f₃ v) := + substitution_boldfaceBoundedFunction (f := ![f₁, f₂, f₃]) hR + (by simp [Fin.forall_fin_iff_zero_and_forall_succ, *]) + +lemma bcomp₄ {k} {R : V → V → V → V → Prop} {f₁ f₂ f₃ f₄ : (Fin k → V) → V} + [hR : ℌ.DefinableRel₄ R] (hf₁ : DefinableBoundedFunction f₁) + (hf₂ : DefinableBoundedFunction f₂) (hf₃ : DefinableBoundedFunction f₃) + (hf₄ : DefinableBoundedFunction f₄) : ℌ.Definable fun v ↦ R (f₁ v) (f₂ v) (f₃ v) (f₄ v) := + substitution_boldfaceBoundedFunction (f := ![f₁, f₂, f₃, f₄]) hR + (by simp [Fin.forall_fin_iff_zero_and_forall_succ, *]) + +lemma bcomp₁_zero {k} {P : V → Prop} {f : (Fin k → V) → V} [hP : Γ-[0].DefinablePred P] + (hf : DefinableBoundedFunction f) : Γ-[0].Definable fun v ↦ P (f v) := + substitution_boldfaceBoundedFunction (f := ![f]) hP (by simp [*]) + +lemma bcomp₂_zero {k} {R : V → V → Prop} {f₁ f₂ : (Fin k → V) → V} [hR : Γ-[0].DefinableRel R] + (hf₁ : DefinableBoundedFunction f₁) (hf₂ : DefinableBoundedFunction f₂) : + Γ-[0].Definable fun v ↦ R (f₁ v) (f₂ v) := + substitution_boldfaceBoundedFunction (f := ![f₁, f₂]) hR + (by simp [Fin.forall_fin_iff_zero_and_forall_succ, *]) + +lemma bcomp₃_zero {k} {R : V → V → V → Prop} {f₁ f₂ f₃ : (Fin k → V) → V} + [hR : Γ-[0].DefinableRel₃ R] (hf₁ : DefinableBoundedFunction f₁) + (hf₂ : DefinableBoundedFunction f₂) (hf₃ : DefinableBoundedFunction f₃) : + Γ-[0].Definable fun v ↦ R (f₁ v) (f₂ v) (f₃ v) := + substitution_boldfaceBoundedFunction (f := ![f₁, f₂, f₃]) hR + (by simp [Fin.forall_fin_iff_zero_and_forall_succ, *]) + +lemma bcomp₄_zero {k} {R : V → V → V → V → Prop} {f₁ f₂ f₃ f₄ : (Fin k → V) → V} + [hR : Γ-[0].DefinableRel₄ R] (hf₁ : DefinableBoundedFunction f₁) + (hf₂ : DefinableBoundedFunction f₂) (hf₃ : DefinableBoundedFunction f₃) + (hf₄ : DefinableBoundedFunction f₄) : + Γ-[0].Definable fun v ↦ R (f₁ v) (f₂ v) (f₃ v) (f₄ v) := + substitution_boldfaceBoundedFunction (f := ![f₁, f₂, f₃, f₄]) hR + (by simp [Fin.forall_fin_iff_zero_and_forall_succ, *]) + +end Definable +end HierarchySymbol + +variable [V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] + +lemma HierarchySymbol.DefinableFunction.bcomp {k} {F : (Fin l → V) → V} + {f : Fin l → (Fin k → V) → V} (hF : ℌ.DefinableFunction F) + (hf : ∀ i, DefinableBoundedFunction (f i)) : ℌ.DefinableFunction (fun v ↦ F (f · v)) := by + simpa using + Definable.substitution_boldfaceBoundedFunction (f := (· 0) :> fun i w ↦ f i (w ·.succ)) + hF <| + by + intro i + refine Fin.cases ?_ (fun i => ?_) i + · simp + · simpa using DefinableBoundedFunction.retraction (hf i) Fin.succ + +lemma HierarchySymbol.DefinableFunction₁.bcomp {k} {F : V → V} {f : (Fin k → V) → V} + (hF : ℌ.DefinableFunction₁ F) (hf : DefinableBoundedFunction f) : + ℌ.DefinableFunction (fun v ↦ F (f v)) := + HierarchySymbol.DefinableFunction.bcomp (f := ![f]) hF (by simp [*]) + +lemma HierarchySymbol.DefinableFunction₂.bcomp {k} {F : V → V → V} {f₁ f₂ : (Fin k → V) → V} + (hF : ℌ.DefinableFunction₂ F) (hf₁ : DefinableBoundedFunction f₁) + (hf₂ : DefinableBoundedFunction f₂) : ℌ.DefinableFunction (fun v ↦ F (f₁ v) (f₂ v)) := + HierarchySymbol.DefinableFunction.bcomp (f := ![f₁, f₂]) hF + (by simp [Fin.forall_fin_iff_zero_and_forall_succ, *]) + +lemma HierarchySymbol.DefinableFunction₃.bcomp {k} {F : V → V → V → V} + {f₁ f₂ f₃ : (Fin k → V) → V} (hF : ℌ.DefinableFunction₃ F) + (hf₁ : DefinableBoundedFunction f₁) (hf₂ : DefinableBoundedFunction f₂) + (hf₃ : DefinableBoundedFunction f₃) : + ℌ.DefinableFunction (fun v ↦ F (f₁ v) (f₂ v) (f₃ v)) := + HierarchySymbol.DefinableFunction.bcomp (f := ![f₁, f₂, f₃]) hF + (by simp [Fin.forall_fin_iff_zero_and_forall_succ, *]) + +lemma DefinableBoundedFunction₁.comp {k} {F : V → V} {f : (Fin k → V) → V} + (hF : DefinableBoundedFunction₁ F) (hf : DefinableBoundedFunction f) : + DefinableBoundedFunction (fun v ↦ F (f v)) := + ⟨hF.bounded.comp hf.bounded, hF.definable.bcomp hf⟩ + +lemma DefinableBoundedFunction₂.comp {k} {F : V → V → V} {f₁ f₂ : (Fin k → V) → V} + (hF : DefinableBoundedFunction₂ F) (hf₁ : DefinableBoundedFunction f₁) + (hf₂ : DefinableBoundedFunction f₂) : DefinableBoundedFunction (fun v ↦ F (f₁ v) (f₂ v)) := + ⟨hF.bounded.comp hf₁.bounded hf₂.bounded, hF.definable.bcomp hf₁ hf₂⟩ + +lemma DefinableBoundedFunction₃.comp {k} {F : V → V → V → V} {f₁ f₂ f₃ : (Fin k → V) → V} + (hF : DefinableBoundedFunction₃ F) (hf₁ : DefinableBoundedFunction f₁) + (hf₂ : DefinableBoundedFunction f₂) (hf₃ : DefinableBoundedFunction f₃) : + DefinableBoundedFunction (fun v ↦ F (f₁ v) (f₂ v) (f₃ v)) := + ⟨hF.bounded.comp hf₁.bounded hf₂.bounded hf₃.bounded, hF.definable.bcomp hf₁ hf₂ hf₃⟩ + +lemma DefinableBoundedFunction.comp₁ {k} {F : V → V} {f : (Fin k → V) → V} [hFb : Bounded₁ F] + [hFd : Σ₀.DefinableFunction₁ F] (hf : DefinableBoundedFunction f) : + DefinableBoundedFunction (fun v ↦ F (f v)) := + DefinableBoundedFunction₁.comp ⟨hFb, hFd⟩ hf + +lemma DefinableBoundedFunction.comp₂ {k} {F : V → V → V} {f₁ f₂ : (Fin k → V) → V} + [hFb : Bounded₂ F] [hFd : Σ₀.DefinableFunction₂ F] (hf₁ : DefinableBoundedFunction f₁) + (hf₂ : DefinableBoundedFunction f₂) : DefinableBoundedFunction (fun v ↦ F (f₁ v) (f₂ v)) := + DefinableBoundedFunction₂.comp ⟨hFb, hFd⟩ hf₁ hf₂ + +lemma DefinableBoundedFunction.comp₃ {k} {F : V → V → V → V} {f₁ f₂ f₃ : (Fin k → V) → V} + [hFb : Bounded₃ F] [hFd : Σ₀.DefinableFunction₃ F] (hf₁ : DefinableBoundedFunction f₁) + (hf₂ : DefinableBoundedFunction f₂) (hf₃ : DefinableBoundedFunction f₃) : + DefinableBoundedFunction (fun v ↦ F (f₁ v) (f₂ v) (f₃ v)) := + DefinableBoundedFunction₃.comp ⟨hFb, hFd⟩ hf₁ hf₂ hf₃ + +section + +open HierarchySymbol + +attribute [aesop (rule_sets := [Definability]) norm] sq Arithmetic.pow_three pow_four + +attribute [aesop 5 (rule_sets := [Definability]) safe] DefinableBoundedFunction.comp₁ + DefinableBoundedFunction.comp₂ DefinableBoundedFunction.comp₃ + +attribute [aesop 6 (rule_sets := [Definability]) safe] Definable.bcomp₁_zero + Definable.bcomp₂_zero Definable.bcomp₃_zero Definable.bcomp₄_zero + +attribute [aesop 8 (rule_sets := [Definability]) safe] Definable.ball_blt_zero + Definable.ball_ble_zero Definable.bexs_blt_zero Definable.bexs_ble_zero + +end + +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Definability/Definable.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Definability/Definable.lean new file mode 100644 index 000000000..b66cae069 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Definability/Definable.lean @@ -0,0 +1,1144 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Definability.Hierarchy +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Tarski.Definability + +/-! Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section +namespace FFL +namespace FirstOrder +namespace Arithmetic + +namespace HierarchySymbol + +variable (ξ : Type*) (n : ℕ) + +open PeanoMinus + +variable {V : Type*} [ORingStructure V] + +/-- The Is Defined By construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +abbrev IsDefinedBy (R : (Fin k → V) → Prop) : {ℌ : HierarchySymbol} → ℌ.Semisentence k → Prop + | Σ-[_], φ => FirstOrder.IsDefinedBy R φ.val + | Π-[_], φ => FirstOrder.IsDefinedBy R φ.val + | ∆-[_], φ => φ.ProperOn V ∧ FirstOrder.IsDefinedBy R φ.val + +/-- The Is Defined By With Param construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +abbrev IsDefinedByWithParam (R : (Fin k → V) → Prop) : + {ℌ : HierarchySymbol} → ℌ.Semiformula V k → Prop + | Σ-[_], φ => FirstOrder.IsDefinedByWithParam R φ.val + | Π-[_], φ => FirstOrder.IsDefinedByWithParam R φ.val + | ∆-[_], φ => φ.ProperWithParamOn V ∧ FirstOrder.IsDefinedByWithParam R φ.val + +/-- Data and laws for Defined in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +class Defined (R : outParam ((Fin k → V) → Prop)) {ℌ : HierarchySymbol} + (φ : ℌ.Semisentence k) where + defined : IsDefinedBy R φ + +variable {ℌ : HierarchySymbol} {Γ : SigmaPiDelta} + +variable (ℌ) + +/-- Data and laws for Definable in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +class Definable {k} (P : (Fin k → V) → Prop) : Prop where + definable : ∃ φ : ℌ.Semiformula V k, IsDefinedByWithParam P φ + +/-- The Defined Pred construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +abbrev DefinedPred (P : V → Prop) (φ : ℌ.Semisentence 1) : Prop := + Defined (fun v ↦ P (v 0)) φ + +/-- The Defined Rel construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +abbrev DefinedRel (R : V → V → Prop) (φ : ℌ.Semisentence 2) : Prop := + Defined (fun v ↦ R (v 0) (v 1)) φ + +/-- The Defined Rel₃ construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +abbrev DefinedRel₃ (R : V → V → V → Prop) (φ : ℌ.Semisentence 3) : Prop := + Defined (fun v ↦ R (v 0) (v 1) (v 2)) φ + +/-- The Defined Rel₄ construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +abbrev DefinedRel₄ (R : V → V → V → V → Prop) (φ : ℌ.Semisentence 4) : Prop := + Defined (fun v ↦ R (v 0) (v 1) (v 2) (v 3)) φ + +variable {ℌ} + +/-- The Defined Function construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +abbrev DefinedFunction {k} (f : (Fin k → V) → V) (φ : ℌ.Semisentence (k + 1)) : Prop := + Defined (fun v ↦ v 0 = f (v ·.succ)) φ + +variable (ℌ) + +/-- The Defined Function₀ construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +abbrev DefinedFunction₀ (c : V) (φ : ℌ.Semisentence 1) : Prop := + DefinedFunction (fun _ => c) φ + +/-- The Defined Function₁ construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +abbrev DefinedFunction₁ (f : V → V) (φ : ℌ.Semisentence 2) : Prop := + DefinedFunction (fun v => f (v 0)) φ + +/-- The Defined Function₂ construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +abbrev DefinedFunction₂ (f : V → V → V) (φ : ℌ.Semisentence 3) : Prop := + DefinedFunction (fun v => f (v 0) (v 1)) φ + +/-- The Defined Function₃ construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +abbrev DefinedFunction₃ (f : V → V → V → V) (φ : ℌ.Semisentence 4) : Prop := + DefinedFunction (fun v => f (v 0) (v 1) (v 2)) φ + +/-- The Defined Function₄ construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +abbrev DefinedFunction₄ (f : V → V → V → V → V) (φ : ℌ.Semisentence 5) : Prop := + DefinedFunction (fun v => f (v 0) (v 1) (v 2) (v 3)) φ + +/-- The Defined Function₅ construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +abbrev DefinedFunction₅ (f : V → V → V → V → V → V) (φ : ℌ.Semisentence 6) : Prop := + DefinedFunction (fun v => f (v 0) (v 1) (v 2) (v 3) (v 4)) φ + +/-- The Definable Pred construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +abbrev DefinablePred (P : V → Prop) : Prop := + ℌ.Definable (k := 1) (fun v ↦ P (v 0)) + +/-- The Definable Rel construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +abbrev DefinableRel (P : V → V → Prop) : Prop := + ℌ.Definable (k := 2) (fun v ↦ P (v 0) (v 1)) + +/-- The Definable Rel₃ construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +abbrev DefinableRel₃ (P : V → V → V → Prop) : Prop := + ℌ.Definable (k := 3) (fun v ↦ P (v 0) (v 1) (v 2)) + +/-- The Definable Rel₄ construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +abbrev DefinableRel₄ (P : V → V → V → V → Prop) : Prop := + ℌ.Definable (k := 4) (fun v ↦ P (v 0) (v 1) (v 2) (v 3)) + +/-- The Definable Rel₅ construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +abbrev DefinableRel₅ (P : V → V → V → V → V → Prop) : Prop := + ℌ.Definable (k := 5) (fun v ↦ P (v 0) (v 1) (v 2) (v 3) (v 4)) + +/-- The Definable Rel₆ construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +abbrev DefinableRel₆ (P : V → V → V → V → V → V → Prop) : Prop := + ℌ.Definable (k := 6) (fun v ↦ P (v 0) (v 1) (v 2) (v 3) (v 4) (v 5)) + +/-- The Definable Function construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +abbrev DefinableFunction (f : (Fin k → V) → V) : Prop := + ℌ.Definable (k := k + 1) (fun v ↦ v 0 = f (v ·.succ)) + +/-- The Definable Function₀ construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +abbrev DefinableFunction₀ (c : V) : Prop := + ℌ.DefinableFunction (k := 0) (fun _ ↦ c) + +/-- The Definable Function₁ construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +abbrev DefinableFunction₁ (f : V → V) : Prop := + ℌ.DefinableFunction (k := 1) (fun v ↦ f (v 0)) + +/-- The Definable Function₂ construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +abbrev DefinableFunction₂ (f : V → V → V) : Prop := + ℌ.DefinableFunction (k := 2) (fun v ↦ f (v 0) (v 1)) + +/-- The Definable Function₃ construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +abbrev DefinableFunction₃ (f : V → V → V → V) : Prop := + ℌ.DefinableFunction (k := 3) (fun v ↦ f (v 0) (v 1) (v 2)) + +/-- The Definable Function₄ construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +abbrev DefinableFunction₄ (f : V → V → V → V → V) : Prop := + ℌ.DefinableFunction (k := 4) (fun v ↦ f (v 0) (v 1) (v 2) (v 3)) + +/-- The Definable Function₅ construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +abbrev DefinableFunction₅ (f : V → V → V → V → V → V) : Prop := + ℌ.DefinableFunction (k := 5) (fun v ↦ f (v 0) (v 1) (v 2) (v 3) (v 4)) + +variable {ℌ} + +/-- The «term -Predicate Via » construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +notation Γ "-Predicate " P " via " φ => DefinedPred Γ P φ + +/-- The «term -Relation Via » construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +notation Γ "-Relation " P " via " φ => DefinedRel Γ P φ + +/-- The «term -Relation₃ Via » construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +notation Γ "-Relation₃ " P " via " φ => DefinedRel₃ Γ P φ + +/-- The «term -Relation₄ Via » construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +notation Γ "-Relation₄ " P " via " φ => DefinedRel₄ Γ P φ + +/-- The «term -Function₀ Via » construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +notation Γ "-Function₀ " c " via " φ => DefinedFunction₀ Γ c φ + +/-- The «term -Function₁ Via » construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +notation Γ "-Function₁ " f " via " φ => DefinedFunction₁ Γ f φ + +/-- The «term -Function₂ Via » construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +notation Γ "-Function₂ " f " via " φ => DefinedFunction₂ Γ f φ + +/-- The «term -Function₃ Via » construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +notation Γ "-Function₃ " f " via " φ => DefinedFunction₃ Γ f φ + +/-- The «term -Function₄ Via » construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +notation Γ "-Function₄ " f " via " φ => DefinedFunction₄ Γ f φ + +/-- The «term -Function₅ Via » construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +notation Γ "-Function₅ " f " via " φ => DefinedFunction₅ Γ f φ + +/-- The «term -Predicate » construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +notation Γ "-Predicate " P => DefinablePred Γ P + +/-- The «term -Relation » construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +notation Γ "-Relation " P => DefinableRel Γ P + +/-- The «term -Relation₃ » construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +notation Γ "-Relation₃ " P => DefinableRel₃ Γ P + +/-- The «term -Relation₄ » construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +notation Γ "-Relation₄ " P => DefinableRel₄ Γ P + +/-- The «term -Relation₅ » construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +notation Γ "-Relation₅ " P => DefinableRel₅ Γ P + +/-- The «term -Function₁ » construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +notation Γ "-Function₁ " f => DefinableFunction₁ Γ f + +/-- The «term -Function₂ » construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +notation Γ "-Function₂ " f => DefinableFunction₂ Γ f + +/-- The «term -Function₃ » construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +notation Γ "-Function₃ " f => DefinableFunction₃ Γ f + +/-- The «term -Function₄ » construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +notation Γ "-Function₄ " f => DefinableFunction₄ Γ f + +/-- +The «term -Predicate[ ] Via » construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +notation Γ "-Predicate[" V "] " P " via " φ => DefinedPred (V := V) Γ P φ + +/-- The «term -Relation[ ] Via » construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +notation Γ "-Relation[" V "] " P " via " φ => DefinedRel (V := V) Γ P φ + +/-- +The «term -Relation₃[ ] Via » construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +notation Γ "-Relation₃[" V "] " P " via " φ => DefinedRel₃ (V := V) Γ P φ + +/-- +The «term -Relation₄[ ] Via » construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +notation Γ "-Relation₄[" V "] " P " via " φ => DefinedRel₄ (V := V) Γ P φ + +/-- +The «term -Function₀[ ] Via » construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +notation Γ "-Function₀[" V "] " c " via " φ => DefinedFunction₀ (V := V) Γ c φ + +/-- +The «term -Function₁[ ] Via » construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +notation Γ "-Function₁[" V "] " f " via " φ => DefinedFunction₁ (V := V) Γ f φ + +/-- +The «term -Function₂[ ] Via » construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +notation Γ "-Function₂[" V "] " f " via " φ => DefinedFunction₂ (V := V) Γ f φ + +/-- +The «term -Function₃[ ] Via » construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +notation Γ "-Function₃[" V "] " f " via " φ => DefinedFunction₃ (V := V) Γ f φ + +/-- +The «term -Function₄[ ] Via » construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +notation Γ "-Function₄[" V "] " f " via " φ => DefinedFunction₄ (V := V) Γ f φ + +/-- +The «term -Function₅[ ] Via » construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +notation Γ "-Function₅[" V "] " f " via " φ => DefinedFunction₅ (V := V) Γ f φ + +/-- The «term -Predicate[ ] » construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +notation Γ "-Predicate[" V "] " P => DefinablePred (V := V) Γ P + +/-- The «term -Relation[ ] » construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +notation Γ "-Relation[" V "] " P => DefinableRel (V := V) Γ P + +/-- The «term -Relation₃[ ] » construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +notation Γ "-Relation₃[" V "] " P => DefinableRel₃ (V := V) Γ P + +/-- The «term -Relation₄[ ] » construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +notation Γ "-Relation₄[" V "] " P => DefinableRel₄ (V := V) Γ P + +/-- The «term -Relation₅[ ] » construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +notation Γ "-Relation₅[" V "] " P => DefinableRel₅ (V := V) Γ P + +/-- The «term -Function₁[ ] » construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +notation Γ "-Function₁[" V "] " f => DefinableFunction₁ (V := V) Γ f + +/-- The «term -Function₂[ ] » construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +notation Γ "-Function₂[" V "] " f => DefinableFunction₂ (V := V) Γ f + +/-- The «term -Function₃[ ] » construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +notation Γ "-Function₃[" V "] " f => DefinableFunction₃ (V := V) Γ f + +/-- The «term -Function₄[ ] » construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +notation Γ "-Function₄[" V "] " f => DefinableFunction₄ (V := V) Γ f + +variable {k} {P Q : (Fin k → V) → Prop} + +namespace Defined + +lemma df {R : (Fin k → V) → Prop} {φ : ℌ.Semisentence k} (h : Defined R φ) : + FirstOrder.IsDefinedBy R φ.val := + match ℌ with + | Σ-[_] => h.defined + | Π-[_] => h.defined + | ∆-[_] => h.defined.2 + +@[simp] +lemma proper {R : (Fin k → V) → Prop} {m} {φ : ∆-[m].Semisentence k} [h : Defined R φ] : + φ.ProperOn V := + h.defined.1 + +@[simp] +lemma iff {R : (Fin k → V) → Prop} {φ : ℌ.Semisentence k} [h : Defined R φ] : + φ.val.Evalb v ↔ R v := + h.df _ + +@[simp] +lemma iff_delta_pi {R : (Fin k → V) → Prop} {φ : (∆-[m]).Semisentence k} [h : Defined R φ] : + φ.pi.val.Evalb v ↔ R v := by simp [h.proper.iff'] + +@[simp] +lemma iff_delta_sigma {R : (Fin k → V) → Prop} {φ : (∆-[m]).Semisentence k} [h : Defined R φ] : + φ.sigma.val.Evalb v ↔ R v := by simp [h.proper.iff] + +lemma of_zero {R : (Fin k → V) → Prop} {φ : Σ₀.Semisentence k} (h : Defined R φ) : + Defined R (φ.ofZero ℌ) := + Defined.mk <| + match ℌ with + | Σ-[m] => by intro _; simp + | Π-[m] => by intro _; simp + | ∆-[m] => ⟨by simp, by intro _; simp⟩ + +lemma of_iff {P Q : (Fin k → V) → Prop} (h : ∀ x, P x ↔ Q x) {φ : ℌ.Semisentence k} + (H : Defined Q φ) : Defined P φ := by rwa [show P = Q from by funext v; simp [h]] + +lemma to_definable (φ : ℌ.Semisentence k) (hP : Defined P φ) : ℌ.Definable P := ⟨φ.rew Rew.emb, by + match ℌ with + | Σ-[_] => intro; simp [hP.iff] + | Π-[_] => intro; simp [hP.iff] + | ∆-[_] => exact ⟨ + fun v ↦ by rcases φ; simpa [HierarchySymbol.Semiformula.rew] using hP.proper.rew Rew.emb v, + by intro; simp⟩⟩ + +lemma to_definable₀ {φ : Σ₀.Semisentence k} (hP : Defined P φ) : ℌ.Definable P := + Defined.to_definable (φ.ofZero ℌ) hP.of_zero + +end Defined + +namespace DefinedFunction + +lemma of_eq {f g : (Fin k → V) → V} (h : ∀ x, f x = g x) {φ : ℌ.Semisentence (k + 1)} + (H : DefinedFunction f φ) : DefinedFunction g φ := + Defined.of_iff (by intro; simp [h]) H + +lemma graph_delta {f : (Fin k → V) → V} {φ : Σ-[m].Semisentence (k + 1)} + (h : DefinedFunction f φ) : DefinedFunction f φ.graphDelta := + ⟨by + rcases m with _ | m + case zero => simp [HierarchySymbol.Semiformula.graphDelta] + case succ => + simp only [Semiformula.graphDelta] + intro e + simp; tauto, + by intro v; simp⟩ + +end DefinedFunction + +namespace IsDefinedByWithParam + +lemma df {R : (Fin k → V) → Prop} {φ : ℌ.Semiformula V k} (h : IsDefinedByWithParam R φ) : + FirstOrder.IsDefinedByWithParam R φ.val := + match ℌ with + | Σ-[_] => h + | Π-[_] => h + | ∆-[_] => h.2 + +lemma iff {R : (Fin k → V) → Prop} {φ : ℌ.Semiformula V k} (h : IsDefinedByWithParam R φ) {v} : + φ.val.Eval v id ↔ R v := + h.df _ + +lemma proper {R : (Fin k → V) → Prop} {m} {φ : ∆-[m].Semiformula V k} + (h : IsDefinedByWithParam R φ) : φ.ProperWithParamOn V := + h.1 + +end IsDefinedByWithParam + +namespace DefinableRel + +@[simp] instance eq : ℌ.DefinableRel (Eq : V → V → Prop) := + Defined.to_definable₀ (φ := .mkSigma “#0 = #1”) ⟨by intro _; simp⟩ + +@[simp] instance lt : ℌ.DefinableRel (LT.lt : V → V → Prop) := + Defined.to_definable₀ (φ := .mkSigma “#0 < #1”) ⟨by intro _; simp⟩ + +@[simp] instance le [V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] : ℌ.DefinableRel (LE.le : V → V → Prop) := + Defined.to_definable₀ (φ := .mkSigma “#0 ≤ #1”) ⟨by intro _; simp⟩ + +end DefinableRel + +namespace DefinableFunction₂ + +instance add : ℌ.DefinableFunction₂ ((· + ·) : V → V → V) := + Defined.to_definable₀ (φ := .mkSigma “#0 = #1 + #2”) ⟨by intro _; simp⟩ + +instance mul : ℌ.DefinableFunction₂ ((· * ·) : V → V → V) := + Defined.to_definable₀ (φ := .mkSigma “#0 = #1 * #2”) ⟨by intro _; simp⟩ + +instance hAdd : ℌ.DefinableFunction₂ (HAdd.hAdd : V → V → V) := + Defined.to_definable₀ (φ := .mkSigma “#0 = #1 + #2”) ⟨by intro _; simp⟩ + +instance hMul : ℌ.DefinableFunction₂ (HMul.hMul : V → V → V) := + Defined.to_definable₀ (φ := .mkSigma “#0 = #1 * #2”) ⟨by intro _; simp⟩ + +protected instance sq [V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] : ℌ.DefinableFunction₁ fun x : V ↦ x^2 := + Defined.to_definable₀ (φ := .mkSigma “#0 = #1 * #1”) ⟨by intro _; simp [sq]⟩ + +instance pow3 [V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] : ℌ.DefinableFunction₁ fun x : V ↦ x^3 := + Defined.to_definable₀ (φ := .mkSigma “#0 = #1 * #1 * #1”) ⟨by intro _; simp + [Arithmetic.pow_three]⟩ + + + +instance pow4 [V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] : ℌ.DefinableFunction₁ fun x : V ↦ x^4 := + Defined.to_definable₀ (φ := .mkSigma “#0 = #1 * #1 * #1 * #1”) ⟨by intro _; simp [pow_four]⟩ + +end DefinableFunction₂ + +namespace Definable + +lemma mk' {ℌ : HierarchySymbol} (φ : ℌ.Semiformula V k) (H : IsDefinedByWithParam P φ) : + ℌ.Definable P := + ⟨φ, H⟩ + +lemma mkPolarity {Γ : Polarity} (φ : ArithmeticSemiformula V k) (hp : Hierarchy Γ m φ) + (hP : ∀ v, P v ↔ φ.Eval v id) : Γ-[m].Definable P := + match Γ with + | Σ => ⟨.mkSigma φ hp, by intro v; simp [hP]⟩ + | Π => ⟨.mkPi φ hp, by intro v; simp [hP]⟩ + +lemma of_zero (h : Definable (Γ'-[0]) P) {ℌ : HierarchySymbol} : ℌ.Definable P := + by + rcases h with ⟨φ, hφ⟩ + apply Definable.mk' (φ.ofZero ℌ) + match ℌ with + | Σ-[m] | Π-[m] => intro _; simp [hφ.iff] + | ∆-[m] => + constructor + · simp + · intro _; simp [hφ.iff] + +instance [Σ₀.Definable P] (ℌ : HierarchySymbol) : ℌ.Definable P := + of_zero (Γ' := Σ) inferInstance + +lemma of_deltaOne {Γ m} (h : ∆₁.Definable P) : Γ-[m+1].Definable P := by + rcases h with ⟨φ, h⟩ + apply Definable.mk' (φ.ofDeltaOne Γ m) + match Γ with + | Σ => intro _; simp [HierarchySymbol.Semiformula.ofDeltaOne, h.iff, + HierarchySymbol.Semiformula.val_sigma] + | Π => intro _; simp [HierarchySymbol.Semiformula.ofDeltaOne, h.iff, h.proper.iff'] + | ∆ => exact ⟨by intro _; simp [HierarchySymbol.Semiformula.ofDeltaOne, h.iff, + HierarchySymbol.Semiformula.val_sigma, h.proper.iff'], + by intro _; simp [HierarchySymbol.Semiformula.ofDeltaOne, h.df.iff, + HierarchySymbol.Semiformula.val_sigma]⟩ + + + +lemma of_delta (h : ∆-[m].Definable P) : Γ-[m].Definable P := + by + rcases h with ⟨φ, h⟩ + match Γ with + | Σ => exact ⟨φ.sigma, by intro v; simp [HierarchySymbol.Semiformula.val_sigma, h.df.iff]⟩ + | Π => + exact + ⟨φ.pi, by intro v; simp [← h.proper v, HierarchySymbol.Semiformula.val_sigma, h.df.iff]⟩ + | ∆ => exact ⟨φ, h⟩ + +instance [∆-[m].Definable P] (Γ) : Γ-[m].Definable P := + of_delta inferInstance + +lemma delta_iff_sigma_and_pi : ∆-[m].Definable P ↔ Π-[m].Definable P ∧ Σ-[m].Definable P := + by + constructor + · intro h + exact ⟨of_delta (Γ := Π) h, of_delta (Γ := Σ) h⟩ + · rintro ⟨hπ, hσ⟩ + rcases hσ with ⟨φ, hφ⟩ + rcases hπ with ⟨ψ, hψ⟩ + exact ⟨.mkDelta φ ψ, by intro v; simp [hφ.df.iff, hψ.df.iff], by intro v; simp [hφ.df.iff]⟩ + +lemma of_sigma_of_pi (hσ : Σ-[m].Definable P) (hπ : Π-[m].Definable P) : Γ-[m].Definable P := + match Γ with + | Σ => hσ + | Π => hπ + | ∆ => by + rcases hσ with ⟨φ, hp⟩; rcases hπ with ⟨ψ, hq⟩ + exact ⟨.mkDelta φ ψ, by intro v; simp [hp.df.iff, hq.df.iff], by intro v; simp [hp.df.iff]⟩ + +lemma of_iff (H : ℌ.Definable Q) (h : ∀ x, P x ↔ Q x) : ℌ.Definable P := by + rwa [show P = Q from by funext v; simp [h]] + +lemma retraction (h : ℌ.Definable P) (f : Fin k → Fin l) : + ℌ.Definable fun v ↦ P fun i ↦ v (f i) := + by + rcases h with ⟨φ, h⟩ + apply Definable.mk' (φ.rew <| Rew.subst fun x ↦ #(f x)) + match ℌ with + | Σ-[_] | Π-[_] => intro; simp [h.iff, Function.comp_def] + | ∆-[_] => exact ⟨h.proper.rew _, by intro; simp [h.iff, Function.comp_def]⟩ + +lemma retractiont (h : ℌ.Definable P) (f : Fin k → ArithmeticSemiterm V n) : + ℌ.Definable fun v ↦ P (fun i ↦ (f i).val v id) := + by + rcases h with ⟨φ, h⟩ + exact + ⟨φ.rew (Rew.subst f), + match ℌ with + | Σ-[_] | Π-[_] => by intro; simp [h.df.iff, Function.comp_def] + | ∆-[_] => ⟨h.proper.rew _, by intro; simp [h.df.iff, Function.comp_def]⟩⟩ + +@[simp] +instance const {P : Prop} : ℌ.Definable (fun _ : Fin k → V ↦ P) := + by + by_cases hP : P + · apply Definable.mk' ⊤ + match ℌ with + | Σ-[m] | Π-[m] => intro v; simp [hP] + | ∆-[m] => exact ⟨by simp, by intro v; simp [hP]⟩ + · apply Definable.mk' ⊥ + match ℌ with + | Σ-[m] | Π-[m] => intro v; simp [hP] + | ∆-[m] => exact ⟨by simp, by intro v; simp [hP]⟩ + +lemma and (hP : ℌ.Definable P) (hQ : ℌ.Definable Q) : ℌ.Definable fun x ↦ P x ∧ Q x := + by + rcases hP with ⟨φ, hP⟩ + rcases hQ with ⟨ψ, hQ⟩ + apply Definable.mk' (φ ⋏ ψ) + match ℌ with + | Σ-[m] | Π-[m] => intro v; simp [hP.iff, hQ.iff] + | ∆-[m] => exact ⟨hP.proper.and hQ.proper, by intro v; simp [hP.iff, hQ.iff]⟩ + +lemma or (hP : ℌ.Definable P) (hQ : ℌ.Definable Q) : ℌ.Definable fun x ↦ P x ∨ Q x := + by + rcases hP with ⟨φ, hP⟩ + rcases hQ with ⟨ψ, hQ⟩ + apply Definable.mk' (φ ⋎ ψ) + match ℌ with + | Σ-[m] | Π-[m] => intro v; simp [hP.iff, hQ.iff] + | ∆-[m] => exact ⟨hP.proper.or hQ.proper, by intro v; simp [hP.iff, hQ.iff]⟩ + +lemma notSigma (h : Σ-[m].Definable P) : Π-[m].Definable fun x ↦ ¬P x := by + rcases h with ⟨φ, h⟩; exact Definable.mk' φ.negSigma fun v ↦ by simp [h.iff] + +lemma notPi (h : Π-[m].Definable P) : Σ-[m].Definable fun x ↦ ¬P x := + by + rcases h with ⟨φ, h⟩ + exact Definable.mk' φ.negPi fun v ↦ by simp [h.iff] + +lemma notDelta (h : ∆-[m].Definable P) : ∆-[m].Definable fun x ↦ ¬P x := + by + rcases h with ⟨φ, h⟩ + exact Definable.mk' (∼φ) ⟨h.proper.neg, by intro v; simp [h.proper.eval_neg, h.iff]⟩ + +lemma not (h : Γ.alt-[m].Definable P) : Γ-[m].Definable (fun v ↦ ¬P v) := + match Γ with + | Σ => h.notPi + | Π => h.notSigma + | ∆ => h.notDelta + +lemma impDelta (hp : ∆-[m].Definable P) (hq : ∆-[m].Definable Q) : + ∆-[m].Definable fun x ↦ P x → Q x := + (hp.notDelta.or hq).of_iff (by intro x; simp [imp_iff_not_or]) + +lemma imp (h₁ : Γ.alt-[m].Definable P) (h₂ : Γ-[m].Definable Q) : + Γ-[m].Definable (fun v ↦ P v → Q v) := + (h₁.not.or h₂).of_iff (by intro v; simp [imp_iff_not_or]) + +lemma biconditional (h₁ : ∆-[m].Definable P) (h₂ : ∆-[m].Definable Q) {Γ} : + Γ-[m].Definable (fun v ↦ P v ↔ Q v) := + .of_delta <| ((h₁.impDelta h₂).and (h₂.impDelta h₁)).of_iff <| by intro v; simp + [iff_iff_implies_and_implies] + + + +lemma ball {P : (Fin k → V) → V → Prop} (h : ℌ.Definable fun w ↦ P (w ·.succ) (w 0)) + (t : ArithmeticSemiterm V k) : ℌ.Definable fun v ↦ ∀ x < t.val v id, P v x := + by + rcases h with ⟨φ, h⟩ + match ℌ with + | Σ-[m] => exact ⟨HierarchySymbol.Semiformula.ball t φ, by intro v; simp [h.iff]⟩ + | Π-[m] => exact ⟨HierarchySymbol.Semiformula.ball t φ, by intro v; simp [h.iff]⟩ + | ∆-[m] => + exact ⟨HierarchySymbol.Semiformula.ball t φ, ⟨h.proper.ball, by intro v; simp [h.iff]⟩⟩ + +lemma bexs {P : (Fin k → V) → V → Prop} (h : ℌ.Definable fun w ↦ P (w ·.succ) (w 0)) + (t : ArithmeticSemiterm V k) : ℌ.Definable fun v ↦ ∃ x < t.val v id, P v x := + by + rcases h with ⟨φ, h⟩ + match ℌ with + | Σ-[m] => exact ⟨HierarchySymbol.Semiformula.bexs t φ, by intro v; simp [h.iff]⟩ + | Π-[m] => exact ⟨HierarchySymbol.Semiformula.bexs t φ, by intro v; simp [h.iff]⟩ + | ∆-[m] => + exact ⟨HierarchySymbol.Semiformula.bexs t φ, ⟨h.proper.bexs, by intro v; simp [h.iff]⟩⟩ + +lemma ball' [V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {P : (Fin k → V) → V → Prop} (h : ℌ.Definable fun w ↦ P (w ·.succ) + (w 0)) (t : ArithmeticSemiterm V k) : + ℌ.Definable fun v ↦ ∀ x ≤ t.val v id, P v x := by + apply (ball h ‘!!t + 1’).of_iff + intro v; simp [lt_succ_iff_le] + + + +lemma bexs' [V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {P : (Fin k → V) → V → Prop} (h : ℌ.Definable fun w ↦ P (w ·.succ) + (w 0)) (t : ArithmeticSemiterm V k) : + ℌ.Definable fun v ↦ ∃ x ≤ t.val v id, P v x := by + apply (bexs h ‘!!t + 1’).of_iff + intro v; simp [lt_succ_iff_le] + + + +lemma exs {P : (Fin k → V) → V → Prop} (h : Σ-[m + 1].Definable fun w ↦ P (w ·.succ) (w 0)) : + Σ-[m + 1].Definable fun v ↦ ∃ x, P v x := by + rcases h with ⟨φ, h⟩; exact ⟨φ.exs, by intro _; simp [h.iff]⟩ + +lemma all {P : (Fin k → V) → V → Prop} (h : Π-[m + 1].Definable fun w ↦ P (w ·.succ) (w 0)) : + Π-[m + 1].Definable fun v ↦ ∀ x, P v x := by + rcases h with ⟨φ, h⟩; exact ⟨φ.all, by intro _; simp [h.iff]⟩ + +lemma conj₂ (Γ : List ι) {R : ι → (Fin k → V) → Prop} (hR : ∀ i, ℌ.Definable (R i)) : + ℌ.Definable fun x ↦ ∀ i ∈ Γ, R i x := + match Γ with + | [] => by simp + | [i] => by simpa using hR i + | i :: j :: Γ => by simpa using (hR i).and (conj₂ (j :: Γ) hR) + +lemma disj₂ (Γ : List ι) {R : ι → (Fin k → V) → Prop} (hR : ∀ i, ℌ.Definable (R i)) : + ℌ.Definable fun x ↦ ∃ i ∈ Γ, R i x := + match Γ with + | [] => by simp + | [i] => by simpa using hR i + | i :: j :: Γ => by simpa using (hR i).or (disj₂ (j :: Γ) hR) + +open _root_.Classical Classical in +lemma fconj (s : Finset ι) {R : ι → (Fin k → V) → Prop} (h : ∀ i, ℌ.Definable (R i)) : + ℌ.Definable fun x ↦ ∀ i ∈ s, R i x := by simpa using conj₂ s.toList h + +open _root_.Classical Classical in +lemma fdisj (s : Finset ι) {R : ι → (Fin k → V) → Prop} (h : ∀ i, ℌ.Definable (R i)) : + ℌ.Definable fun x ↦ ∃ i ∈ s, R i x := by simpa using disj₂ s.toList h + +lemma fintype_all {ι : Type*} [_root_.Finite ι] {P : ι → (Fin k → V) → Prop} + (h : ∀ i, ℌ.Definable fun w : Fin k → V ↦ P i w) : + ℌ.Definable fun v : Fin k → V ↦ ∀ i, P i v := by + classical + let : Fintype ι := Fintype.ofFinite ι + simpa using fconj Finset.univ h + +lemma fintype_exs {ι : Type*} [_root_.Finite ι] {P : ι → (Fin k → V) → Prop} + (h : ∀ i, ℌ.Definable fun w : Fin k → V ↦ P i w) : + ℌ.Definable fun v : Fin k → V ↦ ∃ i, P i v := by + classical + let : Fintype ι := Fintype.ofFinite ι + simpa using fdisj Finset.univ h + +lemma equal' (i j : Fin k) : ℌ.Definable fun v : Fin k → V ↦ v i = v j := by + simpa using retraction DefinableRel.eq ![i, j] + +lemma of_sigma {f : (Fin k → V) → V} (h : Σ-[m].DefinableFunction f) {Γ} : + Γ-[m].DefinableFunction f := by + rcases m with _ | m + · exact of_zero h + apply of_sigma_of_pi + · exact h + · have : Π-[m + 1].Definable fun v ↦ ∀ y, y = f (v ·.succ) → v 0 = y := + all <| imp (by simpa using retraction h (0 :> (·.succ.succ))) (by simpa using equal' 1 0) + exact this.of_iff fun v ↦ by simp + +lemma exsVec {k l} {P : (Fin k → V) → (Fin l → V) → Prop} + (h : + Σ-[m + 1].Definable fun w : Fin (k + l) → V ↦ + P (fun i ↦ w (i.castAdd l)) (fun j ↦ w (j.natAdd k))) : + Σ-[m + 1].Definable fun v : Fin k → V ↦ ∃ ys : Fin l → V, P v ys := + by + induction l generalizing k + case zero => simpa [Matrix.empty_eq] using h + case succ l + ih => + suffices Σ-[m + 1].Definable fun v : Fin k → V ↦ ∃ y, ∃ ys : Fin l → V, P v (y :> ys) + by + apply of_iff this; intro x + constructor + · rintro ⟨ys, h⟩; exact ⟨ys 0, (ys ·.succ), by simpa using h⟩ + · rintro ⟨y, ys, h⟩; exact ⟨_, h⟩ + apply exs + apply ih + let g : Fin (k + (l + 1)) → Fin (k + 1 + l) := + Matrix.vecAppend rfl (fun x ↦ x.succ.castAdd l) + (Fin.castAdd l 0 :> fun j ↦ j.natAdd (k + 1)) + exact + of_iff (retraction h g) + (by + intro v; simp only [g] + apply iff_of_eq; congr + · ext i; congr 1; ext; simp [Matrix.vecAppend_eq_ite] + · ext i + refine Fin.cases ?_ (fun i => ?_) i + · simp only [Matrix.cons_val_zero]; congr 1; ext; simp [Matrix.vecAppend_eq_ite] + · simp only [Matrix.cons_val_succ]; congr 1; ext; simp [Matrix.vecAppend_eq_ite]) + +lemma allVec {k l} {P : (Fin k → V) → (Fin l → V) → Prop} + (h : + Π-[m + 1].Definable fun w : Fin (k + l) → V ↦ + P (fun i ↦ w (i.castAdd l)) (fun j ↦ w (j.natAdd k))) : + Π-[m + 1].Definable fun v : Fin k → V ↦ ∀ ys : Fin l → V, P v ys := + by + induction l generalizing k + case zero => simpa [Matrix.empty_eq] using h + case succ l + ih => + suffices Π-[m + 1].Definable fun v : Fin k → V ↦ ∀ y, ∀ ys : Fin l → V, P v (y :> ys) + by + apply of_iff this; intro x + constructor + · intro h y ys; apply h + · intro h ys; simpa using h (ys 0) (ys ·.succ) + apply all; apply ih + let g : Fin (k + (l + 1)) → Fin (k + 1 + l) := + Matrix.vecAppend rfl (fun x ↦ x.succ.castAdd l) + (Fin.castAdd l 0 :> fun j ↦ j.natAdd (k + 1)) + exact + of_iff (retraction h g) + (by + intro v; simp only [g] + apply iff_of_eq; congr + · ext i; congr 1; ext; simp [Matrix.vecAppend_eq_ite] + · ext i + refine Fin.cases ?_ (fun i => ?_) i + · simp only [Matrix.cons_val_zero]; congr 1; ext; simp [Matrix.vecAppend_eq_ite] + · simp only [Matrix.cons_val_succ]; congr 1; ext; simp [Matrix.vecAppend_eq_ite]) + +private lemma substitution_sigma {f : Fin k → (Fin l → V) → V} (hP : Σ-[m + 1].Definable P) + (hf : ∀ i, Σ-[m + 1].DefinableFunction (f i)) : + Σ-[m + 1].Definable fun z ↦ P (fun i ↦ f i z) := + by + have : Σ-[m + 1].Definable fun z ↦ ∃ ys : Fin k → V, (∀ i, ys i = f i z) ∧ P ys := + by + apply exsVec; apply and + · apply fintype_all; intro i + simpa using retraction (of_sigma (hf i)) (i.natAdd l :> fun i ↦ i.castAdd k) + · exact retraction hP (Fin.natAdd l) + exact + of_iff this <| by + intro v + constructor + · intro hP + exact ⟨(f · v), by simp, hP⟩ + · rintro ⟨ys, hys, hP⟩ + have : ys = fun i ↦ f i v := funext hys + rcases this; exact hP + +private lemma substitution_pi {f : Fin k → (Fin l → V) → V} (hP : Π-[m + 1].Definable P) + (hf : ∀ i, Σ-[m + 1].DefinableFunction (f i)) : + Π-[m + 1].Definable fun z ↦ P (fun i ↦ f i z) := + by + have : Π-[m + 1].Definable fun z ↦ ∀ ys : Fin k → V, (∀ i, ys i = f i z) → P ys := + by + apply allVec; apply imp + · apply fintype_all; intro i + simpa using retraction (of_sigma (hf i)) (i.natAdd l :> fun i ↦ i.castAdd k) + · exact retraction hP (Fin.natAdd l) + exact + of_iff this <| by + intro v + constructor + · intro h ys e + have : ys = (f · v) := funext e + rcases this; exact h + · intro h; apply h _ (by simp) + +lemma substitution {f : Fin k → (Fin l → V) → V} (hP : Γ-[m + 1].Definable P) + (hf : ∀ i, Σ-[m + 1].DefinableFunction (f i)) : + Γ-[m + 1].Definable fun z ↦ P (fun i ↦ f i z) := + match Γ with + | Σ => substitution_sigma hP hf + | Π => substitution_pi hP hf + | ∆ => of_sigma_of_pi (substitution_sigma (of_delta hP) hf) (substitution_pi (of_delta hP) hf) + +end Definable + +lemma DefinablePred.comp {P : V → Prop} {k} {f : (Fin k → V) → V} + (hP : Γ-[m + 1].DefinablePred P) (hf : Σ-[m + 1].DefinableFunction f) : + Γ-[m + 1].Definable (fun v ↦ P (f v)) := + Definable.substitution (f := ![f]) hP (by simpa using hf) + +lemma DefinableRel.comp {P : V → V → Prop} {k} {f g : (Fin k → V) → V} + (hP : Γ-[m + 1].DefinableRel P) (hf : Σ-[m + 1].DefinableFunction f) + (hg : Σ-[m + 1].DefinableFunction g) : Γ-[m + 1].Definable fun v ↦ P (f v) (g v) := + Definable.substitution (f := ![f, g]) hP + (by simp [Fin.forall_fin_iff_zero_and_forall_succ, hf, hg]) + +lemma DefinableRel₃.comp {k} {P : V → V → V → Prop} {f₁ f₂ f₃ : (Fin k → V) → V} + (hP : Γ-[m + 1].DefinableRel₃ P) (hf₁ : Σ-[m + 1].DefinableFunction f₁) + (hf₂ : Σ-[m + 1].DefinableFunction f₂) (hf₃ : Σ-[m + 1].DefinableFunction f₃) : + Γ-[m + 1].Definable (fun v ↦ P (f₁ v) (f₂ v) (f₃ v)) := + Definable.substitution (f := ![f₁, f₂, f₃]) hP + (by simp [Fin.forall_fin_iff_zero_and_forall_succ, hf₁, hf₂, hf₃]) + +lemma DefinableRel₄.comp {k} {P : V → V → V → V → Prop} {f₁ f₂ f₃ f₄ : (Fin k → V) → V} + (hP : Γ-[m + 1].DefinableRel₄ P) (hf₁ : Σ-[m + 1].DefinableFunction f₁) + (hf₂ : Σ-[m + 1].DefinableFunction f₂) (hf₃ : Σ-[m + 1].DefinableFunction f₃) + (hf₄ : Σ-[m + 1].DefinableFunction f₄) : + Γ-[m + 1].Definable (fun v ↦ P (f₁ v) (f₂ v) (f₃ v) (f₄ v)) := + Definable.substitution (f := ![f₁, f₂, f₃, f₄]) hP + (by simp [Fin.forall_fin_iff_zero_and_forall_succ, hf₁, hf₂, hf₃, hf₄]) + +lemma DefinableRel₅.comp {k} {P : V → V → V → V → V → Prop} {f₁ f₂ f₃ f₄ f₅ : (Fin k → V) → V} + (hP : Γ-[m + 1].DefinableRel₅ P) (hf₁ : Σ-[m + 1].DefinableFunction f₁) + (hf₂ : Σ-[m + 1].DefinableFunction f₂) (hf₃ : Σ-[m + 1].DefinableFunction f₃) + (hf₄ : Σ-[m + 1].DefinableFunction f₄) (hf₅ : Σ-[m + 1].DefinableFunction f₅) : + Γ-[m + 1].Definable (fun v ↦ P (f₁ v) (f₂ v) (f₃ v) (f₄ v) (f₅ v)) := + Definable.substitution (f := ![f₁, f₂, f₃, f₄, f₅]) hP + (by simp [Fin.forall_fin_iff_zero_and_forall_succ, hf₁, hf₂, hf₃, hf₄, hf₅]) + +namespace Definable + +lemma comp₁ {k} {P : V → Prop} {f : (Fin k → V) → V} [Γ-[m + 1].DefinablePred P] + (hf : Σ-[m + 1].DefinableFunction f) : Γ-[m + 1].Definable fun v ↦ P (f v) := + DefinablePred.comp inferInstance hf + +lemma comp₂ {k} {P : V → V → Prop} {f g : (Fin k → V) → V} [Γ-[m + 1].DefinableRel P] + (hf : Σ-[m + 1].DefinableFunction f) (hg : Σ-[m + 1].DefinableFunction g) : + Γ-[m + 1].Definable (fun v ↦ P (f v) (g v)) := + DefinableRel.comp inferInstance hf hg + +lemma comp₃ {k} {P : V → V → V → Prop} {f₁ f₂ f₃ : (Fin k → V) → V} [Γ-[m + 1].DefinableRel₃ P] + (hf₁ : Σ-[m + 1].DefinableFunction f₁) (hf₂ : Σ-[m + 1].DefinableFunction f₂) + (hf₃ : Σ-[m + 1].DefinableFunction f₃) : + Γ-[m + 1].Definable (fun v ↦ P (f₁ v) (f₂ v) (f₃ v)) := + DefinableRel₃.comp inferInstance hf₁ hf₂ hf₃ + +lemma comp₄ {k} {P : V → V → V → V → Prop} {f₁ f₂ f₃ f₄ : (Fin k → V) → V} + [Γ-[m + 1].DefinableRel₄ P] (hf₁ : Σ-[m + 1].DefinableFunction f₁) + (hf₂ : Σ-[m + 1].DefinableFunction f₂) (hf₃ : Σ-[m + 1].DefinableFunction f₃) + (hf₄ : Σ-[m + 1].DefinableFunction f₄) : + Γ-[m + 1].Definable (fun v ↦ P (f₁ v) (f₂ v) (f₃ v) (f₄ v)) := + DefinableRel₄.comp inferInstance hf₁ hf₂ hf₃ hf₄ + +lemma comp₅ {k} {P : V → V → V → V → V → Prop} {f₁ f₂ f₃ f₄ f₅ : (Fin k → V) → V} + [Γ-[m + 1].DefinableRel₅ P] (hf₁ : Σ-[m + 1].DefinableFunction f₁) + (hf₂ : Σ-[m + 1].DefinableFunction f₂) (hf₃ : Σ-[m + 1].DefinableFunction f₃) + (hf₄ : Σ-[m + 1].DefinableFunction f₄) (hf₅ : Σ-[m + 1].DefinableFunction f₅) : + Γ-[m + 1].Definable (fun v ↦ P (f₁ v) (f₂ v) (f₃ v) (f₄ v) (f₅ v)) := + DefinableRel₅.comp inferInstance hf₁ hf₂ hf₃ hf₄ hf₅ + +end Definable + +section + +variable {ℌ : HierarchySymbol} + +lemma DefinablePred.of_iff {P Q : V → Prop} (H : ℌ.DefinablePred Q) (h : ∀ x, P x ↔ Q x) : + ℌ.DefinablePred P := by rwa [show P = Q from by funext v; simp [h]] + +lemma DefinableFunction.graph {f : (Fin k → V) → V} (h : ℌ.DefinableFunction f) : + ℌ.Definable fun v ↦ v 0 = f (v ·.succ) := + h + +instance DefinableFunction₁.graph {f : V → V} [h : ℌ.DefinableFunction₁ f] : + ℌ.DefinableRel (Function.Graph f) := + h + +instance DefinableFunction₂.graph {f : V → V → V} [h : ℌ.DefinableFunction₂ f] : + ℌ.DefinableRel₃ (Function.Graph₂ f) := + h + +instance DefinableFunction₃.graph {f : V → V → V → V} [h : ℌ.DefinableFunction₃ f] : + ℌ.DefinableRel₄ (Function.Graph₃ f) := + h + +end + +namespace DefinableFunction + +variable {ℌ : HierarchySymbol} {f : (Fin k → V) → V} + +lemma graph_delta (h : Σ-[m].DefinableFunction f) : ∆-[m].DefinableFunction f := + by + rcases h with ⟨φ, h⟩ + exact + ⟨φ.graphDelta, by + rcases m with _ | m + case zero => simp [HierarchySymbol.Semiformula.graphDelta] + case succ => + simp only [Semiformula.graphDelta] + intro e; simp [h.df.iff]; tauto, + by intro v; simp [h.df.iff]⟩ + +instance [h : Σ-[m].DefinableFunction f] : ∆-[m].DefinableFunction f := + DefinableFunction.graph_delta h + +instance [Σ₀.DefinableFunction f] : ℌ.DefinableFunction f := + inferInstance + +lemma of_sigmaOne (h : Σ₁.DefinableFunction f) {Γ m} : Γ-[m + 1].DefinableFunction f := + Definable.of_deltaOne (graph_delta h) + +@[simp] lemma var {k} (i : Fin k) : ℌ.DefinableFunction (fun v : Fin k → V ↦ v i) := + .of_zero (Γ' := Σ) ⟨.mkSigma “x. x = !!#i.succ”, by intro _; simp⟩ + +@[simp] lemma const {k} (c : V) : ℌ.DefinableFunction (fun _ : Fin k → V ↦ c) := + .of_zero (Γ' := Σ) ⟨.mkSigma “x. #0 = &c”, by intro v; simp⟩ + +@[simp] lemma term_retraction (t : ArithmeticSemiterm V n) (e : Fin n → Fin k) : + ℌ.DefinableFunction fun v : Fin k → V ↦ t.val (fun x ↦ v (e x)) id := + .of_zero (Γ' := Σ) + ⟨.mkSigma “x. x = !!(Rew.subst (fun x ↦ #(e x).succ) t)”, fun v ↦ by + simp [Semiterm.val_substs, Function.comp_def]⟩ + +lemma term (t : ArithmeticSemiterm V k) : + ℌ.DefinableFunction fun v : Fin k → V ↦ t.val v id := + .of_zero (Γ' := Σ) ⟨.mkSigma “x. x = !!(Rew.bShift t)”, fun v ↦ by simp [Semiterm.val_bShift']⟩ + +lemma of_eq (g) (h : ∀ v, f v = g v) (H : ℌ.DefinableFunction f) : ℌ.DefinableFunction g := by + rwa [show g = f from by funext v; simp [h]] + +lemma retraction {n} (hf : ℌ.DefinableFunction f) (e : Fin k → Fin n) : + ℌ.DefinableFunction fun v ↦ f (fun i ↦ v (e i)) := + have : ℌ.Definable fun v ↦ v 0 = f fun x ↦ v (e x).succ := + Definable.retraction hf (0 :> fun i ↦ (e i).succ) + this.of_iff (by intro x; simp) + +lemma retractiont {n} (hf : ℌ.DefinableFunction f) (t : Fin k → ArithmeticSemiterm V n) : + ℌ.DefinableFunction fun v ↦ f (fun i ↦ (t i).val v id) := + have := Definable.retractiont (n := n + 1) hf (#0 :> fun i ↦ Rew.bShift (t i)) + this.of_iff (by intro x; simp [Semiterm.val_bShift']) + +lemma rel (h : ℌ.DefinableFunction f) : ℌ.Definable (fun v ↦ v 0 = f (v ·.succ)) := + h + +lemma nth (ℌ : HierarchySymbol) (i : Fin k) : ℌ.DefinableFunction fun w : Fin k → V ↦ w i := by + apply Definable.of_zero (Γ' := Σ) + exact ⟨.mkSigma “x. x = #i.succ”, by intro v; simp⟩ + +lemma substitution {f : Fin k → (Fin l → V) → V} (hF : Γ-[m + 1].DefinableFunction F) + (hf : ∀ i, Σ-[m + 1].DefinableFunction (f i)) : + Γ-[m + 1].DefinableFunction fun z ↦ F (fun i ↦ f i z) := by + simpa using + Definable.substitution (f := (· 0) :> fun i w ↦ f i (w ·.succ)) hF <| + by + intro i + refine Fin.cases ?_ (fun i => ?_) i + · simp + · simpa using Definable.retraction (hf i) (0 :> (·.succ.succ)) + +end DefinableFunction + +lemma DefinableFunction₁.comp {k} {F : V → V} {f : (Fin k → V) → V} + [hF : Γ-[m + 1].DefinableFunction₁ F] (hf : Σ-[m + 1].DefinableFunction f) : + Γ-[m + 1].DefinableFunction (fun v ↦ F (f v)) := + DefinableFunction.substitution (f := ![f]) hF (by simp [hf]) + +lemma DefinableFunction₂.comp {k} {F : V → V → V} {f₁ f₂ : (Fin k → V) → V} + [hF : Γ-[m + 1].DefinableFunction₂ F] (hf₁ : Σ-[m + 1].DefinableFunction f₁) + (hf₂ : Σ-[m + 1].DefinableFunction f₂) : + Γ-[m + 1].DefinableFunction (fun v ↦ F (f₁ v) (f₂ v)) := + DefinableFunction.substitution (f := ![f₁, f₂]) hF + (by simp [Fin.forall_fin_iff_zero_and_forall_succ, *]) + +lemma DefinableFunction₃.comp {k} {F : V → V → V → V} {f₁ f₂ f₃ : (Fin k → V) → V} + [hF : Γ-[m + 1].DefinableFunction₃ F] (hf₁ : Σ-[m + 1].DefinableFunction f₁) + (hf₂ : Σ-[m + 1].DefinableFunction f₂) (hf₃ : Σ-[m + 1].DefinableFunction f₃) : + Γ-[m + 1].DefinableFunction (fun v ↦ F (f₁ v) (f₂ v) (f₃ v)) := + DefinableFunction.substitution (f := ![f₁, f₂, f₃]) hF + (by simp [Fin.forall_fin_iff_zero_and_forall_succ, *]) + +lemma DefinableFunction₄.comp {k} {F : V → V → V → V → V} {f₁ f₂ f₃ f₄ : (Fin k → V) → V} + [hF : Γ-[m + 1].DefinableFunction₄ F] (hf₁ : Σ-[m + 1].DefinableFunction f₁) + (hf₂ : Σ-[m + 1].DefinableFunction f₂) (hf₃ : Σ-[m + 1].DefinableFunction f₃) + (hf₄ : Σ-[m + 1].DefinableFunction f₄) : + Γ-[m + 1].DefinableFunction (fun v ↦ F (f₁ v) (f₂ v) (f₃ v) (f₄ v)) := + DefinableFunction.substitution (f := ![f₁, f₂, f₃, f₄]) hF + (by simp [Fin.forall_fin_iff_zero_and_forall_succ, *]) + +lemma DefinableFunction₅.comp {k} {F : V → V → V → V → V → V} {f₁ f₂ f₃ f₄ f₅ : (Fin k → V) → V} + [hF : Γ-[m + 1].DefinableFunction₅ F] (hf₁ : Σ-[m + 1].DefinableFunction f₁) + (hf₂ : Σ-[m + 1].DefinableFunction f₂) (hf₃ : Σ-[m + 1].DefinableFunction f₃) + (hf₄ : Σ-[m + 1].DefinableFunction f₄) (hf₅ : Σ-[m + 1].DefinableFunction f₅) : + Γ-[m + 1].DefinableFunction (fun v ↦ F (f₁ v) (f₂ v) (f₃ v) (f₄ v) (f₅ v)) := + DefinableFunction.substitution (f := ![f₁, f₂, f₃, f₄, f₅]) hF + (by simp [Fin.forall_fin_iff_zero_and_forall_succ, *]) + +namespace Definable + +lemma ball_lt {Γ} {P : (Fin k → V) → V → Prop} {f : (Fin k → V) → V} + (hf : Σ-[m + 1].DefinableFunction f) + (h : Γ-[m + 1].Definable (fun w ↦ P (w ·.succ) (w 0))) : + Γ-[m + 1].Definable (fun v ↦ ∀ x < f v, P v x) := + by + rcases hf with ⟨bf, hbf⟩ + rcases h with ⟨φ, hp⟩ + match Γ with + | Σ => + exact + ⟨.mkSigma (∃¹ (bf.val ⋏ (∀¹[“#0 < #1”] φ.val ↜ (#0 :> (#·.succ.succ))))) (by simp), by + intro v; simp [hbf.df.iff, hp.df.iff]⟩ + | Π => + exact + ⟨.mkPi (∀¹ (bf.val ⇒ₗ (∀¹[“#0 < #1”] φ.val ↜ (#0 :> (#·.succ.succ))))) (by simp), by + intro v; simp [hbf.df.iff, hp.df.iff]⟩ + | ∆ => + exact + .of_sigma_of_pi + ⟨.mkSigma (∃¹ (bf.val ⋏ (∀¹[“#0 < #1”] φ.sigma.val ↜ (#0 :> (#·.succ.succ))))) + (by simp), + by intro v; simp [hbf.df.iff, hp.df.iff, HierarchySymbol.Semiformula.val_sigma]⟩ + ⟨.mkPi (∀¹ (bf.val ⇒ₗ (∀¹[“#0 < #1”] φ.pi.val ↜ (#0 :> (#·.succ.succ))))) (by simp), by + intro v; simp [hbf.df.iff, hp.df.iff, hp.proper.iff']⟩ + +lemma bexs_lt {Γ} {P : (Fin k → V) → V → Prop} {f : (Fin k → V) → V} + (hf : Σ-[m + 1].DefinableFunction f) + (h : Γ-[m + 1].Definable (fun w ↦ P (w ·.succ) (w 0))) : + Γ-[m + 1].Definable (fun v ↦ ∃ x < f v, P v x) := + by + rcases hf with ⟨bf, hbf⟩ + rcases h with ⟨φ, hp⟩ + match Γ with + | Σ => + exact + ⟨.mkSigma (∃¹ (bf.val ⋏ (∃¹[“#0 < #1”] φ.val ↜ (#0 :> (#·.succ.succ))))) (by simp), by + intro v; simp [hbf.df.iff, hp.df.iff]⟩ + | Π => + exact + ⟨.mkPi (∀¹ (bf.val ⇒ₗ (∃¹[“#0 < #1”] φ.val ↜ (#0 :> (#·.succ.succ))))) (by simp), by + intro v; simp [hbf.df.iff, hp.df.iff]⟩ + | ∆ => + exact + .of_sigma_of_pi + ⟨.mkSigma (∃¹ (bf.val ⋏ (∃¹[“#0 < #1”] φ.sigma.val ↜ (#0 :> (#·.succ.succ))))) + (by simp), + by intro v; simp [hbf.df.iff, hp.df.iff, HierarchySymbol.Semiformula.val_sigma]⟩ + ⟨.mkPi (∀¹ (bf.val ⇒ₗ (∃¹[“#0 < #1”] φ.pi.val ↜ (#0 :> (#·.succ.succ))))) (by simp), by + intro v; simp [hbf.df.iff, hp.df.iff, hp.proper.iff']⟩ + +lemma ball_le [V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {Γ} {P : (Fin k → V) → V → Prop} {f : (Fin k → V) → V} + (hf : Σ-[m + 1].DefinableFunction f) + (h : Γ-[m + 1].Definable (fun w ↦ P (w ·.succ) (w 0))) : + Γ-[m + 1].Definable (fun v ↦ ∀ x ≤ f v, P v x) := + by + have : Γ-[m + 1].Definable (fun v ↦ ∀ x < f v + 1, P v x) := + ball_lt (DefinableFunction₂.comp hf (by simp)) h + exact this.of_iff <| by intro v; simp [lt_succ_iff_le] + +lemma bexs_le [V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {Γ} {P : (Fin k → V) → V → Prop} {f : (Fin k → V) → V} + (hf : Σ-[m + 1].DefinableFunction f) + (h : Γ-[m + 1].Definable (fun w ↦ P (w ·.succ) (w 0))) : + Γ-[m + 1].Definable (fun v ↦ ∃ x ≤ f v, P v x) := + by + have : Γ-[m + 1].Definable (fun v ↦ ∃ x < f v + 1, P v x) := + bexs_lt (DefinableFunction₂.comp hf (by simp)) h + exact this.of_iff <| by intro v; simp [lt_succ_iff_le] + +lemma ball_lt' {Γ} {P : (Fin k → V) → V → Prop} {f : (Fin k → V) → V} + (hf : Σ-[m + 1].DefinableFunction f) + (h : Γ-[m + 1].Definable (fun w ↦ P (w ·.succ) (w 0))) : + Γ-[m + 1].Definable (fun v ↦ ∀ {x}, x < f v → P v x) := + ball_lt hf h + +lemma ball_le' [V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {Γ} {P : (Fin k → V) → V → Prop} {f : (Fin k → V) → V} + (hf : Σ-[m + 1].DefinableFunction f) + (h : Γ-[m + 1].Definable (fun w ↦ P (w ·.succ) (w 0))) : + Γ-[m + 1].Definable (fun v ↦ ∀ {x}, x ≤ f v → P v x) := + ball_le hf h + +end Definable + +attribute [aesop 5 (rule_sets := [Definability]) safe] DefinableFunction₁.comp + DefinableFunction₂.comp DefinableFunction₃.comp DefinableFunction₄.comp + DefinableFunction₅.comp + +attribute [aesop 6 (rule_sets := [Definability]) safe] Definable.comp₁ Definable.comp₂ + Definable.comp₃ Definable.comp₄ Definable.comp₅ Definable.const + +attribute [aesop 8 (rule_sets := [Definability]) safe] Definable.ball_lt Definable.ball_le + Definable.bexs_lt Definable.bexs_le + +attribute [aesop 10 (rule_sets := [Definability]) safe] Definable.not Definable.imp + Definable.biconditional + +attribute [aesop 11 (rule_sets := [Definability]) safe] Definable.and Definable.or Definable.all + Definable.exs + +/-! ### Auxiliary lemmata for aesop -/ + +section + +variable (P : (Fin k → V) → Prop) (f : (Fin k → V) → V) + +instance [Σ₁.Definable P] : Σ-[0 + 1].Definable P := + inferInstance + +instance [Π₁.Definable P] : Π-[0 + 1].Definable P := + inferInstance + +instance [∆₁.Definable P] : ∆-[0 + 1].Definable P := + inferInstance + +instance [Σ₁.DefinableFunction f] : Σ-[0 + 1].DefinableFunction f := + inferInstance + +instance [Π₁.DefinableFunction f] : Π-[0 + 1].DefinableFunction f := + inferInstance + +instance [∆₁.DefinableFunction f] : ∆-[0 + 1].DefinableFunction f := + inferInstance + +instance [Σ-[2].Definable P] : Σ-[0 + 1 + 1].Definable P := + inferInstance + +instance [Π-[2].Definable P] : Π-[0 + 1 + 1].Definable P := + inferInstance + +instance [∆-[2].Definable P] : ∆-[0 + 1 + 1].Definable P := + inferInstance + +instance [Σ-[2].DefinableFunction f] : Σ-[0 + 1 + 1].DefinableFunction f := + inferInstance + +instance [Π-[2].DefinableFunction f] : Π-[0 + 1 + 1].DefinableFunction f := + inferInstance + +instance [∆-[2].DefinableFunction f] : ∆-[0 + 1 + 1].DefinableFunction f := + inferInstance + +end + +end HierarchySymbol + +variable {V : Type*} [ORingStructure V] {Γ : Polarity} {s k : ℕ} + +lemma definable_of_hierarchy {φ : ArithmeticSemiformula ℕ k} (hφ : Hierarchy Γ s φ) + (e : ℕ → V) : Γ-[s].Definable fun v ↦ φ.Eval v e := + .mkPolarity (Rew.rewriteMap e ▹ φ) (hφ.rew _) fun _ ↦ by simp [Semiformula.eval_rewriteMap] + +lemma definablePred_of_hierarchy {φ : ArithmeticSemiformula ℕ 1} (hφ : Hierarchy Γ s φ) + (e : ℕ → V) : Γ-[s].DefinablePred fun x ↦ φ.Eval ![x] e := + (definable_of_hierarchy hφ e).of_iff fun v ↦ + by + have h : ![v 0] = v := (Matrix.fun_eq_vec_one v).symm + simp [h] + +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Definability/Hierarchy.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Definability/Hierarchy.lean new file mode 100644 index 000000000..750b1cbd8 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Definability/Hierarchy.lean @@ -0,0 +1,608 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.PeanoMinus.Basic + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +/-! +# Arithmetical Formula Sorted by Arithmetical Hierarchy + +This file defines the $\Sigma_n / \Pi_n / \Delta_n$ formulas of arithmetic of first-order logic. + +- `Σ-[m].Semiformula ξ n` is a `ArithmeticSemiformula ξ n` which is `Σ-[m]`. +- `Π-[m].Semiformula ξ n` is a `ArithmeticSemiformula ξ n` which is `Π-[m]`. +- `∆-[m].Semiformula ξ n` is a pair of `Σ-[m].Semiformula ξ n` and `Π-[m].Semiformula ξ n`. +- `ProperOn` : `φ.ProperOn M` iff `φ`'s two element `φ.sigma` and `φ.pi` are equivalent on model +`M`. + +-/ + +namespace FFL +namespace FirstOrder +namespace Arithmetic + +/-- Data and laws for Hierarchy Symbol in `FFL.FirstOrder.Arithmetic`. -/ +structure HierarchySymbol where + /-- The Γ construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ + Γ : SigmaPiDelta + /-- The rank construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ + rank : ℕ + +/-- The «term -[ ]» construction in `FFL.FirstOrder.Arithmetic`. -/ +scoped notation:max Γ:max "-[" n "]" => HierarchySymbol.mk Γ n + +/-- The Σ₀ construction in `Σ₀`. -/ +abbrev HierarchySymbol.sigmaZero : HierarchySymbol := + Σ-[0] + +/-- The Π₀ construction in `Π₀`. -/ +abbrev HierarchySymbol.piZero : HierarchySymbol := + Π-[0] + +/-- The ∆₀ construction in `∆₀`. -/ +abbrev HierarchySymbol.deltaZero : HierarchySymbol := + ∆-[0] + +/-- The Σ₁ construction in `Σ₁`. -/ +abbrev HierarchySymbol.sigmaOne : HierarchySymbol := + Σ-[1] + +/-- The Π₁ construction in `Π₁`. -/ +abbrev HierarchySymbol.piOne : HierarchySymbol := + Π-[1] + +/-- The ∆₁ construction in `∆₁`. -/ +abbrev HierarchySymbol.deltaOne : HierarchySymbol := + ∆-[1] + +/-- The «termΣ₀» construction in `FFL.FirstOrder.Arithmetic`. -/ +notation "Σ₀" => HierarchySymbol.sigmaZero + +/-- The «termΠ₀» construction in `FFL.FirstOrder.Arithmetic`. -/ +notation "Π₀" => HierarchySymbol.piZero + +/-- The «term∆₀» construction in `FFL.FirstOrder.Arithmetic`. -/ +notation "∆₀" => HierarchySymbol.deltaZero + +/-- The «termΣ₁» construction in `FFL.FirstOrder.Arithmetic`. -/ +notation "Σ₁" => HierarchySymbol.sigmaOne + +/-- The «termΠ₁» construction in `FFL.FirstOrder.Arithmetic`. -/ +notation "Π₁" => HierarchySymbol.piOne + +/-- The «term∆₁» construction in `FFL.FirstOrder.Arithmetic`. -/ +notation "∆₁" => HierarchySymbol.deltaOne + +namespace HierarchySymbol + +variable (ξ : Type*) (n : ℕ) + +/-- First-order formulas with separate bound and free variables. -/ +protected inductive Semiformula : HierarchySymbol → Type _ where + | + mkSigma {m} (φ : ArithmeticSemiformula ξ n) (hφ : Hierarchy Σ m φ := by simp) : + Σ-[m].Semiformula + | + mkPi {m} (φ : ArithmeticSemiformula ξ n) (hφ : Hierarchy Π m φ := by simp) : Π-[m].Semiformula + | mkDelta {m} : Σ-[m].Semiformula → Π-[m].Semiformula → ∆-[m].Semiformula + +/-- The Semisentence construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +protected abbrev Semisentence (Γ : HierarchySymbol) (n : ℕ) := + Γ.Semiformula Empty n + +/-- The Sentence construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol`. -/ +protected abbrev Sentence (Γ : HierarchySymbol) := + Γ.Semiformula Empty 0 + +variable {Γ : HierarchySymbol} + +variable {ξ n} + +namespace Semiformula + +/-- The val construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol.Semiformula`. -/ +@[coe] +def val {Γ : HierarchySymbol} : Γ.Semiformula ξ n → ArithmeticSemiformula ξ n + | mkSigma φ _ => φ + | mkPi φ _ => φ + | mkDelta φ _ => φ.val + +@[simp] +lemma val_mkSigma (φ : ArithmeticSemiformula ξ n) (hp : Hierarchy Σ m φ) : + (mkSigma φ hp).val = φ := + rfl + +@[simp] +lemma val_mkPi (φ : ArithmeticSemiformula ξ n) (hp : Hierarchy Π m φ) : (mkPi φ hp).val = φ := + rfl + +@[simp] +lemma val_mkDelta (φ : Σ-[m].Semiformula ξ n) (ψ : Π-[m].Semiformula ξ n) : + (mkDelta φ ψ).val = φ.val := + rfl + +instance : Coe (Σ₀.Semisentence n) (ArithmeticSemisentence n) := + ⟨Semiformula.val⟩ + +instance : Coe (Π₀.Semisentence n) (ArithmeticSemisentence n) := + ⟨Semiformula.val⟩ + +instance : Coe (∆₀.Semisentence n) (ArithmeticSemisentence n) := + ⟨Semiformula.val⟩ + +instance : Coe (Σ₁.Semisentence n) (ArithmeticSemisentence n) := + ⟨Semiformula.val⟩ + +instance : Coe (Π₁.Semisentence n) (ArithmeticSemisentence n) := + ⟨Semiformula.val⟩ + +instance : Coe (∆₁.Semisentence n) (ArithmeticSemisentence n) := + ⟨Semiformula.val⟩ + +lemma sigma_prop : (φ : Σ-[m].Semiformula ξ n) → Hierarchy Σ m φ.val + | mkSigma _ h => h + +lemma pi_prop : (φ : Π-[m].Semiformula ξ n) → Hierarchy Π m φ.val + | mkPi _ h => h + +@[simp] +lemma polarity_prop : {Γ : Polarity} → (φ : Γ-[m].Semiformula ξ n) → Hierarchy Γ m φ.val + | Σ, φ => φ.sigma_prop + | Π, φ => φ.pi_prop + +/-- The sigma construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol.Semiformula`. -/ +def sigma : ∆-[m].Semiformula ξ n → Σ-[m].Semiformula ξ n + | mkDelta φ _ => φ + +@[simp] +lemma sigma_mkDelta (φ : Σ-[m].Semiformula ξ n) (ψ : Π-[m].Semiformula ξ n) : + (mkDelta φ ψ).sigma = φ := + rfl + +/-- The pi construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol.Semiformula`. -/ +def pi : ∆-[m].Semiformula ξ n → Π-[m].Semiformula ξ n + | mkDelta _ φ => φ + +@[simp] +lemma pi_mkDelta (φ : Σ-[m].Semiformula ξ n) (ψ : Π-[m].Semiformula ξ n) : + (mkDelta φ ψ).pi = ψ := + rfl + +lemma val_sigma (φ : ∆-[m].Semiformula ξ n) : φ.sigma.val = φ.val := by rcases φ; simp + +/-- The mk Polarity construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol.Semiformula`. -/ +def mkPolarity (φ : ArithmeticSemiformula ξ n) : + (Γ : Polarity) → Hierarchy Γ m φ → Γ-[m].Semiformula ξ n + | Σ, h => mkSigma φ h + | Π, h => mkPi φ h + +@[simp] +lemma val_mkPolarity (φ : ArithmeticSemiformula ξ n) {Γ} (h : Hierarchy Γ m φ) : + (mkPolarity φ Γ h).val = φ := by cases Γ <;> rfl + +@[simp] +lemma hierarchy_sigma (φ : Σ-[m].Semiformula ξ n) : Hierarchy Σ m φ.val := + φ.sigma_prop + +@[simp] +lemma hierarchy_pi (φ : Π-[m].Semiformula ξ n) : Hierarchy Π m φ.val := + φ.pi_prop + +@[simp] +lemma hierarchy_zero {Γ Γ' m} (φ : Γ-[0].Semiformula ξ n) : Hierarchy Γ' m φ.val := + by + cases Γ + · exact Hierarchy.of_zero φ.sigma_prop + · exact Hierarchy.of_zero φ.pi_prop + · cases φ + simpa using Hierarchy.of_zero (sigma_prop _) + +variable {M : Type*} [ORingStructure M] + +variable (M) + +/-- The Proper On construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol.Semiformula`. -/ +def ProperOn (φ : ∆-[m].Semisentence n) : Prop := + ∀ (e : Fin n → M), φ.sigma.val.Evalb e ↔ φ.pi.val.Evalb e + +/-- The Proper With Param On construction in +`FFL.FirstOrder.Arithmetic.HierarchySymbol.Semiformula`. -/ +def ProperWithParamOn (φ : ∆-[m].Semiformula M n) : Prop := + ∀ (e : Fin n → M), φ.sigma.val.Eval e id ↔ φ.pi.val.Eval e id + +/-- The Provably Proper On construction in +`FFL.FirstOrder.Arithmetic.HierarchySymbol.Semiformula`. -/ +def ProvablyProperOn (φ : ∆-[m].Semisentence n) (T : ArithmeticTheory) : Prop := + T ⊢ ∀¹* (“!φ.sigma.val⋯ ↔ !φ.pi.val⋯”) + +variable {M} + +lemma ProperOn.iff {φ : ∆-[m].Semisentence n} (h : φ.ProperOn M) (e : Fin n → M) : + φ.sigma.val.Evalb e ↔ φ.pi.val.Evalb e := + h e + +lemma ProperWithParamOn.iff {φ : ∆-[m].Semiformula M n} (h : φ.ProperWithParamOn M) + (e : Fin n → M) : φ.sigma.val.Eval e id ↔ φ.pi.val.Eval e id := + h e + +lemma ProperOn.iff' {φ : ∆-[m].Semisentence n} (h : φ.ProperOn M) (e : Fin n → M) : + φ.pi.val.Evalb e ↔ φ.val.Evalb e := by simp [← h.iff, val_sigma] + +lemma ProperWithParamOn.iff' {φ : ∆-[m].Semiformula M n} (h : φ.ProperWithParamOn M) + (e : Fin n → M) : φ.pi.val.Eval e id ↔ φ.val.Eval e id := by simp [← h.iff, val_sigma] + +/-- Data and laws for Provably Proper On' in +`FFL.FirstOrder.Arithmetic.HierarchySymbol.Semiformula`. -/ +inductive ProvablyProperOn' (T : ArithmeticTheory) : + {Γ : HierarchySymbol} → {n : ℕ} → (φ : Γ.Semisentence n) → Prop + | sigma (φ : Σ-[m].Semisentence n) : φ.ProvablyProperOn' T + | pi (φ : Π-[m].Semisentence n) : φ.ProvablyProperOn' T + | delta (φ : ∆-[m].Semisentence n) : φ.ProvablyProperOn T → φ.ProvablyProperOn' T + +section ProvablyProperOn + +variable (T : ArithmeticTheory) + +lemma ProvablyProperOn.ofProperOn [𝐄𝐐 ℒₒᵣ ≼ T] {φ : ∆-[m].Semisentence n} + (h : ∀ (M : Type w) [ORingStructure M] [M↓[ℒₒᵣ] ⊧* T], φ.ProperOn M) : + φ.ProvablyProperOn T := + by + apply FirstOrder.Arithmetic.complete.{w} T _ ?_ + intro M _ _ + simpa [models_iff] using! (h M).iff + +variable {T} + +lemma ProvablyProperOn.properOn {φ : ∆-[m].Semisentence n} (h : φ.ProvablyProperOn T) + (M : Type w) [ORingStructure M] [M↓[ℒₒᵣ] ⊧* T] : φ.ProperOn M := + by + intro v + have := by simpa [models_iff] using consequence_iff.mp (Theory.Proof.sound h) M inferInstance + exact this v + +end ProvablyProperOn + +/-- The rew construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol.Semiformula`. -/ +def rew (ω : Rew ℒₒᵣ ξ₁ n₁ ξ₂ n₂) : + {Γ : HierarchySymbol} → Γ.Semiformula ξ₁ n₁ → Γ.Semiformula ξ₂ n₂ + | Σ-[_], mkSigma φ hp => mkSigma (ω ▹ φ) (by simpa using hp) + | Π-[_], mkPi φ hp => mkPi (ω ▹ φ) (by simpa using hp) + | ∆-[_], mkDelta φ ψ => mkDelta (φ.rew ω) (ψ.rew ω) + +@[simp] +lemma val_rew (ω : Rew ℒₒᵣ ξ₁ n₁ ξ₂ n₂) {Γ : HierarchySymbol} (φ : Γ.Semiformula ξ₁ n₁) : + (φ.rew ω).val = ω ▹ φ.val := by + rcases Γ with ⟨Γ, m⟩; + rcases φ with (_ | _ | ⟨⟨p, _⟩, ⟨q, _⟩⟩) <;> simp [rew] + +@[simp] +lemma ProperOn.rew {φ : ∆-[m].Semisentence n₁} (h : φ.ProperOn M) + (ω : Rew ℒₒᵣ Empty n₁ Empty n₂) : (φ.rew ω).ProperOn M := + by + rcases φ; + simp only [ProperOn, Semiformula.rew, sigma_mkDelta, val_rew, Semiformula.eval_rew, + Empty.eq_elim, pi_mkDelta] + intro e; exact h.iff _ + +@[simp] +lemma ProperOn.rew' {φ : ∆-[m].Semisentence n₁} (h : φ.ProperOn M) (ω : Rew ℒₒᵣ Empty n₁ M n₂) : + (φ.rew ω).ProperWithParamOn M := by + rcases φ; intro e; simp [Semiformula.rew, Semiformula.eval_rew, Empty.eq_elim] + simpa using h.iff _ + +@[simp] +lemma ProperWithParamOn.rew {φ : ∆-[m].Semiformula M n₁} (h : φ.ProperWithParamOn M) + (f : Fin n₁ → ArithmeticSemiterm M n₂) : (φ.rew (Rew.subst f)).ProperWithParamOn M := + by + rcases φ; intro e; + simp only [Semiformula.rew, sigma_mkDelta, val_rew, Semiformula.eval_rew, pi_mkDelta] + exact h.iff _ + +lemma sigmaZero {Γ} (φ : Γ-[0].Semiformula ξ k) : Hierarchy Σ 0 φ.val := + match Γ with + | Σ => φ.sigma_prop + | Π => φ.pi_prop.of_zero + | ∆ => by simp + +/-- The of Zero construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol.Semiformula`. -/ +def ofZero {Γ'} (φ : Γ'-[0].Semiformula ξ k) : (Γ : HierarchySymbol) → Γ.Semiformula ξ k + | Σ-[_] => mkSigma φ.val φ.sigmaZero.of_zero + | Π-[_] => mkPi φ.val φ.sigmaZero.of_zero + | ∆-[_] => mkDelta (mkSigma φ.val φ.sigmaZero.of_zero) (mkPi φ.val φ.sigmaZero.of_zero) + +/-- The of Delta One construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol.Semiformula`. -/ +def ofDeltaOne (φ : ∆₁.Semiformula ξ k) : + (Γ : SigmaPiDelta) → (m : ℕ) → Γ-[m + 1].Semiformula ξ k + | Σ, m => mkSigma φ.sigma.val (φ.sigma.sigma_prop.mono (by simp)) + | Π, m => mkPi φ.pi.val (φ.pi.pi_prop.mono (by simp)) + | ∆, m => + mkDelta (mkSigma φ.sigma.val (φ.sigma.sigma_prop.mono (by simp))) + (mkPi φ.pi.val (φ.pi.pi_prop.mono (by simp))) + +@[simp] +lemma ofZero_val {Γ'} (φ : Γ'-[0].Semiformula ξ n) (Γ) : (ofZero φ Γ).val = φ.val := by + match Γ with + | Σ-[_] => simp [ofZero] + | Π-[_] => simp [ofZero] + | ∆-[_] => simp [ofZero] + +@[simp] +lemma ProperOn.of_zero (φ : Γ'-[0].Semisentence k) (m) : (ofZero φ ∆-[m]).ProperOn M := by + simp [ProperOn, ofZero] + +@[simp] +lemma ProperWithParamOn.of_zero (φ : Γ'-[0].Semiformula M k) (m) : + (ofZero φ ∆-[m]).ProperWithParamOn M := by simp [ProperWithParamOn, ofZero] + +/-- The verum construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol.Semiformula`. -/ +def verum : {Γ : HierarchySymbol} → Γ.Semiformula ξ n + | Σ-[m] => mkSigma ⊤ (by simp) + | Π-[m] => mkPi ⊤ (by simp) + | ∆-[m] => mkDelta (mkSigma ⊤ (by simp)) (mkPi ⊤ (by simp)) + +/-- The falsum construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol.Semiformula`. -/ +def falsum : {Γ : HierarchySymbol} → Γ.Semiformula ξ n + | Σ-[m] => mkSigma ⊥ (by simp) + | Π-[m] => mkPi ⊥ (by simp) + | ∆-[m] => mkDelta (mkSigma ⊥ (by simp)) (mkPi ⊥ (by simp)) + +/-- The and construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol.Semiformula`. -/ +def and : {Γ : HierarchySymbol} → Γ.Semiformula ξ n → Γ.Semiformula ξ n → Γ.Semiformula ξ n + | Σ-[m], φ, ψ => mkSigma (φ.val ⋏ ψ.val) (by simp) + | Π-[m], φ, ψ => mkPi (φ.val ⋏ ψ.val) (by simp) + | ∆-[m], φ, ψ => + mkDelta (mkSigma (φ.sigma.val ⋏ ψ.sigma.val) (by simp)) + (mkPi (φ.pi.val ⋏ ψ.pi.val) (by simp)) + +/-- The or construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol.Semiformula`. -/ +def or : {Γ : HierarchySymbol} → Γ.Semiformula ξ n → Γ.Semiformula ξ n → Γ.Semiformula ξ n + | Σ-[m], φ, ψ => mkSigma (φ.val ⋎ ψ.val) (by simp) + | Π-[m], φ, ψ => mkPi (φ.val ⋎ ψ.val) (by simp) + | ∆-[m], φ, ψ => + mkDelta (mkSigma (φ.sigma.val ⋎ ψ.sigma.val) (by simp)) + (mkPi (φ.pi.val ⋎ ψ.pi.val) (by simp)) + +/-- The neg Sigma construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol.Semiformula`. -/ +def negSigma (φ : Σ-[m].Semiformula ξ n) : Π-[m].Semiformula ξ n := + mkPi (∼φ.val) (by simp) + +/-- The neg Pi construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol.Semiformula`. -/ +def negPi (φ : Π-[m].Semiformula ξ n) : Σ-[m].Semiformula ξ n := + mkSigma (∼φ.val) (by simp) + +/-- The neg Delta construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol.Semiformula`. -/ +def negDelta (φ : ∆-[m].Semiformula ξ n) : ∆-[m].Semiformula ξ n := + mkDelta (φ.pi.negPi) (φ.sigma.negSigma) + +/-- The ball construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol.Semiformula`. -/ +def ball (t : ArithmeticSemiterm ξ n) : + {Γ : HierarchySymbol} → Γ.Semiformula ξ (n + 1) → Γ.Semiformula ξ n + | Σ-[m], φ => mkSigma (∀¹[“#0 < !!(Rew.bShift t)”] φ.val) (by simp) + | Π-[m], φ => mkPi (∀¹[“#0 < !!(Rew.bShift t)”] φ.val) (by simp) + | ∆-[m], φ => + mkDelta (mkSigma (∀¹[“#0 < !!(Rew.bShift t)”] φ.sigma.val) (by simp)) + (mkPi (∀¹[“#0 < !!(Rew.bShift t)”] φ.pi.val) (by simp)) + +/-- The bexs construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol.Semiformula`. -/ +def bexs (t : ArithmeticSemiterm ξ n) : + {Γ : HierarchySymbol} → Γ.Semiformula ξ (n + 1) → Γ.Semiformula ξ n + | Σ-[m], φ => mkSigma (∃¹[“#0 < !!(Rew.bShift t)”] φ.val) (by simp) + | Π-[m], φ => mkPi (∃¹[“#0 < !!(Rew.bShift t)”] φ.val) (by simp) + | ∆-[m], φ => + mkDelta (mkSigma (∃¹[“#0 < !!(Rew.bShift t)”] φ.sigma.val) (by simp)) + (mkPi (∃¹[“#0 < !!(Rew.bShift t)”] φ.pi.val) (by simp)) + +/-- The all construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol.Semiformula`. -/ +def all (φ : Π-[m + 1].Semiformula ξ (n + 1)) : Π-[m + 1].Semiformula ξ n := + mkPi (∀¹ φ.val) φ.pi_prop.all + +/-- The exs construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol.Semiformula`. -/ +def exs (φ : Σ-[m + 1].Semiformula ξ (n + 1)) : Σ-[m + 1].Semiformula ξ n := + mkSigma (∃¹ φ.val) φ.sigma_prop.exs + +instance : Top (Γ.Semiformula ξ n) := + ⟨verum⟩ + +instance : Bot (Γ.Semiformula ξ n) := + ⟨falsum⟩ + +instance : Wedge (Γ.Semiformula ξ n) := + ⟨and⟩ + +instance : Vee (Γ.Semiformula ξ n) := + ⟨or⟩ + +instance : Tilde (∆-[m].Semiformula ξ n) := + ⟨negDelta⟩ + +instance : LogicalConnective (∆-[m].Semiformula ξ n) where arrow φ ψ := ∼φ ⋎ ψ + +instance : ExsQuantifier (Σ-[m + 1].Semiformula ξ) := + ⟨exs⟩ + +instance : UnivQuantifier (Π-[m + 1].Semiformula ξ) := + ⟨all⟩ + +/-- The subst Sigma construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol.Semiformula`. -/ +def substSigma (φ : Σ-[m + 1].Semiformula ξ 1) (F : Σ-[m + 1].Semiformula ξ (n + 1)) : + Σ-[m + 1].Semiformula ξ n := + (F ⋏ φ.rew (Rew.subst ![#0])).exs + +@[simp] +lemma val_verum : (⊤ : Γ.Semiformula ξ n).val = ⊤ := by rcases Γ with ⟨Γ, m⟩; cases Γ <;> rfl + +@[simp] +lemma sigma_verum {m} : (⊤ : ∆-[m].Semiformula ξ n).sigma = ⊤ := by simp [Top.top, verum] + +@[simp] +lemma pi_verum {m} : (⊤ : ∆-[m].Semiformula ξ n).pi = ⊤ := by simp [Top.top, verum] + +@[simp] +lemma val_falsum : (⊥ : Γ.Semiformula ξ n).val = ⊥ := by rcases Γ with ⟨Γ, m⟩; cases Γ <;> rfl + +@[simp] +lemma sigma_falsum {m} : (⊥ : ∆-[m].Semiformula ξ n).sigma = ⊥ := by simp [Bot.bot, falsum] + +@[simp] +lemma pi_falsum {m} : (⊥ : ∆-[m].Semiformula ξ n).pi = ⊥ := by simp [Bot.bot, falsum] + +@[simp] +lemma val_and (φ ψ : Γ.Semiformula ξ n) : (φ ⋏ ψ).val = φ.val ⋏ ψ.val := + by + suffices (φ.and ψ).val = φ.val ⋏ ψ.val from this + rcases Γ with ⟨Γ, m⟩; rcases Γ <;> simp [and, val, val_sigma] + +@[simp] +lemma sigma_and (φ ψ : ∆-[m].Semiformula ξ n) : (φ ⋏ ψ).sigma = φ.sigma ⋏ ψ.sigma := + rfl + +@[simp] +lemma pi_and (φ ψ : ∆-[m].Semiformula ξ n) : (φ ⋏ ψ).pi = φ.pi ⋏ ψ.pi := + rfl + +@[simp] +lemma val_or (φ ψ : Γ.Semiformula ξ n) : (φ ⋎ ψ).val = φ.val ⋎ ψ.val := + by + suffices (φ.or ψ).val = φ.val ⋎ ψ.val from this + rcases Γ with ⟨Γ, m⟩; rcases Γ <;> simp [or, val, val_sigma] + +@[simp] +lemma sigma_or (φ ψ : ∆-[m].Semiformula ξ n) : (φ ⋎ ψ).sigma = φ.sigma ⋎ ψ.sigma := + rfl + +@[simp] +lemma pi_or (φ ψ : ∆-[m].Semiformula ξ n) : (φ ⋎ ψ).pi = φ.pi ⋎ ψ.pi := + rfl + +@[simp] +lemma val_negSigma {m} (φ : Σ-[m].Semiformula ξ n) : φ.negSigma.val = ∼φ.val := by + simp [negSigma] + +@[simp] +lemma val_negPi {m} (φ : Π-[m].Semiformula ξ n) : φ.negPi.val = ∼φ.val := by simp [negPi] + +lemma val_negDelta {m} (φ : ∆-[m].Semiformula ξ n) : (∼φ).val = ∼φ.pi.val := by + simp [HTilde.hTilde, Tilde.tilde, negDelta] + +@[simp] +lemma sigma_negDelta {m} (φ : ∆-[m].Semiformula ξ n) : (∼φ).sigma = φ.pi.negPi := by + simp [HTilde.hTilde, Tilde.tilde, negDelta] + +@[simp] +lemma sigma_negPi {m} (φ : ∆-[m].Semiformula ξ n) : (∼φ).pi = φ.sigma.negSigma := by + simp [HTilde.hTilde, Tilde.tilde, negDelta] + +@[simp] +lemma val_ball (t : ArithmeticSemiterm ξ n) (φ : Γ.Semiformula ξ (n + 1)) : + (ball t φ).val = ∀¹[“#0 < !!(Rew.bShift t)”] φ.val := by + rcases Γ with ⟨Γ, m⟩; + rcases Γ <;> simp [ball, val, val_sigma] + +@[simp] +lemma val_bexs (t : ArithmeticSemiterm ξ n) (φ : Γ.Semiformula ξ (n + 1)) : + (bexs t φ).val = ∃¹[“#0 < !!(Rew.bShift t)”] φ.val := by + rcases Γ with ⟨Γ, m⟩; + rcases Γ <;> simp [bexs, val, val_sigma] + +@[simp] +lemma val_exsSigma {m} (φ : Σ-[m + 1].Semiformula ξ (n + 1)) : (exs φ).val = ∃¹ φ.val := + rfl + +@[simp] +lemma val_allPi {m} (φ : Π-[m + 1].Semiformula ξ (n + 1)) : (all φ).val = ∀¹ φ.val := + rfl + +@[simp] +lemma ProperOn.verum : (⊤ : ∆-[m].Semisentence k).ProperOn M := by intro e; simp + +@[simp] +lemma ProperOn.falsum : (⊥ : ∆-[m].Semisentence k).ProperOn M := by intro e; simp + +lemma ProperOn.and {φ ψ : ∆-[m].Semisentence k} (hp : φ.ProperOn M) (hq : ψ.ProperOn M) : + (φ ⋏ ψ).ProperOn M := by intro e; simp [hp.iff, hq.iff] + +lemma ProperOn.or {φ ψ : ∆-[m].Semisentence k} (hp : φ.ProperOn M) (hq : ψ.ProperOn M) : + (φ ⋎ ψ).ProperOn M := by intro e; simp [hp.iff, hq.iff] + +lemma ProperOn.neg {φ : ∆-[m].Semisentence k} (hp : φ.ProperOn M) : (∼φ).ProperOn M := by + intro e; simp [hp.iff] + +lemma ProperOn.eval_neg {φ : ∆-[m].Semisentence k} (hp : φ.ProperOn M) (e : Fin k → M) : + (∼φ).val.Evalb e ↔ ¬φ.val.Evalb e := by simp [← val_sigma, hp.iff] + +lemma ProperOn.ball {t} {φ : ∆-[m + 1].Semisentence (k + 1)} (hp : φ.ProperOn M) : + (ball t φ).ProperOn M := by intro e; simp [Semiformula.ball, hp.iff] + +lemma ProperOn.bexs {t} {φ : ∆-[m + 1].Semisentence (k + 1)} (hp : φ.ProperOn M) : + (bexs t φ).ProperOn M := by intro e; simp [Semiformula.bexs, hp.iff] + +@[simp] +lemma ProperWithParamOn.verum : (⊤ : ∆-[m].Semiformula M k).ProperWithParamOn M := by + intro e; + simp + +@[simp] +lemma ProperWithParamOn.falsum : (⊥ : ∆-[m].Semiformula M k).ProperWithParamOn M := by + intro e; + simp + +lemma ProperWithParamOn.and {φ ψ : ∆-[m].Semiformula M k} (hp : φ.ProperWithParamOn M) + (hq : ψ.ProperWithParamOn M) : (φ ⋏ ψ).ProperWithParamOn M := by + intro e; + simp [hp.iff, hq.iff] + +lemma ProperWithParamOn.or {φ ψ : ∆-[m].Semiformula M k} (hp : φ.ProperWithParamOn M) + (hq : ψ.ProperWithParamOn M) : (φ ⋎ ψ).ProperWithParamOn M := by + intro e; + simp [hp.iff, hq.iff] + +lemma ProperWithParamOn.neg {φ : ∆-[m].Semiformula M k} (hp : φ.ProperWithParamOn M) : + (∼φ).ProperWithParamOn M := by intro e; simp [hp.iff] + +lemma ProperWithParamOn.eval_neg {φ : ∆-[m].Semiformula M k} (hp : φ.ProperWithParamOn M) + (e : Fin k → M) : (∼φ).val.Eval e id ↔ ¬φ.val.Eval e id := by simp [← val_sigma, hp.iff] + +lemma ProperWithParamOn.ball {t} {φ : ∆-[m].Semiformula M (k + 1)} + (hp : φ.ProperWithParamOn M) : (ball t φ).ProperWithParamOn M := by + intro e; + simp [Semiformula.ball, hp.iff] + +lemma ProperWithParamOn.bexs {t} {φ : ∆-[m].Semiformula M (k + 1)} + (hp : φ.ProperWithParamOn M) : (bexs t φ).ProperWithParamOn M := by + intro e; + simp [Semiformula.bexs, hp.iff] + +/-- The graph Delta construction in `FFL.FirstOrder.Arithmetic.HierarchySymbol.Semiformula`. -/ +def graphDelta (φ : Σ-[m].Semiformula ξ (k + 1)) : ∆-[m].Semiformula ξ (k + 1) := + match m with + | 0 => φ.ofZero _ + | m + 1 => mkDelta φ (mkPi (“x. ∀ y, !φ.val y⋯ → y = x”)) + +@[simp] +lemma graphDelta_val (φ : Σ-[m].Semiformula ξ (k + 1)) : φ.graphDelta.val = φ.val := by + cases m <;> simp [graphDelta] + +end Semiformula + +end HierarchySymbol + +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Exponential.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Exponential.lean new file mode 100644 index 000000000..03fb7a1cd --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Exponential.lean @@ -0,0 +1,22 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Exponential.Pow2 +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Exponential.PPow2 +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Exponential.Exp +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Exponential.Log +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Exponential.Bit + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Exponential/Bit.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Exponential/Bit.lean new file mode 100644 index 000000000..a1dcace43 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Exponential/Bit.lean @@ -0,0 +1,816 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Exponential.Log + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# $\mathrm{Bit}$ predicate +-/ + +@[expose] public section + +namespace FFL +namespace FirstOrder +namespace Arithmetic + +variable {V : Type*} [ORingStructure V] + +section + +variable [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +section model + +/-- The Bit construction in `FFL.FirstOrder.Arithmetic`. -/ +def Bit (i a : V) : Prop := + LenBit (Exp.exp i) a + +/-- Support for `∈` notation over a model of arithmetic, implemented by binary encoding. -/ +instance instMembershipModel : Membership V V := + ⟨fun a i ↦ Bit i a⟩ + +/-- The bit Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.bitDef : Σ₀.Semisentence 2 := + .mkSigma (“x y. ∃ z <⁺ y, !expDef z x ∧ !lenbitDef z y”) + +instance bit_defined : Σ₀-Relation[V] (· ∈ ·) via bitDef := + .mk fun v ↦ by + simp only [bitDef, Fin.isValue, Nat.reduceAdd, Nat.succ_eq_add_one, + HierarchySymbol.Semiformula.val_mkSigma, eval_bexsLTSucc', Semiterm.val_bvar, + LogicalConnective.HomClass.map_and, Semiformula.eval_substs, Matrix.comp₂, + Matrix.cons_val_zero, Matrix.cons_val_one, HierarchySymbol.Defined.iff, + Fin.succ_zero_eq_one, Matrix.cons_val_fin_one, Matrix.cons_app_two, + LogicalConnective.Prop.and_eq, ↓existsAndEq, true_and] + constructor + · rintro ⟨_, h⟩; exact h + · intro h; exact ⟨by simp [h.le], h⟩ + +instance mem_definable : Σ₀-Relation[V] (· ∈ ·) := + bit_defined.to_definable + +instance mem_definable' (ℌ : HierarchySymbol) : ℌ-Relation[V] (· ∈ ·) := + mem_definable.of_zero + +instance mem_definable'' (ℌ : HierarchySymbol) : ℌ-Relation[V] Membership.mem := by + simpa using (mem_definable' ℌ).retraction ![1, 0] + +lemma mem_absolute (i a : ℕ) : i ∈ a ↔ (i : V) ∈ (a : V) := by + simpa using Defined.shigmaZero_absolute V bit_defined bit_defined ![i, a] + +lemma mem_iff_bit {i a : V} : i ∈ a ↔ Bit i a := + iff_of_eq rfl + +lemma exp_le_of_mem {i a : V} (h : i ∈ a) : Exp.exp i ≤ a := + LenBit.le h + +lemma lt_of_mem {i a : V} (h : i ∈ a) : i < a := + lt_of_lt_of_le (lt_exp i) (exp_le_of_mem h) + +lemma not_mem_of_lt_exp {i a : V} (h : a < Exp.exp i) : i ∉ a := fun H ↦ by + have := lt_of_le_of_lt (exp_le_of_mem H) h; simp at this + +@[definability] +lemma HierarchySymbol.Definable.ball_mem (Γ m) {P : (Fin k → V) → V → Prop} + {f : (Fin k → V) → V} (hf : Σ-[m + 1].DefinableFunction f) + (h : Γ-[m + 1].Definable (fun w ↦ P (w ·.succ) (w 0))) : + Γ-[m + 1].Definable (fun v ↦ ∀ x ∈ f v, P v x) := + by + have : Γ-[m + 1].Definable (fun v ↦ ∀ x < f v, x ∈ f v → P v x) := + .ball_lt hf + (.imp (HierarchySymbol.Definable.comp₂ (P := (· ∈ ·)) (.var 0) (hf.retraction Fin.succ)) + h) + refine this.of_iff (fun v => ?_) + exact ⟨fun h x _ hxv ↦ h x hxv, fun h x hx ↦ h x (lt_of_mem hx) hx⟩ + +@[definability] +lemma HierarchySymbol.Definable.bexs_mem (Γ m) {P : (Fin k → V) → V → Prop} + {f : (Fin k → V) → V} (hf : Σ-[m + 1].DefinableFunction f) + (h : Γ-[m + 1].Definable (fun w ↦ P (w ·.succ) (w 0))) : + Γ-[m + 1].Definable (fun v ↦ ∃ x ∈ f v, P v x) := + by + have : Γ-[m + 1].Definable (fun v ↦ ∃ x < f v, x ∈ f v ∧ P v x) := + .bexs_lt hf + (.and (HierarchySymbol.Definable.comp₂ (P := (· ∈ ·)) (.var 0) (hf.retraction _)) h) + refine this.of_iff (fun v => ?_) + constructor + · rintro ⟨x, hx, hxv⟩ + exact ⟨x, lt_of_mem hx, hx, hxv⟩ + · rintro ⟨x, _, hx, hvx⟩ + exact ⟨x, hx, hvx⟩ + +end model + +section mem + +variable {ξ : Type*} {n} + +instance : Semiformula.Operator.Mem ℒₒᵣ := + ⟨⟨bitDef.val⟩⟩ + +lemma operator_mem_def : Semiformula.Operator.Mem.mem.sentence = bitDef.val := by + simp [Semiformula.Operator.Mem.mem] + +/-- The ball In construction in `FFL.FirstOrder.Arithmetic`. -/ +def ballIn (t : ArithmeticSemiterm ξ n) (p : ArithmeticSemiformula ξ (n + 1)) : + ArithmeticSemiformula ξ n := + “∀ x < !!t, x ∈ !!(Rew.bShift t) → !p x⋯” + +/-- The bexs In construction in `FFL.FirstOrder.Arithmetic`. -/ +def bexsIn (t : ArithmeticSemiterm ξ n) (p : ArithmeticSemiformula ξ (n + 1)) : + ArithmeticSemiformula ξ n := + “∃ x < !!t, x ∈ !!(Rew.bShift t) ∧ !p x⋯” + +@[simp] +lemma Hierarchy.bit {t u : ArithmeticSemiterm μ n} : Hierarchy Γ s (“!!t ∈ !!u”) := by + simp [Semiformula.Operator.operator, Matrix.fun_eq_vec_two, operator_mem_def] + +@[simp] +lemma Hieralchy.ballIn {Γ m} (t : ArithmeticSemiterm ξ n) + (p : ArithmeticSemiformula ξ (n + 1)) : Hierarchy Γ m (ballIn t p) ↔ Hierarchy Γ m p := + by + simp only [Arithmetic.ballIn] + simp [Semiformula.Operator.operator, operator_mem_def] + +@[simp] +lemma Hieralchy.bexsIn {Γ m} (t : ArithmeticSemiterm ξ n) + (p : ArithmeticSemiformula ξ (n + 1)) : Hierarchy Γ m (bexsIn t p) ↔ Hierarchy Γ m p := + by + simp only [Arithmetic.bexsIn] + simp [Semiformula.Operator.operator, operator_mem_def] + +/-- The mem Rel construction in `FFL.FirstOrder.Arithmetic`. -/ +def memRel : Σ₀.Semisentence 3 := + .mkSigma (“R x y. ∃ p <⁺ (x + y + 1)², !pairDef p x y ∧ p ∈ R”) + +/-- The mem Rel₃ construction in `FFL.FirstOrder.Arithmetic`. -/ +def memRel₃ : Σ₀.Semisentence 4 := + .mkSigma + (“R x y z. + ∃ yz <⁺ (y + z + 1)², + !pairDef yz y z ∧ ∃ xyz <⁺ (x + yz + 1)², !pairDef xyz x yz ∧ xyz ∈ R”) + +/-- The relation `⟪x, y⟫ ∈ R` in arithmetic, implemented by binary coding, as an operator. -/ +def memRelOpr : Semiformula.Operator ℒₒᵣ 3 := + ⟨memRel.val⟩ + +/-- The mem Rel₃Opr construction in `FFL.FirstOrder.Arithmetic`. -/ +def memRel₃Opr : Semiformula.Operator ℒₒᵣ 4 := + ⟨memRel₃.val⟩ + +section notations + +open _root_.Lean Lean PrettyPrinter Delaborator + +/-- The «first order formula∀ ∈' , » construction in `FFL.FirstOrder.Arithmetic`. -/ +syntax :max "∀ " ident " ∈' " firstOrderTerm ", " firstOrderFormula:0 : firstOrderFormula + +/-- The «first order formula∃ ∈' , » construction in `FFL.FirstOrder.Arithmetic`. -/ +syntax :max "∃ " ident " ∈' " firstOrderTerm ", " firstOrderFormula:0 : firstOrderFormula + +macro_rules + | `(quoteformula(lit)[$binders* | $fbinders* | ∀ $x ∈' $t, $p]) => do + if binders.elem x then + Macro.throwErrorAt x "error: variable is duplicated." + else + let binders' := binders.insertIdx 0 x + `(ballIn quoteterm(lit)[$binders* | $fbinders* | $t] + quoteformula(lit)[$binders'* | $fbinders* | $p]) + | `(quoteformula(lit)[$binders* | $fbinders* | ∃ $x ∈' $t, $p]) => do + if binders.elem x then + Macro.throwErrorAt x "error: variable is duplicated." + else + let binders' := binders.insertIdx 0 x + `(bexsIn quoteterm(lit)[$binders* | $fbinders* | $t] + quoteformula(lit)[$binders'* | $fbinders* | $p]) + +/-- +`x ~[m] y` states that `⟪x, y⟫` is in `m`, where the notion of "in" is implemented by binary +coding. -/ +syntax :45 firstOrderTerm:45 " ∼[" firstOrderTerm "]" firstOrderTerm:0 : firstOrderFormula + +/-- The «first order formula ≁[ ] » construction in `FFL.FirstOrder.Arithmetic`. -/ +syntax :45 firstOrderTerm:45 " ≁[" firstOrderTerm "]" firstOrderTerm:0 : firstOrderFormula + +/-- The «first order formula:⟪ , ⟫:∈ » construction in `FFL.FirstOrder.Arithmetic`. -/ +syntax :45 ":⟪" firstOrderTerm ", " firstOrderTerm "⟫:∈ " firstOrderTerm:0 : firstOrderFormula + +/-- The «first order formula:⟪ , , ⟫:∈ » construction in `FFL.FirstOrder.Arithmetic`. -/ +syntax :45 ":⟪" firstOrderTerm ", " firstOrderTerm ", " firstOrderTerm "⟫:∈ " firstOrderTerm:0 : + firstOrderFormula + +macro_rules + | + `(quoteformula(lit)[$binders* | $fbinders* | + $t₁:firstOrderTerm ∼[$u:firstOrderTerm]$t₂:firstOrderTerm]) => + `(memRelOpr.operator + ![quoteterm(lit)[$binders* | $fbinders* | $u], + quoteterm(lit)[$binders* | $fbinders* | $t₁], + quoteterm(lit)[$binders* | $fbinders* | $t₂]]) + | + `(quoteformula(lit)[$binders* | $fbinders* | + $t₁:firstOrderTerm ≁[$u:firstOrderTerm]$t₂:firstOrderTerm]) => + `(∼memRelOpr.operator + ![quoteterm(lit)[$binders* | $fbinders* | $u], + quoteterm(lit)[$binders* | $fbinders* | $t₁], + quoteterm(lit)[$binders* | $fbinders* | $t₂]]) + | + `(quoteformula(lit)[$binders* | $fbinders* | + :⟪$t₁:firstOrderTerm, $t₂:firstOrderTerm⟫:∈ $u:firstOrderTerm]) => + `(memRelOpr.operator + ![quoteterm(lit)[$binders* | $fbinders* | $u], + quoteterm(lit)[$binders* | $fbinders* | $t₁], + quoteterm(lit)[$binders* | $fbinders* | $t₂]]) + | + `(quoteformula(lit)[$binders* | $fbinders* | + :⟪$t₁:firstOrderTerm, $t₂:firstOrderTerm, $t₃:firstOrderTerm⟫:∈ $u:firstOrderTerm]) => + `(memRel₃Opr.operator + ![quoteterm(lit)[$binders* | $fbinders* | $u], + quoteterm(lit)[$binders* | $fbinders* | $t₁], + quoteterm(lit)[$binders* | $fbinders* | $t₂], + quoteterm(lit)[$binders* | $fbinders* | $t₃]]) + +@[simp] +lemma Hierarchy.memRel {t₁ t₂ u : ArithmeticSemiterm μ n} : + Hierarchy Γ s (“!!t₁ ∼[!!u] !!t₂”) := by + simp [Semiformula.Operator.operator, Matrix.fun_eq_vec_two, memRelOpr] + +@[simp] +lemma Hierarchy.memRel₃ {t₁ t₂ t₃ u : ArithmeticSemiterm μ n} : + Hierarchy Γ s (“:⟪!!t₁, !!t₂, !!t₃⟫:∈ !!u”) := by + simp [Semiformula.Operator.operator, Matrix.fun_eq_vec_two, memRel₃Opr] + +end notations + +end mem + +section model + +scoped instance : Tarski.Structure.Mem ℒₒᵣ V := + ⟨by intro a b; simp [Semiformula.Operator.val, operator_mem_def]⟩ + +@[simp] +lemma eval_ballIn {t : ArithmeticSemiterm ξ n} {φ : ArithmeticSemiformula ξ (n + 1)} + {bv : Fin n → V} {fv : ξ → V} : + (ballIn t φ).Eval (M := V) bv fv ↔ ∀ x ∈ t.val bv fv, φ.Eval (x :> bv) fv := + by + suffices + (∀ x < t.val bv fv, x ∈ t.val bv fv → φ.Eval (x :> bv) fv) ↔ + ∀ x ∈ t.val bv fv, φ.Eval (x :> bv) fv + by simpa [ballIn] + constructor + · intro h x hx; exact h x (lt_of_mem hx) hx + · intro h x _ hx; exact h x hx + +@[simp] +lemma eval_bexsIn {t : ArithmeticSemiterm ξ n} {φ : ArithmeticSemiformula ξ (n + 1)} + {bv : Fin n → V} {fv : ξ → V} : + (bexsIn t φ).Eval (M := V) bv fv ↔ ∃ x ∈ t.val bv fv, φ.Eval (x :> bv) fv := + by + suffices + (∃ x < t.val bv fv, x ∈ t.val bv fv ∧ φ.Eval (x :> bv) fv) ↔ + ∃ x ∈ t.val bv fv, φ.Eval (x :> bv) fv + by simpa [bexsIn] + constructor + · rintro ⟨x, _, hx, h⟩; exact ⟨x, hx, h⟩ + · rintro ⟨x, hx, h⟩; exact ⟨x, lt_of_mem hx, hx, h⟩ + +instance memRel_defined : Σ₀-Relation₃ (fun r x y : V ↦ ⟪x, y⟫ ∈ r) via memRel := + .mk fun v ↦ by simp [memRel] + +instance memRel₃_defined : Σ₀-Relation₄ (fun r x y z : V ↦ ⟪x, y, z⟫ ∈ r) via memRel₃ := + .mk fun v ↦ by simp [memRel₃] + +@[simp] +lemma eval_memRel {x y r : V} : memRelOpr.val ![r, x, y] ↔ ⟪x, y⟫ ∈ r := + by + unfold Semiformula.Operator.val + simp [memRelOpr] + +@[simp] +lemma eval_memRel₃ {x y z r : V} : memRel₃Opr.val ![r, x, y, z] ↔ ⟪x, y, z⟫ ∈ r := + by + unfold Semiformula.Operator.val + simp [memRel₃Opr] + +end model + +section model + +lemma mem_iff_mul_exp_add_exp_add {i a : V} : + i ∈ a ↔ ∃ k, ∃ r < Exp.exp i, a = k * Exp.exp (i + 1) + Exp.exp i + r := by + simpa [mem_iff_bit, exp_succ] using! lenbit_iff_add_mul (exp_pow2 i) (a := a) + +lemma not_mem_iff_mul_exp_add {i a : V} : + i ∉ a ↔ ∃ k, ∃ r < Exp.exp i, a = k * Exp.exp (i + 1) + r := by + simpa [mem_iff_bit, exp_succ] using! not_lenbit_iff_add_mul (exp_pow2 i) (a := a) + +section empty + +/-- The inst Empty Collection lean Pool construction in `FFL.FirstOrder.Arithmetic`. -/ +scoped instance instEmptyCollectionModel : EmptyCollection V := + ⟨0⟩ + +omit [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] in +lemma emptyset_def : (∅ : V) = 0 := + rfl + +@[simp] +lemma not_mem_empty (i : V) : i ∉ (∅ : V) := by simp [emptyset_def, mem_iff_bit, Bit] + +@[simp] +lemma not_mem_zero (i : V) : i ∉ (0 : V) := by simp [mem_iff_bit, Bit] + +end empty + +section singleton + +/-- The inst Singleton lean Pool construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable scoped instance instSingletonModel : Singleton V V := + ⟨fun a ↦ Exp.exp a⟩ + +lemma singleton_def (a : V) : { a } = Exp.exp a := + rfl + +@[simp] +lemma singleton_injective (a b : V) : ({ a } : V) = { b } ↔ a = b := + by + constructor + · intro h + simpa [singleton_def] using congr_arg log h + · rintro rfl; rfl + +end singleton + +section insert + +open _root_.Classical Classical in +/-- The bit Insert construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def bitInsert (i a : V) : V := + if i ∈ a then a else a + Exp.exp i + +open _root_.Classical Classical in +/-- The bit Remove construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def bitRemove (i a : V) : V := + if i ∈ a then a - Exp.exp i else a + +/-- The inst Insert lean Pool construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable scoped instance instInsertModel : Insert V V := + ⟨bitInsert⟩ + +lemma insert_eq {i a : V} : insert i a = bitInsert i a := + rfl + +lemma singleton_eq_insert (i : V) : ({ i } : V) = insert i ∅ := by + simp [singleton_def, insert, bitInsert, emptyset_def] + +instance : LawfulSingleton V V where insert_empty_eq := fun x ↦ Eq.symm <| singleton_eq_insert x + +@[simp] +lemma mem_bitInsert_iff {i j a : V} : i ∈ insert j a ↔ i = j ∨ i ∈ a := + by + by_cases h : j ∈ a <;> simp [h, insert_eq, bitInsert] + · by_cases e : i = j <;> simp [h, e] + · simpa [exp_inj.eq_iff] using! lenbit_add_pow2_iff_of_not_lenbit (exp_pow2 i) (exp_pow2 j) h + +@[simp] +lemma mem_bitRemove_iff {i j a : V} : i ∈ bitRemove j a ↔ i ≠ j ∧ i ∈ a := + by + by_cases h : j ∈ a + · simpa [h, bitRemove, exp_inj.eq_iff] using! + lenbit_sub_pow2_iff_of_lenbit (exp_pow2 i) (exp_pow2 j) h + · simp only [bitRemove, h, ↓reduceIte, ne_eq, iff_and_self] + rintro _ rfl; contradiction + +lemma not_mem_bitRemove_self (i a : V) : i ∉ bitRemove i a := by simp + +lemma insert_graph (b i a : V) : + b = insert i a ↔ (i ∈ a ∧ b = a) ∨ (i ∉ a ∧ ∃ e ≤ b, e = Exp.exp i ∧ b = a + e) := + ⟨by rintro rfl; by_cases hi : i ∈ a <;> simp [hi, insert, bitInsert], + by + by_cases hi : i ∈ a <;> + simp only [hi, true_and, not_true_eq_false, false_and, or_false, insert, bitInsert, + ↓reduceIte, imp_self, not_false_eq_true, true_and, false_or, forall_exists_index, + and_imp] + rintro x _ rfl rfl; rfl⟩ + +/-- The insert Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.insertDef : Σ₀.Semisentence 3 := + .mkSigma (“b i a. (i ∈ a ∧ b = a) ∨ (i ∉ a ∧ ∃ e <⁺ b, !expDef e i ∧ b = a + e)”) + +instance insert_defined : Σ₀-Function₂[V] insert via insertDef := + .mk fun v ↦ by simp [insertDef, insert_graph] + +instance insert_definable : Σ₀-Function₂[V] insert := + insert_defined.to_definable + +instance insert_definable' (Γ) : Γ-Function₂[V] insert := + insert_definable.of_zero + +open _root_.Classical Classical in +lemma insert_le_of_le_of_le {i j a b : V} (hij : i ≤ j) (hab : a ≤ b) : + insert i a ≤ b + Exp.exp j := + by + suffices (if i ∈ a then a else a + Exp.exp i) ≤ b + Exp.exp j by simpa [insert, bitInsert] + by_cases hi : i ∈ a + · simpa [hi] using le_trans hab (by simp) + · simpa [hi] using add_le_add hab (exp_monotone_le.mpr hij) + +lemma insert_absolute (x s : ℕ) : ((insert x s : ℕ) : V) = insert (x : V) (s : V) := + by + have := + DefinedFunction.shigmaZero_absolute_func V (k := 2) (f := fun v ↦ insert (v 0) (v 1)) (f' := + fun v ↦ insert (v 0) (v 1)) (φ := insertDef) insert_defined insert_defined ![x, s] + simpa using this + +end insert + +lemma one_eq_singleton : (1 : V) = {∅} := by + simp [singleton_eq_insert, insert, bitInsert, emptyset_def] + +@[simp] +lemma mem_singleton_iff {i j : V} : i ∈ ({ j } : V) ↔ i = j := by + simp [singleton_eq_insert, -insert_empty_eq] + +lemma bitRemove_lt_of_mem {i a : V} (h : i ∈ a) : bitRemove i a < a := by + simp [h, bitRemove, tsub_lt_iff_left (exp_le_of_mem h)] + +lemma pos_of_nonempty {i a : V} (h : i ∈ a) : 0 < a := + by + by_contra A + rcases show a = 0 by simpa using A + simp_all + +lemma mem_insert (i a : V) : i ∈ insert i a := by simp + +lemma insert_eq_self_of_mem {i a : V} (h : i ∈ a) : insert i a = a := by + simp [insert_eq, bitInsert, h] + +lemma log_mem_of_pos {a : V} (h : 0 < a) : log a ∈ a := + mem_iff_mul_exp_add_exp_add.mpr + ⟨0, a - Exp.exp (log a), + (tsub_lt_iff_left (exp_log_le_self h)).mpr + (by rw [← two_mul]; exact lt_two_mul_exponential_log h), + by simpa using Eq.symm <| add_tsub_self_of_le (exp_log_le_self h)⟩ + +lemma le_log_of_mem {i a : V} (h : i ∈ a) : i ≤ log a := + (exp_le_iff_le_log (pos_of_nonempty h)).mp (exp_le_of_mem h) + +lemma succ_mem_iff_mem_div_two {i a : V} : i + 1 ∈ a ↔ i ∈ a / 2 := by + simp [mem_iff_bit, Bit, LenBit.iff_rem, exp_succ, Arithmetic.div_mul] + +lemma lt_length_of_mem {i a : V} (h : i ∈ a) : i < ‖a‖ := by + simpa [length_of_pos (pos_of_nonempty h), ← le_iff_lt_succ] using le_log_of_mem h + +lemma lt_exp_iff {a i : V} : a < Exp.exp i ↔ ∀ j ∈ a, j < i := + ⟨fun h j hj ↦ exp_monotone.mp <| lt_of_le_of_lt (exp_le_of_mem hj) h, + by + suffices Exp.exp i ≤ a → ∃ x ∈ a, i ≤ x by contrapose; simpa + intro h + have pos : 0 < a := lt_of_lt_of_le (by simp) h + exact ⟨log a, log_mem_of_pos pos, (exp_le_iff_le_log pos).mp h⟩⟩ + +instance instHasSubsetModel : HasSubset V := + ⟨fun a b ↦ ∀ ⦃i⦄, i ∈ a → i ∈ b⟩ + +/-- The bit Subset Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.bitSubsetDef : Σ₀.Semisentence 2 := + .mkSigma (“a b. ∀ i < a, i ∈ a → i ∈ b”) + +instance bitSubset_defined : Σ₀-Relation[V] Subset via bitSubsetDef := + .mk fun v ↦ by + simpa [bitSubsetDef] using + ⟨by intro h x hx; exact h x (lt_of_mem hx) hx, by intro h x _ hx; exact h hx⟩ + +instance bitSubset_definable : Σ₀-Relation[V] Subset := + bitSubset_defined.to_definable₀ + +@[simp, definability] +instance bitSubset_definable' (ℌ : HierarchySymbol) : ℌ-Relation[V] Subset := + bitSubset_defined.to_definable₀ + +lemma subset_iff {a b : V} : a ⊆ b ↔ (∀ x ∈ a, x ∈ b) := by simp [HasSubset.Subset] + +@[refl, simp] +lemma subset_refl (a : V) : a ⊆ a := by intro x; simp + +@[trans] +lemma subset_trans {a b c : V} (hab : a ⊆ b) (hbc : b ⊆ c) : a ⊆ c := by + intro x hx; + exact hbc (hab hx) + +lemma mem_exp_add_succ_sub_one (i j : V) : i ∈ Exp.exp (i + j + 1) - 1 := + by + have : + Exp.exp (i + j + 1) - 1 = (Exp.exp j - 1) * Exp.exp (i + 1) + Exp.exp i + (Exp.exp i - 1) := + calc + Exp.exp (i + j + 1) - 1 = Exp.exp j * Exp.exp (i + 1) - 1 := by + simp [exp_add, ← mul_assoc, mul_comm] + _ = Exp.exp j * Exp.exp (i + 1) - Exp.exp (i + 1) + Exp.exp (i + 1) - 1 := by + rw [sub_add_self_of_le]; exact le_mul_of_pos_left (exp_pos j) + _ = (Exp.exp j - 1) * Exp.exp (i + 1) + Exp.exp (i + 1) - 1 := by simp [sub_mul] + _ = (Exp.exp j - 1) * Exp.exp (i + 1) + (Exp.exp i + Exp.exp i) - 1 := by + simp [← two_mul, ← exp_succ i] + _ = (Exp.exp j - 1) * Exp.exp (i + 1) + (Exp.exp i + Exp.exp i - 1) := by + rw [add_tsub_assoc_of_le]; simp [← two_mul, ← pos_iff_one_le] + _ = (Exp.exp j - 1) * Exp.exp (i + 1) + Exp.exp i + (Exp.exp i - 1) := by + simp [add_assoc, add_tsub_assoc_of_le] + exact + mem_iff_mul_exp_add_exp_add.mpr + ⟨Exp.exp j - 1, Exp.exp i - 1, (tsub_lt_iff_left (by simp)).mpr <| by simp, this⟩ + +/-- under a = {0, 1, 2, ..., a - 1} -/ +noncomputable def under (a : V) : V := + Exp.exp a - 1 + +@[simp] +lemma le_under (a : V) : a ≤ under a := + le_iff_lt_succ.mpr + (by simp [under, show Exp.exp a - 1 + 1 = Exp.exp a from sub_add_self_of_le (by simp)]) + +@[simp] +lemma mem_under_iff {i j : V} : i ∈ under j ↔ i < j := + by + constructor + · intro h + have : Exp.exp i < Exp.exp j := + calc + Exp.exp i ≤ Exp.exp j - 1 := exp_le_of_mem h + _ < Exp.exp j := pred_lt_self_of_pos (exp_pos j) + exact exp_monotone.mp this + · intro lt + have := lt_iff_succ_le.mp lt + let k := j - (i + 1) + have : j = i + k + 1 := + calc + j = i + (j - i) := by rw [add_tsub_self_of_le (le_of_lt lt)] + _ = i + (j - i - 1 + 1) := by + rw [sub_add_self_of_le <| le_tsub_of_add_le_left <| lt_iff_succ_le.mp lt] + _ = i + k + 1 := by simp [add_assoc, ← Arithmetic.sub_sub, k] + rw [this]; exact mem_exp_add_succ_sub_one i k + +lemma not_mem_under_self (i : V) : i ∉ under i := by simp + +private lemma under_graph (x y : V) : y = under x ↔ y + 1 = Exp.exp x := + by + constructor + · rintro rfl; simp [under, sub_add_self_of_le] + · intro h + have := congr_arg (· - 1) h + simpa [under] using this + +/-- The under Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.underDef : Σ₀.Semisentence 2 := + .mkSigma (“y x. !expDef.val(y + 1)x”) + +instance under_defined : Σ₀-Function₁[V] under via underDef := + .mk fun v ↦ by simp [underDef, under_graph] + +instance under_definable : Σ₀-Function₁[V] under := + under_defined.to_definable + +instance under_definable' (Γ) : Γ-Function₁[V] under := + under_definable.of_zero + +lemma eq_zero_of_subset_zero {a : V} : a ⊆ 0 → a = 0 := + by + intro h; by_contra A + have : log a ∈ (0 : V) := h (log_mem_of_pos (pos_iff_ne_zero.mpr A)) + simp_all + +lemma subset_div_two {a b : V} : a ⊆ b → a / 2 ⊆ b / 2 := + by + intro ss i hi + have : i + 1 ∈ a := succ_mem_iff_mem_div_two.mpr hi + exact succ_mem_iff_mem_div_two.mp <| ss this + +lemma zero_mem_iff {a : V} : 0 ∉ a ↔ 2 ∣ a := by simp [mem_iff_bit, Bit, LenBit] + +@[simp] +lemma zero_not_mem (a : V) : 0 ∉ 2 * a := by simp [mem_iff_bit, Bit, LenBit] + +@[simp] +lemma zero_mem_double_add_one (a : V) : 0 ∈ 2 * a + 1 := by + simp [mem_iff_bit, Bit, LenBit, ← mod_eq_zero_iff_dvd] + +@[simp] +lemma succ_mem_two_mul_iff {i a : V} : i + 1 ∈ 2 * a ↔ i ∈ a := by + simp [mem_iff_bit, Bit, LenBit, exp_succ, div_cancel_left] + +@[simp] +lemma succ_mem_two_mul_succ_iff {i a : V} : i + 1 ∈ 2 * a + 1 ↔ i ∈ a := by + simp [mem_iff_bit, Bit, LenBit, exp_succ, Arithmetic.div_mul] + +lemma le_of_subset {a b : V} (h : a ⊆ b) : a ≤ b := + by + induction b using pi1_polynomial_induction generalizing a + · definability + case zero => simp [eq_zero_of_subset_zero h] + case even b _ IH => + have IH : a / 2 ≤ b := IH (by simpa using subset_div_two h) + have : 2 * (a / 2) = a := + mul_div_self_of_dvd.mpr + (zero_mem_iff.mp <| by intro ha; have : 0 ∈ 2 * b := h ha; simp_all) + simpa [this] using mul_le_mul_left (a := 2) IH + case odd b + IH => + have IH : a / 2 ≤ b := IH (by simpa [div_mul_add' b 2 one_lt_two] using subset_div_two h) + exact le_trans (le_two_mul_div_two_add_one a) (by simpa using IH) + +lemma mem_ext {a b : V} (h : ∀ i, i ∈ a ↔ i ∈ b) : a = b := + le_antisymm (le_of_subset fun i hi ↦ (h i).mp hi) (le_of_subset fun i hi ↦ (h i).mpr hi) + +lemma mem_ext_iff {a b : V} : a = b ↔ ∀ i, i ∈ a ↔ i ∈ b := + ⟨by rintro rfl; simp, mem_ext⟩ + +lemma pos_iff_nonempty {s : V} : 0 < s ↔ s ≠ ∅ := + pos_iff_ne_zero + +lemma nonempty_of_pos {a : V} (h : 0 < a) : ∃ i, i ∈ a := + by + by_contra A + have : a = 0 := mem_ext (by simpa using A) + simp [this] at h + +lemma eq_empty_or_nonempty (a : V) : a = ∅ ∨ ∃ i, i ∈ a := + by + rcases Arithmetic.zero_le a with (rfl | pos) + · simp [emptyset_def] + · right; exact nonempty_of_pos pos + +lemma nonempty_iff {s : V} : s ≠ ∅ ↔ ∃ x, x ∈ s := + by + rcases eq_empty_or_nonempty s with ⟨rfl, hy⟩ + · simp + · simpa [show s ≠ ∅ from by rintro rfl; simp_all] + +lemma isempty_iff {s : V} : s = ∅ ↔ ∀ x, x ∉ s := by + simpa using not_iff_not.mpr (nonempty_iff (s := s)) + +@[simp] +lemma empty_subset (s : V) : ∅ ⊆ s := by intro x; simp + +lemma lt_of_lt_log {a b : V} (pos : 0 < b) (h : ∀ i ∈ a, i < log b) : a < b := + by + rcases Arithmetic.zero_le a with (rfl | apos) + · exact pos + by_contra A + exact + not_lt_of_ge (log_monotone <| show b ≤ a by simpa using A) (h (log a) (log_mem_of_pos apos)) + +@[simp] +lemma under_inj {i j : V} : under i = under j ↔ i = j := + ⟨fun h ↦ by + by_contra ne + wlog lt : i < j + · exact this (Eq.symm h) (Ne.symm ne) (lt_of_le_of_ne (by simpa using lt) (Ne.symm ne)) + have : i ∉ under i := by simp + have : i ∈ under i := by rw [h]; simp [mem_under_iff, lt] + contradiction, by rintro rfl; simp⟩ + +@[simp] +lemma under_zero : under (0 : V) = ∅ := + mem_ext (by simp [mem_under_iff]) + +@[simp] +lemma under_succ (i : V) : under (i + 1) = insert i (under i) := + mem_ext (by simp [mem_under_iff, lt_succ_iff_le, le_iff_eq_or_lt]) + +lemma insert_remove {i a : V} (h : i ∈ a) : insert i (bitRemove i a) = a := + mem_ext <| by + suffices ∀ j, j = i ∨ j ≠ i ∧ j ∈ a ↔ j ∈ a by simpa + intro j + constructor + · rintro (rfl | ⟨_, hj⟩) <;> assumption + · intro hj; simp [hj, eq_or_ne j i] + +end model + +end + +section + +variable {m : ℕ} [Fact (1 ≤ m)] [V↓[ℒₒᵣ] ⊧* 𝐈𝐍𝐃 Σ m] + +lemma finset_comprehension_aux (Γ : Polarity) {P : V → Prop} (hP : Γ-[m]-Predicate P) (a : V) : + haveI : V↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := modISigmaOfLe (show 1 ≤ m from Fact.out) + ∃ s < Exp.exp a, ∀ i < a, i ∈ s ↔ P i := + by + have : V↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := modISigmaOfLe (show 1 ≤ m from Fact.out) + have : ∃ s < Exp.exp a, ∀ i < a, P i → i ∈ s := + ⟨under a, pred_lt_self_of_pos (by simp), fun i hi _ ↦ by simpa [mem_under_iff] using hi⟩ + rcases this with ⟨s, hsn, hs⟩ + have : Γ.alt-[m]-Predicate (fun s : V ↦ ∀ i < a, P i → i ∈ s) := + by + apply HierarchySymbol.Definable.ball_blt + · simp + apply HierarchySymbol.Definable.imp + · simpa using HierarchySymbol.Definable.bcomp₁ (by definability) + · simpa using HierarchySymbol.Definable.bcomp₂ (by definability) (by definability) + have : ∃ t, (∀ i < a, P i → i ∈ t) ∧ ∀ t' < t, ∃ x < a, P x ∧ x ∉ (t' : V) := by + simpa using InductionOnHierarchy.least_number Γ.alt m this hs + rcases this with ⟨t, ht, t_minimal⟩ + have t_le_s : t ≤ s := + not_lt.mp + (by + intro lt + rcases t_minimal s lt with ⟨i, hin, hi, his⟩ + exact his (hs i hin hi)) + have : ∀ i < a, i ∈ t → P i := by + intro i _ hit + by_contra Hi + have : ∃ j < a, P j ∧ (j ∈ t → j = i) := by + simpa [not_imp_not] using t_minimal (bitRemove i t) (bitRemove_lt_of_mem hit) + rcases this with ⟨j, hjn, Hj, hm⟩ + rcases hm (ht j hjn Hj); contradiction + exact ⟨t, lt_of_le_of_lt t_le_s hsn, fun i hi ↦ ⟨this i hi, ht i hi⟩⟩ + +theorem finset_comprehension {Γ} {P : V → Prop} (hP : Γ-[m]-Predicate P) (a : V) : + haveI : V↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := modISigmaOfLe (show 1 ≤ m from Fact.out) + ∃ s < Exp.exp a, ∀ i < a, i ∈ s ↔ P i := + match Γ with + | Σ => finset_comprehension_aux Σ hP a + | Π => finset_comprehension_aux Π hP a + | ∆ => finset_comprehension_aux Σ hP.of_delta a + +theorem finset_comprehension_exists_unique {P : V → Prop} (hP : Γ-[m]-Predicate P) (a : V) : + haveI : V↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := modISigmaOfLe (show 1 ≤ m from Fact.out) + ∃! s, s < Exp.exp a ∧ ∀ i < a, i ∈ s ↔ P i := + by + have : V↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := modISigmaOfLe (show 1 ≤ m from Fact.out) + rcases finset_comprehension hP a with ⟨s, hs, Hs⟩ + exact + ExistsUnique.intro s ⟨hs, Hs⟩ + (by + intro t ⟨ht, Ht⟩ + apply mem_ext + intro i + constructor + · intro hi + have hin : i < a := exp_monotone.mp (lt_of_le_of_lt (exp_le_of_mem hi) ht) + exact (Hs i hin).mpr ((Ht i hin).mp hi) + · intro hi + have hin : i < a := exp_monotone.mp (lt_of_le_of_lt (exp_le_of_mem hi) hs) + exact (Ht i hin).mpr ((Hs i hin).mp hi)) + +end + +section + +variable [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +instance : Fact (1 ≤ 1) := + ⟨by rfl⟩ + +theorem finset_comprehension₁ {P : V → Prop} (hP : Γ-[1]-Predicate P) (a : V) : + ∃ s < Exp.exp a, ∀ i < a, i ∈ s ↔ P i := + finset_comprehension hP a + +theorem finset_comprehension₁Proof {P : V → Prop} (hP : Γ-[1]-Predicate P) (a : V) : + ∃! s, s < Exp.exp a ∧ (∀ i < a, i ∈ s ↔ P i) := + by + rcases finset_comprehension₁ hP a with ⟨s, hs, Ha⟩ + exact + ExistsUnique.intro s ⟨hs, Ha⟩ + (by + rintro b ⟨hb, Hb⟩ + apply mem_ext + intro x + constructor + · intro hx + have : x < a := exp_monotone.mp <| LE.le.trans_lt (exp_le_of_mem hx) hb + exact (Ha x this).mpr <| (Hb x this).mp hx + · intro hx + have : x < a := exp_monotone.mp <| LE.le.trans_lt (exp_le_of_mem hx) hs + exact (Hb x this).mpr <| (Ha x this).mp hx) + +theorem finite_comprehension₁Proof {P : V → Prop} (hP : Γ-[1]-Predicate P) + (fin : ∃ m, ∀ i, P i → i < m) : ∃! s : V, ∀ i, i ∈ s ↔ P i := + by + rcases fin with ⟨m, mh⟩ + rcases finset_comprehension₁ hP m with ⟨s, hs, Hs⟩ + have H : ∀ i, i ∈ s ↔ P i := fun i ↦ + ⟨fun h ↦ (Hs i (exp_monotone.mp (lt_of_le_of_lt (exp_le_of_mem h) hs))).mp h, fun h ↦ + (Hs i (mh i h)).mpr h⟩ + exact ExistsUnique.intro s H (fun s' H' ↦ mem_ext <| fun i ↦ by simp [H, H']) + +end + +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Exponential/Exp.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Exponential/Exp.lean new file mode 100644 index 000000000..48790467f --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Exponential/Exp.lean @@ -0,0 +1,979 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Exponential.PPow2 +public import Mathlib.Algebra.Order.Ring.Basic + +/-! Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section +/-! +# Exponential function + +This file provides a proof of the theorem states that +the graph of exponential function is definable by $\Sigma_0$-formula and +it's inductive property is provable in $\mathsf{I}\Sigma_0$. + +-/ + +namespace FFL +namespace FirstOrder +namespace Arithmetic + +variable {V : Type*} [ORingStructure V] + +section ISigma0 + +variable [V↓[ℒₒᵣ] ⊧* 𝐈Σ₀] + +/-- The ext construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def ext (u z : V) : V := + z / u % u + +lemma ext_graph (a b c : V) : a = ext b c ↔ ∃ x ≤ c, x = c / b ∧ a = x % b := by simp [ext] + +/-- The ext Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.extDef : Σ₀.Semisentence 3 := + .mkSigma “a b c. ∃ x <⁺ c, !divDef x c b ∧ !remDef a x b” + +instance ext_defined : Σ₀-Function₂[V] ext via extDef := + .mk fun v ↦ by simp [extDef, ext_graph, Semiformula.eval_substs, le_iff_lt_succ] + +instance ext_definable : Σ₀-Function₂[V] ext := + ext_defined.to_definable + +@[simp] +lemma ext_le_add (u z : V) : ext u z ≤ z := + le_trans (mod_le (z / u) u) (by simp) + +instance : Bounded₂ (ext : V → V → V) := + ⟨#1, by intro v; simp⟩ + +@[simp] +lemma ext_lt {u} (z : V) (pos : 0 < u) : ext u z < u := by simp [ext, pos] + +lemma ext_add_of_dvd_sq_right {u z₁ z₂ : V} (pos : 0 < u) (h : u ^ 2 ∣ z₂) : + ext u (z₁ + z₂) = ext u z₁ := by + have : ∃ z', z₂ = z' * u * u := by + rcases h with ⟨u', rfl⟩ + exact ⟨u', by simp [mul_comm _ u', mul_assoc]; simp [sq]⟩ + rcases this with ⟨z₂, rfl⟩ + simp [ext, div_add_mul_self, pos] + +lemma ext_add_of_dvd_sq_left {u z₁ z₂ : V} (pos : 0 < u) (h : u ^ 2 ∣ z₁) : + ext u (z₁ + z₂) = ext u z₂ := by rw [add_comm]; exact ext_add_of_dvd_sq_right pos h + +lemma ext_rem {i j z : V} (ppi : PPow2 i) (ppj : PPow2 j) (hij : i < j) : + ext i (z % j) = ext i z := by + have := div_add_mod z j + have : i^2 ∣ j := ppi.pow2.sq.dvd_of_le ppj.pow2 (PPow2.sq_le_of_lt ppi ppj hij) + calc + ext i (z % j) = ext i (j * (z / j) + (z % j)) := by + symm + exact ext_add_of_dvd_sq_left ppi.pos (Dvd.dvd.mul_right this (z / j)) + _ = ext i z := by simp [div_add_mod] + +/-- The Seq₀ construction in `FFL.FirstOrder.Arithmetic.Exponential`. -/ +def Exponential.Seq₀ (X Y : V) : Prop := + ext 4 X = 1 ∧ ext 4 Y = 2 + +/-- The Even construction in `FFL.FirstOrder.Arithmetic.Exponential.Seqₛ`. -/ +def Exponential.Seqₛ.Even (X Y u : V) : Prop := + ext (u ^ 2) X = 2 * ext u X ∧ ext (u ^ 2) Y = (ext u Y) ^ 2 + +/-- The Odd construction in `FFL.FirstOrder.Arithmetic.Exponential.Seqₛ`. -/ +def Exponential.Seqₛ.Odd (X Y u : V) : Prop := + ext (u ^ 2) X = 2 * ext u X + 1 ∧ ext (u ^ 2) Y = 2 * (ext u Y) ^ 2 + +/-- The Seqₛ construction in `FFL.FirstOrder.Arithmetic.Exponential`. -/ +def Exponential.Seqₛ (y X Y : V) : Prop := + ∀ u ≤ y, u ≠ 2 → PPow2 u → Seqₛ.Even X Y u ∨ Seqₛ.Odd X Y u + +/-- The Seqₘ construction in `FFL.FirstOrder.Arithmetic.Exponential`. -/ +def Exponential.Seqₘ (x y X Y : V) : Prop := + ∃ u ≤ y ^ 2, u ≠ 2 ∧ PPow2 u ∧ ext u X = x ∧ ext u Y = y + +/-- The graph of the exponential function -/ +def Exponential (x y : V) : Prop := + (x = 0 ∧ y = 1) ∨ + ∃ X ≤ y ^ 4, + ∃ Y ≤ y ^ 4, Exponential.Seq₀ X Y ∧ Exponential.Seqₛ y X Y ∧ Exponential.Seqₘ x y X Y + +lemma Exponential.Seqₛ.iff (y X Y : V) : + Exponential.Seqₛ y X Y ↔ + ∀ u ≤ y, + u ≠ 2 → + PPow2 u → + ((∃ ext_u_X ≤ X, ext_u_X = ext u X ∧ 2 * ext_u_X = ext (u ^ 2) X) ∧ + (∃ ext_u_Y ≤ Y, ext_u_Y = ext u Y ∧ ext_u_Y ^ 2 = ext (u ^ 2) Y)) ∨ + ((∃ ext_u_X ≤ X, ext_u_X = ext u X ∧ 2 * ext_u_X + 1 = ext (u ^ 2) X) ∧ + (∃ ext_u_Y ≤ Y, ext_u_Y = ext u Y ∧ 2 * ext_u_Y ^ 2 = ext (u ^ 2) Y)) := + ⟨by + intro H u hu ne2 ppu + rcases H u hu ne2 ppu with (H | H) + · exact Or.inl ⟨⟨ext u X, by simp [H.1]⟩, ⟨ext u Y, by simp [H.2]⟩⟩ + · exact Or.inr ⟨⟨ext u X, by simp [H.1]⟩, ⟨ext u Y, by simp [H.2]⟩⟩, + by + intro H u hu ne2 ppu + rcases H u hu ne2 ppu with + (⟨⟨_, _, rfl, hx⟩, ⟨_, _, rfl, hy⟩⟩ | ⟨⟨_, _, rfl, hx⟩, ⟨_, _, rfl, hy⟩⟩) + · exact Or.inl ⟨by simp [hx], by simp [hy]⟩ + · exact Or.inr ⟨by simp [hx], by simp [hy]⟩⟩ + +/-- The def construction in `FFL.FirstOrder.Arithmetic.Exponential.Seqₛ`. -/ +def Exponential.Seqₛ.def : Σ₀.Semisentence 3 := .mkSigma + “ y X Y. + ∀ u <⁺ y, u ≠ 2 → !ppow2Def u → + ( (∃ ext_u_X <⁺ X, !extDef ext_u_X u X ∧ !extDef (2 * ext_u_X) u² X) ∧ + (∃ ext_u_Y <⁺ Y, !extDef ext_u_Y u Y ∧ !extDef ext_u_Y² u² Y) ) ∨ + ( (∃ ext_u_X <⁺ X, !extDef ext_u_X u X ∧ !extDef (2 * ext_u_X + 1) u² X) ∧ + (∃ ext_u_Y <⁺ Y, !extDef ext_u_Y u Y ∧ !extDef (2 * ext_u_Y²) u² Y) ) ” + +instance Exponential.Seqₛ.defined : Σ₀-Relation₃[V] Exponential.Seqₛ via Exponential.Seqₛ.def := + .mk fun v ↦ by simp [Exponential.Seqₛ.iff, Exponential.Seqₛ.def, sq] + +lemma Exponential.graph_iff (x y : V) : + Exponential x y ↔ + (x = 0 ∧ y = 1) ∨ + ∃ X ≤ y ^ 4, + ∃ Y ≤ y ^ 4, + (1 = ext 4 X ∧ 2 = ext 4 Y) ∧ + Exponential.Seqₛ y X Y ∧ + (∃ u ≤ y ^ 2, u ≠ 2 ∧ PPow2 u ∧ x = ext u X ∧ y = ext u Y) := + ⟨by + rintro (H | ⟨X, bX, Y, bY, H₀, Hₛ, ⟨u, hu, ne2, ppu, hX, hY⟩⟩) + · exact Or.inl H + · exact + Or.inr ⟨X, bX, Y, bY, ⟨H₀.1.symm, H₀.2.symm⟩, Hₛ, ⟨u, hu, ne2, ppu, hX.symm, hY.symm⟩⟩, + by + rintro (H | ⟨X, bX, Y, bY, H₀, Hₛ, ⟨u, hu, ne2, ppu, hX, hY⟩⟩) + · exact Or.inl H + · exact + Or.inr ⟨X, bX, Y, bY, ⟨H₀.1.symm, H₀.2.symm⟩, Hₛ, ⟨u, hu, ne2, ppu, hX.symm, hY.symm⟩⟩⟩ + +/-- The exponential Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.exponentialDef : Σ₀.Semisentence 2 := + .mkSigma + “x y. + (x = 0 ∧ y = 1) ∨ ∃ X <⁺ y⁴, ∃ Y <⁺ y⁴, + (!extDef 1 4 X ∧ !extDef 2 4 Y) ∧ + !Exponential.Seqₛ.def y X Y ∧ + ∃ u <⁺ y², u ≠ 2 ∧ !ppow2Def u ∧ !extDef x u X ∧ !extDef y u Y” + + + +/-- The graph of the exponential function can be defined by the $\Delta_0$-formula. -/ +instance Exponential.defined : Σ₀-Relation[V] Exponential via exponentialDef := + .mk fun v ↦ by simp [Exponential.graph_iff, exponentialDef, pow_four, sq] + +/-- The graph of the exponential function can be defined by the $\Delta_0$-formula. -/ +instance exponential_definable : Σ₀-Relation (Exponential : V → V → Prop) := + Exponential.defined.to_definable + +@[simp] +instance exponential_definable' (Γ) : Γ-Relation (Exponential : V → V → Prop) := + exponential_definable.of_zero + +namespace Exponential + +/-- The seq X₀ construction in `FFL.FirstOrder.Arithmetic.Exponential`. -/ +def seqX₀ : V := + 4 + +/-- The seq Y₀ construction in `FFL.FirstOrder.Arithmetic.Exponential`. -/ +def seqY₀ : V := + 2 * 4 + +lemma one_lt_four : (1 : V) < 4 := + by + rw [← three_add_one_eq_four] + exact lt_add_of_pos_left 1 three_pos + +lemma two_lt_three : (2 : V) < 3 := by rw [← two_add_one_eq_three]; exact lt_add_one 2 + +lemma three_lt_four : (3 : V) < 4 := by rw [← three_add_one_eq_four]; exact lt_add_one 3 + +lemma two_lt_four : (2 : V) < 4 := + lt_trans two_lt_three three_lt_four + +lemma seq₀_zero_two : Seq₀ (seqX₀ : V) (seqY₀ : V) := by + simp [seqX₀, seqY₀, Seq₀, ext, two_lt_four] + +lemma Seq₀.rem {X Y i : V} (h : Seq₀ X Y) (ppi : PPow2 i) (hi : 4 < i) : Seq₀ (X % i) (Y % i) := + by + rw [Seq₀, ext_rem, ext_rem] <;> try simp [ppi, hi] + exact h + +lemma Seqₛ.rem {y y' X Y i : V} (h : Seqₛ y X Y) (ppi : PPow2 i) (hi : y' ^ 2 < i) + (hy : y' ≤ y) : Seqₛ y' (X % i) (Y % i) := + by + intro j hj ne2 ppj + have : j ^ 2 < i := lt_of_le_of_lt (sq_le_sq.mpr hj) hi + have : j < i := lt_of_le_of_lt (le_trans hj <| by simp) hi + rcases h j (le_trans hj hy) ne2 ppj with (H | H) + · left; simpa [Seqₛ.Even, ext_rem, ppj, ppj.sq, ppi, *] using H + · right; simpa [Seqₛ.Odd, ext_rem, ppj, ppj.sq, ppi, *] using H + +lemma seqₛ_one_zero_two : Seqₛ (1 : V) (seqX₀ : V) (seqY₀ : V) := by + intro u leu; rcases le_one_iff_eq_zero_or_one.mp leu with (rfl | rfl) <;> simp + +/-- The append construction in `FFL.FirstOrder.Arithmetic.Exponential`. -/ +noncomputable def append (i X z : V) : V := + X % i + z * i + +lemma append_lt (i X : V) {z} (hz : z < i) : append i X z < i ^ 2 := + calc + append i X z = (X % i) + z * i := rfl + _ < (1 + z) * i := by simpa [add_mul] using mod_lt _ (pos_of_gt hz) + _ ≤ i ^ 2 := by + simpa [sq, add_comm] using mul_le_mul_of_nonneg_right (lt_iff_succ_le.mp hz) (by simp) + +lemma ext_append_last (i X : V) {z} (hz : z < i) : ext i (append i X z) = z := by + simp [ext, append, div_add_mul_self, show 0 < i from pos_of_gt hz, hz] + +lemma ext_append_of_lt {i j : V} (hi : PPow2 i) (hj : PPow2 j) (hij : i < j) (X z : V) : + ext i (append j X z) = ext i X := by + have : i^2 ∣ j := Pow2.dvd_of_le hi.pow2.sq hj.pow2 (PPow2.sq_le_of_lt hi hj hij) + calc + ext i (append j X z) = ext i ((X % j) + z * j) := rfl + _ = ext i (X % j) := ext_add_of_dvd_sq_right hi.pos (Dvd.dvd.mul_left this z) + _ = ext i (j * (X / j) + (X % j)) := by + rw [add_comm] + exact Eq.symm <| ext_add_of_dvd_sq_right hi.pos (Dvd.dvd.mul_right this _) + _ = ext i X := by simp [div_add_mod] + +lemma Seq₀.append {X Y i x y : V} (H : Seq₀ X Y) (ppi : PPow2 i) (hi : 4 < i) : + Seq₀ (append i X x) (append i Y y) := + by + rw [Seq₀, ext_append_of_lt, ext_append_of_lt] <;> try simp [ppi, hi] + exact H + +lemma Seqₛ.append {z x y X Y i : V} (h : Seqₛ z X Y) (ppi : PPow2 i) (hz : z < i) : + Seqₛ z (append (i ^ 2) X x) (append (i ^ 2) Y y) := + by + intro j hj ne2 ppj + have : j < i ^ 2 := lt_of_lt_of_le (lt_of_le_of_lt hj hz) (by simp) + have : j ^ 2 < i ^ 2 := sq_lt_sq.mpr (lt_of_le_of_lt hj hz) + rcases h j hj ne2 ppj with (H | H) + · simp only [Even, Odd] + left; + rw [ext_append_of_lt, ext_append_of_lt, ext_append_of_lt, ext_append_of_lt] <;> + try simp [ppi.sq, ppj.sq, *] + exact H + · simp only [Even, Odd] + right; + rw [ext_append_of_lt, ext_append_of_lt, ext_append_of_lt, ext_append_of_lt] <;> + try simp [ppi.sq, ppj.sq, *] + exact H + +lemma exponential_zero_one : Exponential (0 : V) 1 := + Or.inl (by simp) + +@[simp] +lemma exponential_one_two : Exponential (1 : V) 2 := + Or.inr + ⟨4, by simp [pow_four_eq_sq_sq, two_pow_two_eq_four], 2 * 4, by + simpa [pow_four_eq_sq_sq, two_pow_two_eq_four, sq (4 : V)] using le_of_lt two_lt_four, by + simp [Seq₀, ext, two_lt_four], by + simpa [Seqₛ] using fun i hi ne2 ppi ↦ False.elim <| not_le.mpr (ppi.two_lt ne2) hi, + ⟨4, by simp [two_pow_two_eq_four], by simp, by simp [ext, two_lt_four]⟩⟩ + +lemma pow2_ext_of_seq₀_of_seqₛ {y X Y : V} (h₀ : Exponential.Seq₀ X Y) + (hₛ : Exponential.Seqₛ y X Y) {i} (ne2 : i ≠ 2) (hi : i ≤ y ^ 2) (ppi : PPow2 i) : + Pow2 (ext i Y) := by + induction i using ISigma0.order_induction + · definability + case ind i IH => + by_cases ei : i = 4 + · rcases ei with rfl; simp [h₀.2] + · have ppsq : Pow2 (ext (√i) Y) := + IH (√i) (sqrt_lt_self_of_one_lt ppi.one_lt) (ppi.sqrt_ne_two ne2 ei) + (le_trans (by simp) hi) (ppi.sqrt ne2) + rcases + show Seqₛ.Even X Y (√i) ∨ Seqₛ.Odd X Y (√i) from + hₛ (√i) (sqrt_le_of_le_sq <| hi) (ppi.sqrt_ne_two ne2 ei) (ppi.sqrt ne2) with + (heven | hodd) + · have : ext i Y = (ext (√i) Y) ^ 2 := by simpa [ppi.sq_sqrt_eq ne2] using heven.2 + simp [this, ppsq] + · have : ext i Y = 2 * (ext (√i) Y) ^ 2 := by simpa [ppi.sq_sqrt_eq ne2] using hodd.2 + simp [this, ppsq] + +lemma range_pow2 {x y : V} (h : Exponential x y) : Pow2 y := + by + rcases h with (⟨rfl, rfl⟩ | ⟨X, bX, Y, bY, H₀, Hₛ, ⟨u, hu, ne2, ppu, rfl, rfl⟩⟩) + · simp + · exact pow2_ext_of_seq₀_of_seqₛ H₀ Hₛ ne2 hu ppu + +lemma le_sq_ext_of_seq₀_of_seqₛ {y X Y : V} (h₀ : Exponential.Seq₀ X Y) + (hₛ : Exponential.Seqₛ y X Y) {i} (ne2 : i ≠ 2) (hi : i ≤ y ^ 2) (ppi : PPow2 i) : + i ≤ (ext i Y) ^ 2 := by + induction i using ISigma0.order_induction + · definability + case ind i IH => + by_cases ei : i = 4 + · rcases ei with rfl; simp [h₀.2, two_pow_two_eq_four] + · have IH : √i ≤ (ext (√i) Y) ^ 2 := + IH (√i) (sqrt_lt_self_of_one_lt ppi.one_lt) (ppi.sqrt_ne_two ne2 ei) + (le_trans (by simp) hi) (ppi.sqrt ne2) + rcases + show Seqₛ.Even X Y (√i) ∨ Seqₛ.Odd X Y (√i) from + hₛ (√i) (sqrt_le_of_le_sq <| hi) (ppi.sqrt_ne_two ne2 ei) (ppi.sqrt ne2) with + (heven | hodd) + · have : ext i Y = (ext (√i) Y) ^ 2 := by simpa [ppi.sq_sqrt_eq ne2] using heven.2 + have : √i ≤ ext i Y := by simpa [this] using IH + simpa [ppi.sq_sqrt_eq ne2] using sq_le_sq.mpr this + · have : ext i Y = 2 * (ext (√i) Y) ^ 2 := by simpa [ppi.sq_sqrt_eq ne2] using hodd.2 + have : 2 * √i ≤ ext i Y := by simpa [this] using mul_le_mul_left (a := 2) IH + have : √i ≤ ext i Y := le_trans (le_mul_of_pos_left <| by simp) this + simpa [ppi.sq_sqrt_eq ne2] using sq_le_sq.mpr this + +example {a b c : ℕ} : a * (b * c) = b * (a * c) := by exact Nat.mul_left_comm a b c + +lemma two_mul_ext_le_of_seq₀_of_seqₛ {y X Y : V} (h₀ : Exponential.Seq₀ X Y) (hₛ : + Exponential.Seqₛ y X Y) + {i} (ne2 : i ≠ 2) (hi : i ≤ y ^ 2) (ppi : PPow2 i) : 2 * ext i Y ≤ i := by + induction i using ISigma0.order_induction + · definability + case ind i IH => + by_cases ei : i = 4 + · rcases ei with rfl; simp [h₀.2, two_mul_two_eq_four] + · have IH : 2 * ext (√i) Y ≤ √i := + IH (√i) (sqrt_lt_self_of_one_lt ppi.one_lt) (ppi.sqrt_ne_two ne2 ei) (le_trans (by simp) + hi) (ppi.sqrt ne2) + rcases show Seqₛ.Even X Y (√i) ∨ Seqₛ.Odd X Y (√i) from + hₛ (√i) (sqrt_le_of_le_sq <| hi) (ppi.sqrt_ne_two ne2 ei) (ppi.sqrt ne2) with (heven | hodd) + · have : ext i Y = (ext (√i) Y)^2 := by simpa [ppi.sq_sqrt_eq ne2] using heven.2 + calc + 2 * ext i Y ≤ 2 * (2 * ext i Y) := le_mul_of_pos_left (by simp) + _ = (2 * ext (√i) Y)^2 := by simp [this, sq, mul_left_comm, mul_assoc] + _ ≤ (√i)^2 := sq_le_sq.mpr IH + _ = i := ppi.sq_sqrt_eq ne2 + · have : ext i Y = 2*(ext (√i) Y)^2 := by simpa [ppi.sq_sqrt_eq ne2] using hodd.2 + calc + 2 * ext i Y = (2 * ext (√i) Y)^2 := by simp [this, sq, mul_left_comm, mul_assoc] + _ ≤ (√i)^2 := sq_le_sq.mpr IH + _ = i := ppi.sq_sqrt_eq ne2 + +lemma exponential_exists_sq_of_exponential_even {x y : V} : + Exponential (2 * x) y → ∃ y', y = y' ^ 2 ∧ Exponential x y' := + by + rintro (⟨hx, rfl⟩ | ⟨X, _, Y, _, hseq₀, hseqₛ, i, hi, ne2, ppi, hXx, hYy⟩) + · exact ⟨1, by simp [show x = 0 from by simpa using hx, exponential_zero_one]⟩ + by_cases ne4 : i = 4 + · rcases ne4 with rfl + have ex : 1 = 2 * x := by simpa [hseq₀.1] using hXx + have : (2 : V) ∣ 1 := by rw [ex]; simp + have : ¬(2 : V) ∣ 1 := not_dvd_of_lt (by simp) one_lt_two + contradiction + have : Seqₛ.Even X Y (√i) ∨ Seqₛ.Odd X Y (√i) := + hseqₛ (√i) (sqrt_le_of_le_sq hi) (ppi.sqrt_ne_two ne2 ne4) (ppi.sqrt ne2) + rcases this with (⟨hXi, hYi⟩ | ⟨hXi, _⟩) + · have hXx : x = ext (√i) X := by simpa [ppi.sq_sqrt_eq ne2, hXx] using hXi + have hYy : y = (ext (√i) Y) ^ 2 := by simpa [ppi.sq_sqrt_eq ne2, hYy] using hYi + let X' := X % i + let Y' := Y % i + have bX' : X' ≤ (ext (√i) Y) ^ 4 := by + simpa [pow_four_eq_sq_sq, ← hYy] using le_trans (le_of_lt <| by simp [X', ppi.pos]) hi + have bY' : Y' ≤ (ext (√i) Y) ^ 4 := by + simpa [pow_four_eq_sq_sq, ← hYy] using le_trans (le_of_lt <| by simp [Y', ppi.pos]) hi + have hseqₛ' : Seqₛ (ext (√i) Y) X' Y' := + hseqₛ.rem ppi (sq_lt_of_lt_sqrt <| ext_lt Y (ppi.sqrt ne2).pos) (by simp [hYy]) + have hseqₘ' : Seqₘ x (ext (√i) Y) X' Y' := + ⟨√i, sqrt_le_of_le_sq <| by simp [← hYy, hi], ppi.sqrt_ne_two ne2 ne4, ppi.sqrt ne2, + by + have : √i < i := sqrt_lt_self_of_one_lt ppi.one_lt + simp [X', Y', this, ext_rem, ppi, ppi.sqrt ne2, hXx]⟩ + have : Exponential x (ext (√i) Y) := + Or.inr ⟨X', bX', Y', bY', hseq₀.rem ppi (ppi.four_lt ne2 ne4), hseqₛ', hseqₘ'⟩ + exact ⟨ext (√i) Y, hYy, this⟩ + · have : 2 ∣ ext i X := by simp [hXx] + have : ¬2 ∣ ext i X := by + simp [show ext i X = 2 * ext (√i) X + 1 from by simpa [ppi.sq_sqrt_eq ne2] using hXi, + ← mod_eq_zero_iff_dvd] + contradiction + +lemma bit_zero {x y : V} : Exponential x y → Exponential (2 * x) (y ^ 2) := + by + rintro (⟨hx, rfl⟩ | ⟨X, _, Y, _, hseq₀, hseqₛ, i, hi, ne2, ppi, hXx, hYy⟩) + · rcases hx with rfl; simpa using (exponential_zero_one (V := V)) + have hxsqi : 2 * x < i ^ 2 := + lt_of_lt_of_le (by simp [← hXx, ppi.pos]) (two_mul_le_sq ppi.two_le) + have hysqi : y ^ 2 < i ^ 2 := sq_lt_sq.mpr <| by simp [← hYy, ppi.pos] + have hiisq : i < i ^ 2 := lt_square_of_lt ppi.one_lt + let X' := append (i ^ 2) X (2 * x) + let Y' := append (i ^ 2) Y (y ^ 2) + have bX' : X' ≤ (y ^ 2) ^ 4 := + by + have : X' < i ^ 4 := by simpa [pow_four_eq_sq_sq] using append_lt (i ^ 2) X hxsqi + exact le_trans (le_of_lt this) (pow_le_pow_left' hi 4) + have bY' : Y' ≤ (y ^ 2) ^ 4 := + by + have : Y' < i ^ 4 := by simpa [pow_four_eq_sq_sq] using append_lt (i ^ 2) Y hysqi + exact le_trans (le_of_lt this) (pow_le_pow_left' hi 4) + have hseq₀' : Seq₀ X' Y' := + hseq₀.append ppi.sq (ppi.sq.four_lt ppi.sq_ne_two (ppi.sq_ne_four ne2)) + have hseqₛ' : Seqₛ (y ^ 2) X' Y' := by + intro j hj jne2 ppj + by_cases hjy : j ≤ y + · have : Seqₛ y X' Y' := hseqₛ.append ppi (by simp [← hYy, ppi.pos]) + exact this j hjy jne2 ppj + · have : i = j := + by + have : Pow2 y := by simpa [hYy] using pow2_ext_of_seq₀_of_seqₛ hseq₀ hseqₛ ne2 hi ppi + exact PPow2.sq_uniq this ppi ppj ⟨by simp [← hYy, ppi.pos], hi⟩ ⟨by simpa using hjy, hj⟩ + rcases this with rfl + left + suffices ext (i ^ 2) X' = 2 * ext i X' ∧ ext (i ^ 2) Y' = ext i Y' ^ 2 by + simpa [Seqₛ.Even] + constructor + · calc + ext (i ^ 2) X' = 2 * x := ext_append_last _ _ hxsqi + _ = 2 * ext i X := by simp [hXx] + _ = 2 * ext i X' := by rw [ext_append_of_lt ppi ppi.sq hiisq] + · calc + ext (i ^ 2) Y' = y ^ 2 := ext_append_last _ _ hysqi + _ = ext i Y ^ 2 := by simp [hYy] + _ = ext i Y' ^ 2 := by rw [ext_append_of_lt ppi ppi.sq hiisq] + have hseqₘ' : Seqₘ (2 * x) (y ^ 2) X' Y' := + ⟨i ^ 2, sq_le_sq.mpr hi, ppi.sq_ne_two, ppi.sq, by + rw [ext_append_last, ext_append_last] <;> simp [hxsqi, hysqi]⟩ + exact Or.inr <| ⟨X', bX', Y', bY', hseq₀', hseqₛ', hseqₘ'⟩ + +lemma exponential_even {x y : V} : + Exponential (2 * x) y ↔ ∃ y', y = y' ^ 2 ∧ Exponential x y' := + ⟨exponential_exists_sq_of_exponential_even, by rintro ⟨y, rfl, h⟩; exact bit_zero h⟩ + +lemma exponential_even_sq {x y : V} : Exponential (2 * x) (y ^ 2) ↔ Exponential x y := + ⟨by + intro h + rcases exponential_exists_sq_of_exponential_even h with ⟨y', e, h⟩ + simpa [show y = y' from by simpa using e] using h, bit_zero⟩ + +lemma exponential_exists_sq_of_exponential_odd {x y : V} : + Exponential (2 * x + 1) y → ∃ y', y = 2 * y' ^ 2 ∧ Exponential x y' := + by + rintro (⟨hx, rfl⟩ | ⟨X, _, Y, _, hseq₀, hseqₛ, i, hi, ne2, ppi, hXx, hYy⟩) + · simp at hx + by_cases ne4 : i = 4 + · rcases ne4 with rfl + have ex : x = 0 := by simpa [hseq₀.1] using hXx + have ey : y = 2 := by simpa [hseq₀.2] using Eq.symm hYy + exact ⟨1, by simp [ex, ey, exponential_zero_one]⟩ + have : Seqₛ.Even X Y (√i) ∨ Seqₛ.Odd X Y (√i) := + hseqₛ (√i) (sqrt_le_of_le_sq hi) (ppi.sqrt_ne_two ne2 ne4) (ppi.sqrt ne2) + rcases this with (⟨hXi, _⟩ | ⟨hXi, hYi⟩) + · have hXx : 2 * x + 1 = 2 * ext (√i) X := by simpa [ppi.sq_sqrt_eq ne2, hXx] using hXi + have : 2 ∣ 2 * x + 1 := by rw [hXx]; simp + have : ¬2 ∣ 2 * x + 1 := by simp [← mod_eq_zero_iff_dvd] + contradiction + · have hXx : x = ext (√i) X := by simpa [ppi.sq_sqrt_eq ne2, hXx] using hXi + have hYy : y = 2 * (ext (√i) Y) ^ 2 := by simpa [ppi.sq_sqrt_eq ne2, hYy] using hYi + let X' := X % i + let Y' := Y % i + have bsqi : √i ≤ (ext (√i) Y) ^ 2 := + le_sq_ext_of_seq₀_of_seqₛ hseq₀ hseqₛ (ppi.sqrt_ne_two ne2 ne4) (le_trans (by simp) hi) + (ppi.sqrt ne2) + have bi : i ≤ ext (√i) Y ^ 4 := by + simpa [pow_four_eq_sq_sq, ppi.sq_sqrt_eq ne2] using sq_le_sq.mpr bsqi + have bX' : X' ≤ (ext (√i) Y) ^ 4 := le_trans (le_of_lt <| by simp [X', ppi.pos]) bi + have bY' : Y' ≤ (ext (√i) Y) ^ 4 := le_trans (le_of_lt <| by simp [Y', ppi.pos]) bi + have hseqₛ' : Seqₛ (ext (√i) Y) X' Y' := + hseqₛ.rem ppi (sq_lt_of_lt_sqrt <| ext_lt Y (ppi.sqrt ne2).pos) + (le_trans (le_sq _) (by simp [hYy])) + have hseqₘ' : Seqₘ x (ext (√i) Y) X' Y' := + ⟨√i, bsqi, ppi.sqrt_ne_two ne2 ne4, ppi.sqrt ne2, + by + have : √i < i := sqrt_lt_self_of_one_lt ppi.one_lt + simp [X', Y', this, ext_rem, ppi, ppi.sqrt ne2, hXx]⟩ + have : Exponential x (ext (√i) Y) := + Or.inr ⟨X', bX', Y', bY', hseq₀.rem ppi (ppi.four_lt ne2 ne4), hseqₛ', hseqₘ'⟩ + exact ⟨ext (√i) Y, hYy, this⟩ + +lemma bit_one {x y : V} : Exponential x y → Exponential (2 * x + 1) (2 * y ^ 2) := by + rintro (⟨hx, rfl⟩ | ⟨X, _, Y, _, hseq₀, hseqₛ, i, hi, ne2, ppi, hXx, hYy⟩) + · rcases hx with rfl; simp + have hxsqi : 2 * x + 1 < i ^ 2 := calc + 2 * x + 1 < 2 * i + 1 := by simp [←hXx, ppi.pos] + _ ≤ i ^ 2 := lt_iff_succ_le.mp (two_mul_lt_sq <| ppi.two_lt ne2) + have hysqi : 2 * y ^ 2 < i ^ 2 := by + have : 2 * ext i Y ≤ i := two_mul_ext_le_of_seq₀_of_seqₛ hseq₀ hseqₛ ne2 hi ppi + suffices 2 * (2 * y ^ 2) < 2 * i ^ 2 from lt_of_mul_lt_mul_left this + calc + 2 * (2 * y ^ 2) = (2 * y)^2 := by simp [sq, mul_assoc, mul_left_comm y 2] + _ ≤ i^2 := sq_le_sq.mpr (by simpa [hYy] using this) + _ < 2 * i^2 := lt_mul_of_one_lt_left ppi.sq.pos one_lt_two + have hiisq : i < i^2 := lt_square_of_lt ppi.one_lt + let X' := append (i^2) X (2 * x + 1) + let Y' := append (i^2) Y (2 * (y ^ 2)) + have bX' : X' ≤ (2 * y ^ 2)^4 := by + have : X' < i^4 := by simpa [pow_four_eq_sq_sq] using append_lt (i^2) X hxsqi + exact le_trans (le_of_lt this) (pow_le_pow_left' (le_trans hi <| by simp) 4) + have bY' : Y' ≤ (2 * y ^ 2)^4 := by + have : Y' < i^4 := by simpa [pow_four_eq_sq_sq] using append_lt (i^2) Y hysqi + exact le_trans (le_of_lt this) (pow_le_pow_left' (le_trans hi <| by simp) 4) + have hseq₀' : Seq₀ X' Y' := hseq₀.append ppi.sq (ppi.sq.four_lt ppi.sq_ne_two (ppi.sq_ne_four + ne2)) + have hseqₛ' : Seqₛ (2 * y ^ 2) X' Y' := by + intro j hj jne2 ppj + by_cases hjy : j ≤ y + · have : Seqₛ y X' Y' := hseqₛ.append ppi (by simp [←hYy, ppi.pos]) + exact this j hjy jne2 ppj + · have : i = j := by + have : Pow2 y := by simpa [hYy] using pow2_ext_of_seq₀_of_seqₛ hseq₀ hseqₛ ne2 hi ppi + exact PPow2.two_mul_sq_uniq this ppi ppj + ⟨by simp [←hYy, ppi.pos], le_trans hi (by simp)⟩ ⟨by simpa using hjy, hj⟩ + rcases this with rfl + right + suffices ext (i ^ 2) X' = 2 * ext i X' + 1 ∧ ext (i ^ 2) Y' = 2 * ext i Y' ^ 2 by simpa + [Seqₛ.Odd] + constructor + · calc + ext (i ^ 2) X' = 2 * x + 1 := ext_append_last _ _ hxsqi + _ = 2 * ext i X + 1 := by simp [hXx] + _ = 2 * ext i X' + 1 := by rw [ext_append_of_lt ppi ppi.sq hiisq] + · calc + ext (i ^ 2) Y' = 2 * y ^ 2 := ext_append_last _ _ hysqi + _ = 2 * ext i Y ^ 2 := by simp [hYy] + _ = 2 * ext i Y' ^ 2 := by rw [ext_append_of_lt ppi ppi.sq hiisq] + have hseqₘ' : Seqₘ (2 * x + 1) (2 * y ^ 2) X' Y' := + ⟨i ^ 2, sq_le_sq.mpr (le_trans hi <| by simp), ppi.sq_ne_two, ppi.sq, + by rw [ext_append_last, ext_append_last] <;> try simp [hxsqi, hysqi]⟩ + exact Or.inr <| ⟨X', bX', Y', bY', hseq₀', hseqₛ', hseqₘ'⟩ + +lemma exponential_odd {x y : V} : + Exponential (2 * x + 1) y ↔ ∃ y', y = 2 * y' ^ 2 ∧ Exponential x y' := + ⟨exponential_exists_sq_of_exponential_odd, by rintro ⟨y, rfl, h⟩; exact bit_one h⟩ + +lemma exponential_odd_two_mul_sq {x y : V} : + Exponential (2 * x + 1) (2 * y ^ 2) ↔ Exponential x y := + ⟨by + intro h + rcases exponential_exists_sq_of_exponential_odd h with ⟨y', e, h⟩ + simpa [show y = y' from by simpa using e] using h, bit_one⟩ + +lemma two_le_ext_of_seq₀_of_seqₛ {y X Y : V} (h₀ : Exponential.Seq₀ X Y) + (hₛ : Exponential.Seqₛ y X Y) {i} (ne2 : i ≠ 2) (hi : i ≤ y ^ 2) (ppi : PPow2 i) : + 2 ≤ ext i Y := by + induction i using ISigma0.order_induction + · definability + case ind i IH => + by_cases ei : i = 4 + · rcases ei with rfl; simp [h₀.2] + · have IH : 2 ≤ ext (√i) Y := + IH (√i) (sqrt_lt_self_of_one_lt ppi.one_lt) (ppi.sqrt_ne_two ne2 ei) + (le_trans (by simp) hi) (ppi.sqrt ne2) + rcases + show Seqₛ.Even X Y (√i) ∨ Seqₛ.Odd X Y (√i) from + hₛ (√i) (sqrt_le_of_le_sq <| hi) (ppi.sqrt_ne_two ne2 ei) (ppi.sqrt ne2) with + (heven | hodd) + · calc + 2 ≤ ext (√i) Y := IH + _ ≤ (ext (√i) Y) ^ 2 := by simp + _ = ext i Y := by simpa [ppi.sq_sqrt_eq ne2] using Eq.symm heven.2 + · calc + 2 ≤ ext (√i) Y := IH + _ ≤ (ext (√i) Y) ^ 2 := by simp + _ ≤ 2 * (ext (√i) Y) ^ 2 := by simp + _ = ext i Y := by simpa [ppi.sq_sqrt_eq ne2] using Eq.symm hodd.2 + +lemma ext_le_ext_of_seq₀_of_seqₛ {y X Y : V} (h₀ : Exponential.Seq₀ X Y) (hₛ : Exponential.Seqₛ + y X Y) + {i} (ne2 : i ≠ 2) (hi : i ≤ y ^ 2) (ppi : PPow2 i) : ext i X < ext i Y := by + induction i using ISigma0.order_induction + · definability + case ind i IH => + by_cases ne4 : i = 4 + · rcases ne4 with rfl; simp [h₀.1, h₀.2] + · have IH : ext (√i) X < ext (√i) Y := + IH (√i) (sqrt_lt_self_of_one_lt ppi.one_lt) (ppi.sqrt_ne_two ne2 ne4) (le_trans (by + simp) hi) (ppi.sqrt ne2) + have twole : 2 ≤ ext (√i) Y := two_le_ext_of_seq₀_of_seqₛ h₀ hₛ (ppi.sqrt_ne_two ne2 ne4) + (le_trans (by simp) hi) (ppi.sqrt ne2) + rcases show Seqₛ.Even X Y (√i) ∨ Seqₛ.Odd X Y (√i) from + hₛ (√i) (sqrt_le_of_le_sq <| hi) (ppi.sqrt_ne_two ne2 ne4) (ppi.sqrt ne2) with (heven | + hodd) + · calc + ext i X = 2 * ext (√i) X := by simpa [ppi.sq_sqrt_eq ne2] using heven.1 + _ < 2 * ext (√i) Y := by simpa using IH + _ ≤ ext (√i) Y^2 := two_mul_le_sq twole + _ = ext i Y := by simpa [ppi.sq_sqrt_eq ne2] using Eq.symm heven.2 + · calc + ext i X = 2 * ext (√i) X + 1 := by simpa [ppi.sq_sqrt_eq ne2] using hodd.1 + _ < 2 * ext (√i) Y + 1 := by simpa using IH + _ ≤ 2 * ext (√i) Y^2 := + lt_iff_succ_le.mp <| (mul_lt_mul_iff_right₀ <| by simp).mpr + <| lt_self_pow₀ (one_lt_iff_two_le.mpr twole) (by simp) + _ = ext i Y := by simpa [ppi.sq_sqrt_eq ne2] using Eq.symm hodd.2 + +lemma range_pos {x y : V} (h : Exponential x y) : 0 < y := + by + rcases h with (⟨rfl, rfl⟩ | ⟨X, bX, Y, bY, H₀, Hₛ, ⟨u, hu, ne2, ppu, rfl, rfl⟩⟩) + · simp + · have : 2 ≤ ext u Y := two_le_ext_of_seq₀_of_seqₛ H₀ Hₛ ne2 hu ppu + exact lt_of_lt_of_le (by simp) this + +lemma lt {x y : V} (h : Exponential x y) : x < y := + by + rcases h with (⟨rfl, rfl⟩ | ⟨X, bX, Y, bY, H₀, Hₛ, ⟨u, hu, ne2, ppu, rfl, rfl⟩⟩) + · simp + · exact ext_le_ext_of_seq₀_of_seqₛ H₀ Hₛ ne2 hu ppu + +lemma not_exponential_of_le {x y : V} (h : x ≤ y) : ¬Exponential y x := by + intro hxy; exact not_le.mpr (lt hxy) h + +@[simp] +lemma one_not_even (a : V) : 1 ≠ 2 * a := by + intro h + have : (2 : V) ∣ 1 := by rw [h]; simp + have : ¬(2 : V) ∣ 1 := not_dvd_of_lt (by simp) one_lt_two + contradiction + +@[simp] +lemma exponential_two_four : Exponential (2 : V) 4 := by + simpa [two_pow_two_eq_four] using (show Exponential (1 : V) 2 from by simp).bit_zero + +lemma exponential_succ {x y : V} : Exponential (x + 1) y ↔ ∃ z, y = 2 * z ∧ Exponential x z := by + suffices x < y → (Exponential (x + 1) y ↔ ∃ z ≤ y, y = 2 * z ∧ Exponential x z) by + by_cases hxy : x < y + · simp only [this hxy] + exact ⟨by rintro ⟨z, _, rfl, hz⟩; exact ⟨z, rfl, hz⟩, + by rintro ⟨z, rfl, hz⟩; exact ⟨z, by simpa using hz⟩⟩ + · suffices ∀ z, y = 2 * z → ¬Exponential x z by + simpa [not_exponential_of_le (show y ≤ x + 1 from le_add_right (by simpa using hxy))] + rintro z rfl + exact not_exponential_of_le (le_trans le_two_mul_left <| by simpa using hxy) + · revert x + induction y using ISigma0.order_induction + · definability + case ind y IH => + intro x hxy + rcases even_or_odd x with ⟨x, (rfl | rfl)⟩ + · constructor + · intro H + rcases exponential_odd.mp H with ⟨y, rfl, H'⟩ + exact ⟨y ^ 2, by simp, rfl, H'.bit_zero⟩ + · rintro ⟨y, hy, rfl, H⟩ + rcases exponential_even.mp H with ⟨y, rfl, H'⟩ + exact H'.bit_one + · constructor + · intro H + have : Exponential (2 * (x + 1)) y := by simpa [mul_add, add_assoc, + one_add_one_eq_two] using H + rcases exponential_even.mp this with ⟨y, rfl, H'⟩ + have : 1 < y := by + simpa using (show 1 < y ^ 2 from lt_of_le_of_lt (by simp) hxy) + have : Exponential (x + 1) y ↔ ∃ z ≤ y, y = 2 * z ∧ Exponential x z := + IH y (lt_square_of_lt <| this) (lt_trans (by simp) H'.lt) + rcases this.mp H' with ⟨y, _, rfl, H''⟩ + exact ⟨2 * y ^ 2, by simp [sq, mul_assoc, mul_left_comm y 2], + by simp [sq, mul_assoc, mul_left_comm y 2], H''.bit_one⟩ + · rintro ⟨y, _, rfl, H⟩ + rcases exponential_odd.mp H with ⟨y, rfl, H'⟩ + by_cases ne1 : y = 1 + · rcases ne1 with rfl + rcases (show x = 0 from by simpa using H'.lt) + simp [one_add_one_eq_two, two_mul_two_eq_four] + have : y < y ^ 2 := lt_square_of_lt <| one_lt_iff_two_le.mpr <| H'.range_pow2.two_le ne1 + have : Exponential (x + 1) (2 * y) ↔ ∃ z ≤ 2 * y, 2 * y = 2 * z ∧ Exponential x z := + IH (2 * y) (by simpa using lt_of_lt_of_le this le_two_mul_left) + (lt_of_lt_of_le H'.lt <| by simp) + have : Exponential (x + 1) (2 * y) := this.mpr ⟨y, by simp, rfl, H'⟩ + simpa [sq, mul_add, add_assoc, mul_assoc, one_add_one_eq_two, mul_left_comm y 2] using + this.bit_zero + +lemma exponential_succ_mul_two {x y : V} : Exponential (x + 1) (2 * y) ↔ Exponential x y := + ⟨by intro h; rcases exponential_succ.mp h with ⟨y', e, h⟩; simpa [show y = y' from by simpa + using e] using h, + by intro h; exact exponential_succ.mpr ⟨y, rfl, h⟩⟩ + +alias ⟨of_succ_two_mul, succ⟩ := exponential_succ_mul_two + +lemma one_le_ext_of_seq₀_of_seqₛ {y X Y : V} (h₀ : Exponential.Seq₀ X Y) + (hₛ : Exponential.Seqₛ y X Y) {i} (ne2 : i ≠ 2) (hi : i ≤ y ^ 2) (ppi : PPow2 i) : + 1 ≤ ext i X := by + induction i using ISigma0.order_induction + · definability + case ind i IH => + by_cases ne4 : i = 4 + · rcases ne4 with rfl; simp [h₀.1] + · have IH : 1 ≤ ext (√i) X := + IH (√i) (sqrt_lt_self_of_one_lt ppi.one_lt) (ppi.sqrt_ne_two ne2 ne4) + (le_trans (by simp) hi) (ppi.sqrt ne2) + rcases + show Seqₛ.Even X Y (√i) ∨ Seqₛ.Odd X Y (√i) from + hₛ (√i) (sqrt_le_of_le_sq <| hi) (ppi.sqrt_ne_two ne2 ne4) (ppi.sqrt ne2) with + (heven | hodd) + · have : ext i X = 2 * ext (√i) X := by simpa [ppi.sq_sqrt_eq ne2] using heven.1 + exact le_trans IH (by simp [this]) + · have : ext i X = 2 * ext (√i) X + 1 := by simpa [ppi.sq_sqrt_eq ne2] using hodd.1 + simp [this] + +lemma zero_uniq {y : V} (h : Exponential 0 y) : y = 1 := + by + rcases h with (⟨_, rfl⟩ | ⟨X, _, Y, _, H₀, Hₛ, ⟨u, hu, ne2, ppu, hX, _⟩⟩) + · rfl + · have : 1 ≤ ext u X := one_le_ext_of_seq₀_of_seqₛ H₀ Hₛ ne2 hu ppu + simp [hX] at this + +@[simp] +lemma zero_uniq_iff {y : V} : Exponential 0 y ↔ y = 1 := + ⟨zero_uniq, by rintro rfl; exact exponential_zero_one⟩ + +lemma succ_lt_s {y : V} (h : Exponential (x + 1) y) : 2 ≤ y := + by + rcases h with (⟨h, rfl⟩ | ⟨X, _, Y, _, H₀, Hₛ, ⟨u, hu, ne2, ppu, _, hY⟩⟩) + · simp at h + · simpa [hY] using two_le_ext_of_seq₀_of_seqₛ H₀ Hₛ ne2 hu ppu + +protected lemma uniq {x y₁ y₂ : V} : Exponential x y₁ → Exponential x y₂ → y₁ = y₂ := + by + intro h₁ h₂ + wlog h : y₁ ≤ y₂ + · exact Eq.symm <| this h₂ h₁ (show y₂ ≤ y₁ from le_of_not_ge h) + revert x h y₁ + suffices ∀ x < y₂, ∀ y₁ ≤ y₂, Exponential x y₁ → Exponential x y₂ → y₁ = y₂ by + intro x y₁ h₁ h₂ hy; exact this x h₂.lt y₁ hy h₁ h₂ + induction y₂ using ISigma0.order_induction + · definability + case ind y₂ IH => + intro x _ y₁ h h₁ h₂ + rcases zero_or_succ x with (rfl | ⟨x, rfl⟩) + · simp [h₁.zero_uniq, h₂.zero_uniq] + · rcases exponential_succ.mp h₁ with ⟨y₁, rfl, h₁'⟩ + rcases exponential_succ.mp h₂ with ⟨y₂, rfl, h₂'⟩ + have : y₁ = y₂ := + IH y₂ (lt_mul_of_pos_of_one_lt_left h₂'.range_pos one_lt_two) x h₂'.lt y₁ + (by simpa using h) h₁' h₂' + simp [this] + +protected lemma inj {x₁ x₂ y : V} : Exponential x₁ y → Exponential x₂ y → x₁ = x₂ := + by + intro h₁ h₂ + revert x₁ x₂ h₁ h₂ + suffices ∀ x₁ < y, ∀ x₂ < y, Exponential x₁ y → Exponential x₂ y → x₁ = x₂ by + intro x₁ x₂ h₁ h₂; exact this x₁ h₁.lt x₂ h₂.lt h₁ h₂ + induction y using ISigma0.order_induction + · definability + case ind y IH => + intro x₁ _ x₂ _ h₁ h₂ + rcases zero_or_succ x₁ with (rfl | ⟨x₁, rfl⟩) <;> + rcases zero_or_succ x₂ with (rfl | ⟨x₂, rfl⟩) + · rfl + · rcases h₁.zero_uniq + rcases exponential_succ.mp h₂ with ⟨z, hz⟩ + simp at hz + · rcases h₂.zero_uniq + rcases exponential_succ.mp h₁ with ⟨z, hz⟩ + simp at hz + · rcases exponential_succ.mp h₁ with ⟨y, rfl, hy₁⟩ + have hy₂ : Exponential x₂ y := h₂.of_succ_two_mul + have : x₁ = x₂ := + IH y (lt_mul_of_pos_of_one_lt_left hy₁.range_pos one_lt_two) x₁ hy₁.lt x₂ hy₂.lt hy₁ hy₂ + simp [this] + +lemma exponential_elim {x y : V} : + Exponential x y ↔ + (x = 0 ∧ y = 1) ∨ ∃ x', ∃ y', x = x' + 1 ∧ y = 2 * y' ∧ Exponential x' y' := + ⟨by + intro h + rcases zero_or_succ x with (rfl | ⟨x', rfl⟩) + · simp [h.zero_uniq] + · right; rcases exponential_succ.mp h with ⟨y', rfl, H⟩ + exact ⟨x', y', rfl, rfl, H⟩, + by + rintro (⟨rfl, rfl⟩ | ⟨x, y, rfl, rfl, h⟩) + · simp + · exact h.succ⟩ + +lemma monotone {x₁ x₂ y₁ y₂ : V} : Exponential x₁ y₁ → Exponential x₂ y₂ → x₁ < x₂ → y₁ < y₂ := + by + suffices ∀ x₁ < y₁, ∀ y₂ ≤ y₁, ∀ x₂ < y₂, Exponential x₁ y₁ → Exponential x₂ y₂ → x₂ ≤ x₁ + by + intro h₁ h₂ + suffices y₂ ≤ y₁ → x₂ ≤ x₁ by contrapose; simpa + intro hy + exact this x₁ h₁.lt y₂ hy x₂ h₂.lt h₁ h₂ + induction y₁ using ISigma0.order_induction + · definability + case ind y₁ IH => + intro x₁ _ y₂ hy x₂ _ h₁ h₂ + rcases zero_or_succ x₁ with (rfl | ⟨x₁, rfl⟩) <;> + rcases zero_or_succ x₂ with (rfl | ⟨x₂, rfl⟩) + · simp + · rcases show y₁ = 1 from h₁.zero_uniq + rcases le_one_iff_eq_zero_or_one.mp hy with (rfl | rfl) + · have := h₂.range_pos; simp at this + · exact False.elim <| not_lt.mpr h₂.succ_lt_s one_lt_two + · simp + · rcases exponential_succ.mp h₁ with ⟨y₁, rfl, h₁'⟩ + rcases exponential_succ.mp h₂ with ⟨y₂, rfl, h₂'⟩ + have : x₂ ≤ x₁ := + IH y₁ (lt_mul_of_pos_of_one_lt_left h₁'.range_pos one_lt_two) x₁ h₁'.lt y₂ + (le_of_mul_le_mul_left hy (by simp)) x₂ h₂'.lt h₁' h₂' + simpa using this + +lemma monotone_le {x₁ x₂ y₁ y₂ : V} (h₁ : Exponential x₁ y₁) (h₂ : Exponential x₂ y₂) : + x₁ ≤ x₂ → y₁ ≤ y₂ := by + rintro (rfl | h) + · exact (h₁.uniq h₂).le + · exact le_of_lt (monotone h₁ h₂ h) + +lemma monotone_iff {x₁ x₂ y₁ y₂ : V} (h₁ : Exponential x₁ y₁) (h₂ : Exponential x₂ y₂) : + x₁ < x₂ ↔ y₁ < y₂ := by + constructor + · exact monotone h₁ h₂ + · contrapose; simpa using monotone_le h₂ h₁ + +lemma monotone_le_iff {x₁ x₂ y₁ y₂ : V} (h₁ : Exponential x₁ y₁) (h₂ : Exponential x₂ y₂) : + x₁ ≤ x₂ ↔ y₁ ≤ y₂ := by + constructor + · exact monotone_le h₁ h₂ + · contrapose; simpa using monotone h₂ h₁ + +lemma add_mul {x₁ x₂ y₁ y₂ : V} (h₁ : Exponential x₁ y₁) (h₂ : Exponential x₂ y₂) : Exponential + (x₁ + x₂) (y₁ * y₂) := by + wlog hy : y₁ ≥ y₂ + · simpa [add_comm, mul_comm] using this h₂ h₁ (le_of_not_ge hy) + revert y₂ + suffices ∀ y₂ ≤ y₁, Exponential x₂ y₂ → Exponential (x₁ + x₂) (y₁ * y₂) by + intro y₂ h₂ hy; exact this y₂ hy h₂ + induction x₂ using ISigma0.succ_induction + · definability + case zero => + intro y₂ _ h₂ + simpa [show y₂ = 1 from h₂.zero_uniq] using h₁ + case succ x₂ IH => + intro y₂ hy h₂ + rcases exponential_succ.mp h₂ with ⟨y₂, rfl, H₂⟩ + have : Exponential (x₁ + x₂) (y₁ * y₂) := IH y₂ (le_trans (by simp) hy) H₂ + simpa [←add_assoc, mul_left_comm y₁ 2 y₂] using this.succ + +end Exponential + +end ISigma0 + +section ISigma1 + +variable [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +namespace Exponential + +/-- The exponential function is proved to be total in $\mathsf I Σ_1$. -/ +lemma range_exists (x : V) : ∃ y, Exponential x y := + by + induction x using ISigma1.sigma1_succ_induction + · definability + case zero => exact ⟨1, by simp⟩ + case succ x IH => + rcases IH with ⟨y, IH⟩ + exact ⟨2 * y, IH.succ⟩ + +lemma range_exists_unique (x : V) : ∃! y, Exponential x y := + by + rcases range_exists x with ⟨y, h⟩ + exact ExistsUnique.intro y h (by intro y' h'; exact h'.uniq h) + +end Exponential + +noncomputable instance : Exp V := + ⟨fun a ↦ Classical.chooseUnique (Exponential.range_exists_unique a)⟩ + +section exponential + +lemma exponential_exp (a : V) : Exponential a (Exp.exp a) := + Classical.chooseUnique_spec (Exponential.range_exists_unique a) + +lemma exponential_graph {a b : V} : a = Exp.exp b ↔ Exponential b a := + Classical.chooseUnique_eq_iff_right _ + +/-- The exp Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.expDef : Σ₀.Semisentence 2 := .mkSigma + “x y. !exponentialDef.val y x” + + + +instance exp_defined_deltaZero : Σ₀-Function₁[V] Exp.exp via expDef := + .mk fun v ↦ by simp [expDef, exponential_graph] + +instance exp_definable_deltaZero : Σ₀-Function₁ (Exp.exp : V → V) := + exp_defined_deltaZero.to_definable + +lemma exp_of_exponential {a b : V} (h : Exponential a b) : Exp.exp a = b := + Eq.symm <| exponential_graph.mpr h + +lemma exp_inj : Function.Injective (Exp.exp : V → V) := fun a _ H ↦ + (exponential_exp a).inj (exponential_graph.mp H) + +@[simp] +lemma exp_zero : Exp.exp (0 : V) = 1 := + exp_of_exponential (by simp) + +@[simp] +lemma exp_one : Exp.exp (1 : V) = 2 := + exp_of_exponential (by simp) + +lemma exp_succ (a : V) : Exp.exp (a + 1) = 2 * Exp.exp a := + exp_of_exponential <| Exponential.exponential_succ_mul_two.mpr <| exponential_exp a + +lemma exp_even (a : V) : Exp.exp (2 * a) = (Exp.exp a) ^ 2 := + exp_of_exponential <| Exponential.exponential_even_sq.mpr <| exponential_exp a + +@[simp] +lemma lt_exp (a : V) : a < Exp.exp a := + (exponential_exp a).lt + +@[simp] +lemma exp_pos (a : V) : 0 < Exp.exp a := + (exponential_exp a).range_pos + +@[simp] +lemma one_le_exp (a : V) : 1 ≤ Exp.exp a := + pos_iff_one_le.mp (by simp) + +@[simp] +lemma exp_pow2 (a : V) : Pow2 (Exp.exp a) := + (exponential_exp a).range_pow2 + +@[simp] +lemma exp_monotone {a b : V} : Exp.exp a < Exp.exp b ↔ a < b := + Iff.symm <| Exponential.monotone_iff (exponential_exp a) (exponential_exp b) + +@[simp] +lemma exp_monotone_le {a b : V} : Exp.exp a ≤ Exp.exp b ↔ a ≤ b := + Iff.symm <| Exponential.monotone_le_iff (exponential_exp a) (exponential_exp b) + +lemma nat_cast_exp (n : ℕ) : (Exp.exp n : ℕ) = Exp.exp (n : V) := by + induction n with + | zero => simp + | succ n + ih => + have htwo : ((2 : ℕ) : V) = 2 := + (numeral_eq_natCast_app (M := V) 2).symm.trans numeral_two_eq_two + simp only [exp_succ, Nat.cast_mul, ih, Nat.cast_add, Nat.cast_one, mul_eq_mul_right_iff] + exact Or.inl htwo + +end exponential + +lemma exp_nat_eq_two_pow (n : ℕ) : Exp.exp n = 2 ^ n := by + induction n with + | zero => simp + | succ n ih => grind [exp_succ] + +end ISigma1 + +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Exponential/Log.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Exponential/Log.lean new file mode 100644 index 000000000..9c090a4fe --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Exponential/Log.lean @@ -0,0 +1,650 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Exponential.Exp + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +/-! +# Logarithmic function +-/ + +namespace FFL +namespace FirstOrder +namespace Arithmetic + +variable {V : Type*} [ORingStructure V] + +section ISigma0 + +variable [V↓[ℒₒᵣ] ⊧* 𝐈Σ₀] + +lemma log_exists_unique_pos {y : V} (hy : 0 < y) : + ∃! x, x < y ∧ ∃ y' ≤ y, Exponential x y' ∧ y < 2 * y' := + by + have : ∃ x < y, ∃ y' ≤ y, Exponential x y' ∧ y < 2 * y' := + by + induction y using sigma0_polynomial_induction + · definability + case zero => simp at hy + case even y _ + IH => + rcases (IH (by simpa using hy) : ∃ x < y, ∃ y' ≤ y, Exponential x y' ∧ y < 2 * y') with + ⟨x, hxy, y', gey, H, lty⟩ + exact + ⟨x + 1, lt_of_lt_of_le (by simp [hxy]) (succ_le_double_of_pos (pos_of_gt hxy)), 2 * y', + by simpa using gey, Exponential.exponential_succ_mul_two.mpr H, by simpa using lty⟩ + case odd y IH => + rcases (Arithmetic.zero_le y : 0 ≤ y) with (rfl | pos) + · simp + · rcases (IH pos : ∃ x < y, ∃ y' ≤ y, Exponential x y' ∧ y < 2 * y') with + ⟨x, hxy, y', gey, H, lty⟩ + exact + ⟨x + 1, by simpa using lt_of_lt_of_le hxy (by simp), 2 * y', + le_trans (by simpa using gey) le_self_add, + Exponential.exponential_succ_mul_two.mpr H, two_mul_add_one_lt_two_mul_of_lt lty⟩ + rcases this with ⟨x, hx⟩ + exact + ExistsUnique.intro x hx + (fun x' ↦ by + intro hx' + by_contra A + wlog lt : x < x' + · exact this hy x' hx' x hx (Ne.symm A) (lt_of_le_of_ne (by simpa using lt) A) + rcases hx with ⟨_, z, _, H, hyz⟩ + rcases hx' with ⟨_, z', hzy', H', _⟩ + have : z < z' := Exponential.monotone H H' lt + have : y < y := + calc + y < 2 * z := hyz + _ ≤ z' := ((Pow2.lt_iff_two_mul_le H.range_pow2 H'.range_pow2).mp this) + _ ≤ y := hzy' + simp at this) + +lemma log_exists_unique (y : V) : + ∃! x, (y = 0 → x = 0) ∧ (0 < y → x < y ∧ ∃ y' ≤ y, Exponential x y' ∧ y < 2 * y') := + by + by_cases hy : y = 0 + · rcases hy; simp + · simp [hy, pos_iff_ne_zero.mpr hy, log_exists_unique_pos] + +/-- The log construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def log (a : V) : V := + Classical.chooseUnique (log_exists_unique a) + +@[simp] +lemma log_zero : log (0 : V) = 0 := + (Classical.chooseUnique_spec (log_exists_unique (0 : V))).1 rfl + +lemma log_pos {y : V} (pos : 0 < y) : ∃ y' ≤ y, Exponential (log y) y' ∧ y < 2 * y' := + ((Classical.chooseUnique_spec (log_exists_unique y)).2 pos).2 + +lemma log_lt_self_of_pos {y : V} (pos : 0 < y) : log y < y := + ((Classical.chooseUnique_spec (log_exists_unique y)).2 pos).1 + +@[simp] +lemma log_le_self (a : V) : log a ≤ a := + by + rcases Arithmetic.zero_le a with (rfl | pos) + · simp + · exact le_of_lt <| log_lt_self_of_pos pos + +lemma log_graph {x y : V} : + x = log y ↔ (y = 0 → x = 0) ∧ (0 < y → x < y ∧ ∃ y' ≤ y, Exponential x y' ∧ y < 2 * y') := + Classical.chooseUnique_eq_iff_right _ + +/-- The log Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.logDef : Σ₀.Semisentence 2 := + .mkSigma + (“x y. (y = 0 → x = 0) ∧ (0 < y → x < y ∧ ∃ y' <⁺ y, !exponentialDef x y' ∧ y < 2 * y')”) + +instance log_defined : Σ₀-Function₁[V] log via logDef := + .mk fun v ↦ by simp [logDef, log_graph] + +instance log_definable : Σ₀-Function₁ (log : V → V) := + log_defined.to_definable + +instance : Bounded₁ (log : V → V) := + ⟨#0, fun _ ↦ by simp⟩ + +lemma log_eq_of_pos {x y : V} (pos : 0 < y) {y'} (H : Exponential x y') (hy' : y' ≤ y) + (hy : y < 2 * y') : log y = x := + (log_exists_unique_pos pos).unique ⟨log_lt_self_of_pos pos, log_pos pos⟩ + ⟨lt_of_lt_of_le H.lt hy', y', hy', H, hy⟩ + +@[simp] +lemma log_one : log (1 : V) = 0 := + log_eq_of_pos (by simp) (y' := 1) (by simp) (by rfl) (by simp) + +@[simp] +lemma log_two : log (2 : V) = 1 := + log_eq_of_pos (by simp) (y' := 2) (by simp) (by rfl) (by simp) + +lemma log_two_mul_of_pos {y : V} (pos : 0 < y) : log (2 * y) = log y + 1 := + by + rcases log_pos pos with ⟨y', hy', H, hy⟩ + exact + log_eq_of_pos (by simpa using pos) (Exponential.exponential_succ_mul_two.mpr H) + (by simpa using hy') (by simpa using hy) + +lemma log_two_mul_add_one_of_pos {y : V} (pos : 0 < y) : log (2 * y + 1) = log y + 1 := + by + rcases log_pos pos with ⟨y', hy', H, hy⟩ + exact + log_eq_of_pos (by simp) (Exponential.exponential_succ_mul_two.mpr H) + (le_trans (by simpa using hy') le_self_add) (two_mul_add_one_lt_two_mul_of_lt hy) + +lemma Exponential.log_eq_of_exp {x y : V} (H : Exponential x y) : log y = x := + log_eq_of_pos H.range_pos H + (by { rfl + }) + (lt_mul_of_pos_of_one_lt_left H.range_pos one_lt_two) + +lemma exponential_of_pow2 {p : V} (pp : Pow2 p) : Exponential (log p) p := + by + rcases log_pos pp.pos with ⟨q, hq, H, hp⟩ + suffices p = q by simpa [this] using H + by_contra ne + have : q < p := lt_of_le_of_ne hq (Ne.symm ne) + have : 2 * q < 2 * q := + calc + 2 * q ≤ p := (Pow2.lt_iff_two_mul_le H.range_pow2 pp).mp this + _ < 2 * q := hp + simp at this + +lemma log_mul_pow2_add_of_lt {a p b : V} (pos : 0 < a) (pp : Pow2 p) (hb : b < p) : + log (a * p + b) = log a + log p := + by + rcases log_pos pos with ⟨a', ha', Ha, ha⟩ + rcases log_pos pp.pos with ⟨p', hp', Hp, hp⟩ + exact + log_eq_of_pos (lt_of_lt_of_le (mul_pos pos pp.pos) le_self_add) (Exponential.add_mul Ha Hp) + (le_trans (mul_le_mul' ha' hp') le_self_add) + (by + rcases Hp.uniq (exponential_of_pow2 pp) + calc + a * p + b < a * p + p := by simp [hb] + _ = (a + 1) * p := by simp [add_mul] + _ ≤ 2 * (a' * p) := by + simpa [← mul_assoc] using mul_le_mul_right (lt_iff_succ_le.mp ha)) + +lemma log_mul_pow2 {a p : V} (pos : 0 < a) (pp : Pow2 p) : log (a * p) = log a + log p := by + simpa using log_mul_pow2_add_of_lt pos pp pp.pos + +lemma log_monotone {a b : V} (h : a ≤ b) : log a ≤ log b := + by + rcases Arithmetic.zero_le a with (rfl | posa) + · simp + rcases Arithmetic.zero_le b with (rfl | posb) + · have := lt_of_lt_of_le posa h; simp_all + rcases log_pos posa with ⟨a', ha', Ha, _⟩ + rcases log_pos posb with ⟨b', _, Hb, hb⟩ + by_contra lt + have : b' < a' := (Exponential.monotone_iff Hb Ha).mp (by simpa using lt) + have : b < b := + calc + b < 2 * b' := hb + _ ≤ a' := ((Pow2.lt_iff_two_mul_le Hb.range_pow2 Ha.range_pow2).mp this) + _ ≤ a := ha' + _ ≤ b := h + simp_all + +/-- The binary Length construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def binaryLength (a : V) : V := + if 0 < a then log a + 1 else 0 + +/-- The inst Length construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable scoped instance : Length V := + ⟨binaryLength⟩ + +lemma length_eq_binaryLength (a : V) : ‖a‖ = if 0 < a then log a + 1 else 0 := + rfl + +@[simp] +lemma length_zero : ‖(0 : V)‖ = 0 := by simp [length_eq_binaryLength] + +lemma length_of_pos {a : V} (pos : 0 < a) : ‖a‖ = log a + 1 := by + simp [length_eq_binaryLength, pos] + +@[simp] +lemma length_le (a : V) : ‖a‖ ≤ a := + by + rcases Arithmetic.zero_le a with (rfl | pos) + · simp + · simp [pos, length_of_pos, ← lt_iff_succ_le, log_lt_self_of_pos] + +lemma length_graph {i a : V} : + i = ‖a‖ ↔ (0 < a → ∃ k ≤ a, k = log a ∧ i = k + 1) ∧ (a = 0 → i = 0) := + by + rcases Arithmetic.zero_le a with (rfl | pos) + · simp + · simp [length_of_pos, pos, pos_iff_ne_zero.mp pos] + +/-- The length Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.lengthDef : Σ₀.Semisentence 2 := + .mkSigma (“i a. (0 < a → ∃ k <⁺ a, !logDef k a ∧ i = k + 1) ∧ (a = 0 → i = 0)”) + +instance length_defined : Σ₀-Function₁[V] Length.length via lengthDef := + .mk fun v ↦ by simp [lengthDef, length_graph] + +instance length_definable : Σ₀-Function₁ (‖·‖ : V → V) := + length_defined.to_definable + +instance : Bounded₁ (‖·‖ : V → V) := + ⟨#0, fun _ ↦ by simp⟩ + +@[simp] +lemma length_one : ‖(1 : V)‖ = 1 := by simp [length_eq_binaryLength] + +lemma Exponential.length_eq {x y : V} (H : Exponential x y) : ‖y‖ = x + 1 := by + simpa [length_of_pos H.range_pos] using H.log_eq_of_exp + +lemma length_two_mul_of_pos {a : V} (pos : 0 < a) : ‖2 * a‖ = ‖a‖ + 1 := by + simp [pos, length_of_pos, log_two_mul_of_pos] + +lemma length_two_mul_add_one (a : V) : ‖2 * a + 1‖ = ‖a‖ + 1 := + by + rcases Arithmetic.zero_le a with (rfl | pos) + · simp + · simp [pos, length_of_pos, log_two_mul_add_one_of_pos] + +lemma length_mul_pow2_add_of_lt {a p b : V} (pos : 0 < a) (pp : Pow2 p) (hb : b < p) : + ‖a * p + b‖ = ‖a‖ + log p := by + simp [length_of_pos, pos, pp.pos, log_mul_pow2_add_of_lt pos pp hb, + add_right_comm (log a) (log p) 1] + +lemma length_mul_pow2 {a p : V} (pos : 0 < a) (pp : Pow2 p) : ‖a * p‖ = ‖a‖ + log p := by + simp [length_of_pos, pos, pp.pos, log_mul_pow2 pos pp, add_right_comm (log a) (log p) 1] + +lemma length_monotone {a b : V} (h : a ≤ b) : ‖a‖ ≤ ‖b‖ := + by + rcases Arithmetic.zero_le a with (rfl | posa) + · simp + · simpa [length_of_pos posa, length_of_pos (lt_of_lt_of_le posa h)] using log_monotone h + +lemma pos_of_lt_length {a b : V} (h : a < ‖b‖) : 0 < b := by + by_contra A; + rcases (show b = 0 from by simpa using A); simp_all + +@[simp] +lemma length_pos_iff {a : V} : 0 < ‖a‖ ↔ 0 < a := + by + constructor + · intro h + by_contra ha + have : a = 0 := by simpa using ha + subst a + simp_all + · intro h + exact pos_iff_one_le.mpr (by simpa using length_monotone (pos_iff_one_le.mp h)) + +@[simp] +lemma length_eq_zero_iff {a : V} : ‖a‖ = 0 ↔ a = 0 := + not_iff_not.mp (by simp [← pos_iff_ne_zero]) + +lemma le_log_of_lt_length {a b : V} (h : a < ‖b‖) : a ≤ log b := + by + have : 0 < b := pos_of_lt_length h + exact le_iff_lt_succ.mpr (by simpa [length_of_pos this] using h) + +lemma exponential_log_le_self {a b : V} (pos : 0 < a) (h : Exponential (log a) b) : b ≤ a := + by + rcases log_pos pos with ⟨_, _, H, _⟩; rcases H.uniq h + assumption + +lemma lt_exponential_log_self {a b : V} (h : Exponential (log a) b) : a < 2 * b := + by + rcases Arithmetic.zero_le a with (rfl | pos) + · simp at h; simp [h] + rcases log_pos pos with ⟨_, _, H, _⟩; rcases H.uniq h + assumption + +lemma lt_exp_len_self {a b : V} (h : Exponential ‖a‖ b) : a < b := + by + rcases Arithmetic.zero_le a with (rfl | pos) + · simp at h; simp [h] + have : Exponential (log a + 1) b := by simpa [length_of_pos pos] using h + rcases Exponential.exponential_succ.mp this with ⟨b, rfl, H⟩ + exact lt_exponential_log_self H + +lemma le_iff_le_log_of_exp {x y a : V} (H : Exponential x y) (pos : 0 < a) : + y ≤ a ↔ x ≤ log a := + ⟨by rcases H.log_eq_of_exp; exact log_monotone, fun h ↦ by + rcases log_pos pos with ⟨a', ha', Haa', _⟩; + exact le_trans (Exponential.monotone_le H Haa' h) ha'⟩ + +lemma le_iff_lt_length_of_exp {x y a : V} (H : Exponential x y) : y ≤ a ↔ x < ‖a‖ := + by + rcases Arithmetic.zero_le a with (rfl | pos) + · simpa using pos_iff_ne_zero.mp H.range_pos + simp [le_iff_le_log_of_exp H pos, length_of_pos pos, ← le_iff_lt_succ] + +lemma Exponential.lt_iff_log_lt {x y a : V} (H : Exponential x y) (pos : 0 < a) : + a < y ↔ log a < x := + not_iff_not.mp (by simpa using le_iff_le_log_of_exp H pos) + +lemma Exponential.lt_iff_len_le {x y a : V} (H : Exponential x y) : a < y ↔ ‖a‖ ≤ x := + not_iff_not.mp (by simpa using le_iff_lt_length_of_exp H) + +lemma Exponential.le_of_lt_length {x y a : V} (H : Exponential x y) : x < ‖a‖ → y ≤ a := fun h ↦ + (le_iff_lt_length_of_exp H).mpr h + +lemma Exponential.le_log {x y : V} (H : Exponential x y) : x ≤ log y := + (le_iff_le_log_of_exp H H.range_pos).mp (by rfl) + +lemma Exponential.lt_length {x y : V} (H : Exponential x y) : x < ‖y‖ := + (le_iff_lt_length_of_exp H).mp (by rfl) + +lemma lt_exponential_length {a b : V} (h : Exponential ‖a‖ b) : a < b := + by + rcases Arithmetic.zero_le a with (rfl | pos) + · simp at h; simp [h] + have : Exponential (log a + 1) b := by simpa [length_of_pos pos] using h + rcases Exponential.exponential_succ.mp this with ⟨b, rfl, H⟩ + exact lt_exponential_log_self H + +lemma sq_len_le_three_mul (a : V) : ‖a‖ ^ 2 ≤ 3 * a := + by + induction a using sigma0_polynomial_induction + · definability + case zero => simp + case even a pos IH => + calc + ‖2 * a‖ ^ 2 = (‖a‖ + 1) ^ 2 := by rw [length_two_mul_of_pos pos] + _ = ‖a‖ ^ 2 + 2 * ‖a‖ + 1 := by simp [sq, add_mul_self_eq] + _ ≤ 3 * a + 2 * ‖a‖ + 1 := by simpa using IH + _ ≤ 3 * a + 2 * a + 1 := by simp + _ ≤ 3 * a + 2 * a + a := by simp [← pos_iff_one_le, pos] + _ = 3 * (2 * a) := by + simp_all only [← two_add_one_eq_three, two_mul, add_mul, add_assoc, one_mul] + case odd a IH => + rcases Arithmetic.zero_le a with (rfl | pos) + · simp [← two_add_one_eq_three] + calc + ‖2 * a + 1‖ ^ 2 = (‖a‖ + 1) ^ 2 := by rw [length_two_mul_add_one a] + _ = ‖a‖ ^ 2 + 2 * ‖a‖ + 1 := by simp [sq, add_mul_self_eq] + _ ≤ 3 * a + 2 * ‖a‖ + 1 := by simpa using IH + _ ≤ 3 * a + 2 * a + 1 := by simp + _ ≤ 3 * a + 2 * a + a := by simp [← pos_iff_one_le, pos] + _ = 3 * (2 * a) := by + simp_all only [← two_add_one_eq_three, two_mul, add_mul, add_assoc, one_mul] + _ ≤ 3 * (2 * a + 1) := by simp + +lemma brange_exists_unique (a : V) : ∀ x < ‖a‖, ∃! y, Exponential x y := + by + suffices ∀ x < ‖a‖, ∃ y ≤ a, Exponential x y + by + intro x hx; rcases this x hx with ⟨_, _, H⟩ + exact ExistsUnique.intro _ H (fun y' H' ↦ H'.uniq H) + intro x + induction x using ISigma0.succ_induction + · definability + case zero => + intro ha + have : 0 < a := pos_of_lt_length ha + exact ⟨1, pos_iff_one_le.mp this, by simp⟩ + case succ x IH => + intro hx + rcases (IH (lt_of_le_of_lt (by simp) hx) : ∃ y ≤ a, Exponential x y) with ⟨y, hy, H⟩ + have : 0 < a := by by_contra A; rcases (show a = 0 from by simpa using A); simp_all + have : 2 * y ≤ a := (le_iff_le_log_of_exp H.succ this).mpr (le_log_of_lt_length hx) + exact ⟨2 * y, this, H.succ⟩ + +lemma bexp_exists_unique (a x : V) : ∃! y, (x < ‖a‖ → Exponential x y) ∧ (‖a‖ ≤ x → y = 0) := + by + by_cases hx : x < ‖a‖ + · simpa [hx, show ¬‖a‖ ≤ x from by simpa using hx, log_exists_unique_pos] using + brange_exists_unique a x hx + · simp [hx, show ‖a‖ ≤ x from by simpa using hx] + +/-- `bexp a x = exp x` if `x < ‖a‖`; `= 0` o.w. -/ +noncomputable def bexp (a x : V) : V := + Classical.chooseUnique (bexp_exists_unique a x) + +lemma exp_bexp_of_lt {a x : V} (h : x < ‖a‖) : Exponential x (bexp a x) := + (Classical.chooseUnique_spec (bexp_exists_unique a x)).1 h + +lemma bexp_eq_zero_of_le {a x : V} (h : ‖a‖ ≤ x) : bexp a x = 0 := + (Classical.chooseUnique_spec (bexp_exists_unique a x)).2 h + +@[simp] +lemma bexp_zero (x : V) : bexp 0 x = 0 := + bexp_eq_zero_of_le (by simp) + +@[simp] +lemma exp_bexp_of_lt_iff {a x : V} : Exponential x (bexp a x) ↔ x < ‖a‖ := + ⟨by + intro h; by_contra A + have : bexp a x = 0 := bexp_eq_zero_of_le (not_lt.mp A) + simp [this] at h + have := h.range_pos; simp_all, exp_bexp_of_lt⟩ + +@[simp] +lemma bexp_le_self (a x : V) : bexp a x ≤ a := + by + rcases show x < ‖a‖ ∨ ‖a‖ ≤ x from lt_or_ge _ _ with (lt | le) + · have : 0 < a := pos_of_lt_length lt + exact (le_iff_le_log_of_exp (exp_bexp_of_lt lt) this).mpr (le_log_of_lt_length lt) + · simp [bexp_eq_zero_of_le le] + +lemma bexp_graph {y a x : V} : + y = bexp a x ↔ ∃ l ≤ a, l = ‖a‖ ∧ (x < l → Exponential x y) ∧ (l ≤ x → y = 0) := + ⟨by rintro rfl; exact ⟨‖a‖, by simp, rfl, exp_bexp_of_lt, bexp_eq_zero_of_le⟩, + by + rintro ⟨_, _, rfl, hlt, hle⟩ + rcases show x < ‖a‖ ∨ ‖a‖ ≤ x from lt_or_ge _ _ with (lt | le) + · exact (hlt lt).uniq (exp_bexp_of_lt lt) + · rcases hle le; simp [bexp_eq_zero_of_le le]⟩ + +/-- The bexp Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.bexpDef : Σ₀.Semisentence 3 := + .mkSigma (“y a x. ∃ l <⁺ a, !lengthDef l a ∧ (x < l → !exponentialDef x y) ∧ (l ≤ x → y = 0)”) + +instance bexp_defined : Σ₀-Function₂[V] bexp via bexpDef := + .mk fun v ↦ by simp [bexpDef, bexp_graph] + +instance bexp_definable : Σ₀-Function₂[V] bexp := + bexp_defined.to_definable + +instance : Bounded₂ (bexp : V → V → V) := + ⟨#0, fun _ ↦ by simp⟩ + +lemma bexp_monotone_iff {a i j : V} (hi : i < ‖a‖) (hj : j < ‖a‖) : + bexp a i < bexp a j ↔ i < j := + Iff.symm <| Exponential.monotone_iff (by simp [hi]) (by simp [hj]) + +lemma bexp_monotone_le_iff {a i j : V} (hi : i < ‖a‖) (hj : j < ‖a‖) : + bexp a i ≤ bexp a j ↔ i ≤ j := + Iff.symm <| Exponential.monotone_le_iff (by simp [hi]) (by simp [hj]) + +lemma bexp_eq_of_lt_length {i a a' : V} (ha : i < ‖a‖) (ha' : i < ‖a'‖) : + bexp a i = bexp a' i := + by + have H : Exponential i (bexp a i) := by simp [ha] + have H' : Exponential i (bexp a' i) := by simp [ha'] + exact H.uniq H' + +@[simp] +lemma bexp_pow2 {a x : V} (h : x < ‖a‖) : Pow2 (bexp a x) := + (exp_bexp_of_lt h).range_pow2 + +@[simp] +lemma lt_bexp {a x : V} (h : x < ‖a‖) : x < bexp a x := + (exp_bexp_of_lt h).lt + +@[simp] +lemma bexp_pos {a x : V} (h : x < ‖a‖) : 0 < bexp a x := + (exp_bexp_of_lt h).range_pos + +lemma lt_bexp_len {a x : V} (h : ‖x‖ < ‖a‖) : x < bexp a ‖x‖ := + lt_exp_len_self (exp_bexp_of_lt h) + +lemma bexp_eq_of_exp {a x : V} (h : x < ‖a‖) (H : Exponential x y) : bexp a x = y := + (exp_bexp_of_lt h).uniq H + +lemma log_bexp {a x : V} (h : x < ‖a‖) : log (bexp a x) = x := + Exponential.log_eq_of_exp (exp_bexp_of_lt h) + +lemma len_bexp {a x : V} (h : x < ‖a‖) : ‖bexp a x‖ = x + 1 := by + rw [length_of_pos (bexp_pos h), log_bexp h] + +lemma bexp_zero_zero : bexp (0 : V) 0 = 0 := + bexp_eq_zero_of_le (by simp) + +@[simp] +lemma bexp_pos_zero {a : V} (h : 0 < a) : bexp a 0 = 1 := + bexp_eq_of_exp (by simpa) (by simp) + +lemma bexp_monotone {a₁ x₁ a₂ x₂ : V} (h₁ : x₁ < ‖a₁‖) (h₂ : x₂ < ‖a₂‖) : + bexp a₁ x₁ < bexp a₂ x₂ ↔ x₁ < x₂ := + Iff.symm <| (exp_bexp_of_lt h₁).monotone_iff (exp_bexp_of_lt h₂) + +lemma bexp_monotone_le {a₁ x₁ a₂ x₂ : V} (h₁ : x₁ < ‖a₁‖) (h₂ : x₂ < ‖a₂‖) : + bexp a₁ x₁ ≤ bexp a₂ x₂ ↔ x₁ ≤ x₂ := + Iff.symm <| (exp_bexp_of_lt h₁).monotone_le_iff (exp_bexp_of_lt h₂) + +lemma bexp_add {x₁ x₂ a : V} (h : x₁ + x₂ < ‖a‖) : bexp a (x₁ + x₂) = bexp a x₁ * bexp a x₂ := + (exp_bexp_of_lt h).uniq + ((exp_bexp_of_lt (lt_of_le_of_lt le_self_add h)).add_mul + (exp_bexp_of_lt (lt_of_le_of_lt le_add_self h))) + +lemma bexp_two_mul {a a' x : V} (hx : 2 * x < ‖a‖) (hx' : x < ‖a'‖) : + bexp a (2 * x) = (bexp a' x) ^ 2 := + bexp_eq_of_exp hx (exp_bexp_of_lt hx').bit_zero + +lemma bexp_two_mul_succ {a i : V} : bexp (2 * a) (i + 1) = 2 * bexp a i := + by + rcases Arithmetic.zero_le a with (rfl | pos) + · simp + rcases show i ≥ ‖a‖ ∨ i < ‖a‖ from le_or_gt ‖a‖ i with (h | h) + · simp [bexp_eq_zero_of_le, h, + show ‖2 * a‖ ≤ i + 1 from by simp [length_two_mul_of_pos pos, h]] + · exact bexp_eq_of_exp (by simp [length_two_mul_of_pos pos, h]) (exp_bexp_of_lt h).succ + +lemma bexp_two_mul_add_one_succ {a i : V} : bexp (2 * a + 1) (i + 1) = 2 * bexp a i := + by + rcases show i ≥ ‖a‖ ∨ i < ‖a‖ from le_or_gt ‖a‖ i with (h | h) + · simp [bexp_eq_zero_of_le, h, + show ‖2 * a + 1‖ ≤ i + 1 from by simp [length_two_mul_add_one, h]] + · exact bexp_eq_of_exp (by simp [length_two_mul_add_one, h]) (exp_bexp_of_lt h).succ + +/-- The fbit construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def fbit (a i : V) : V := + (a / bexp a i) % 2 + +@[simp] +lemma fbit_lt_two (a i : V) : fbit a i < 2 := by simp [fbit] + +@[simp] +lemma fbit_le_one (a i : V) : fbit a i ≤ 1 := + lt_two_iff_le_one.mp (by simp [fbit]) + +lemma fbit_eq_one_iff {a i : V} : fbit a i = 1 ↔ LenBit (bexp a i) a := by + simp [fbit, LenBit.iff_rem] + +lemma fbit_eq_zero_iff {a i : V} : fbit a i = 0 ↔ ¬LenBit (bexp a i) a := by + simp [fbit, LenBit.iff_rem] + +lemma fbit_eq_zero_of_le {a i : V} (hi : ‖a‖ ≤ i) : fbit a i = 0 := by + simp [fbit, bexp_eq_zero_of_le hi] + +/-- The fbit Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.fbitDef : Σ₀.Semisentence 3 := + .mkSigma (“b a i. ∃ x <⁺ a, !bexpDef x a i ∧ ∃ y <⁺ a, !divDef y a x ∧ !remDef b y 2”) + +instance fbit_defined : Σ₀-Function₂[V] fbit via fbitDef := + .mk fun v ↦ by simp [fbitDef, fbit] + +instance fbit_definable : Σ₀-Function₂[V] fbit := + fbit_defined.to_definable + +instance : Bounded₂ (fbit : V → V → V) := + ⟨‘1’, fun _ ↦ by simp⟩ + +@[simp] +lemma fbit_zero (i : V) : fbit 0 i = 0 := by simp [fbit] + +@[simp] +lemma fbit_mul_two_mul (a i : V) : fbit (2 * a) (i + 1) = fbit a i := by + simp [fbit, bexp_two_mul_succ, div_cancel_left] + +@[simp] +lemma fbit_mul_two_add_one_mul (a i : V) : fbit (2 * a + 1) (i + 1) = fbit a i := by + simp [fbit, bexp_two_mul_add_one_succ, Arithmetic.div_mul] + +@[simp] +lemma fbit_two_mul_zero_eq_zero (a : V) : fbit (2 * a) 0 = 0 := + by + rcases Arithmetic.zero_le a with (rfl | pos) + · simp + · have : bexp (2 * a) 0 = 1 := bexp_eq_of_exp (by simp [pos]) (by simp) + simp [fbit, this] + +@[simp] +lemma fbit_two_mul_add_one_zero_eq_one (a : V) : fbit (2 * a + 1) 0 = 1 := by simp [fbit] + +end ISigma0 + +section ISigma1 + +variable [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +@[simp] +lemma log_exponential (a : V) : log (Exp.exp a) = a := + (exponential_exp a).log_eq_of_exp + +lemma exp_log_le_self {a : V} (pos : 0 < a) : Exp.exp (log a) ≤ a := + by + rcases log_pos pos with ⟨_, _, H, _⟩ + rcases H.uniq (exponential_exp (log a)) + assumption + +lemma lt_two_mul_exponential_log {a : V} (pos : 0 < a) : a < 2 * Exp.exp (log a) := + by + rcases log_pos pos with ⟨_, _, H, _⟩ + rcases H.uniq (exponential_exp (log a)) + assumption + +@[simp] +lemma length_exponential (a : V) : ‖Exp.exp a‖ = a + 1 := by simp [length_of_pos (exp_pos a)] + +lemma exp_add (a b : V) : Exp.exp (a + b) = Exp.exp a * Exp.exp b := + exp_of_exponential (Exponential.add_mul (exponential_exp a) (exponential_exp b)) + +lemma log_mul_exp_add_of_lt {a b : V} (pos : 0 < a) (i : V) (hb : b < Exp.exp i) : + log (a * Exp.exp i + b) = log a + i := by simp [log_mul_pow2_add_of_lt pos (exp_pow2 i) hb] + +lemma log_mul_exp {a : V} (pos : 0 < a) (i : V) : log (a * Exp.exp i) = log a + i := by + simp [log_mul_pow2 pos (exp_pow2 i)] + +lemma length_mul_exp_add_of_lt {a b : V} (pos : 0 < a) (i : V) (hb : b < Exp.exp i) : + ‖a * Exp.exp i + b‖ = ‖a‖ + i := by simp [length_mul_pow2_add_of_lt pos (exp_pow2 i) hb] + +lemma length_mul_exp {a : V} (pos : 0 < a) (i : V) : ‖a * Exp.exp i‖ = ‖a‖ + i := by + simp [length_mul_pow2 pos (exp_pow2 i)] + +lemma exp_le_iff_le_log {i a : V} (pos : 0 < a) : Exp.exp i ≤ a ↔ i ≤ log a := + ⟨by intro h; simpa using log_monotone h, fun h ↦ + le_trans (exp_monotone_le.mpr h) (exp_log_le_self pos)⟩ + +end ISigma1 + +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Exponential/PPow2.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Exponential/PPow2.lean new file mode 100644 index 000000000..5d70d26f0 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Exponential/PPow2.lean @@ -0,0 +1,406 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Exponential.Pow2 + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +/-! +# On $\mathrm{PPow2}(x)$ + +$\mathrm{PPow2}(n)$ is a property that holds iff $n = 2^{2^i}$ for some $i$. +-/ + +namespace FFL +namespace FirstOrder +namespace Arithmetic + +variable {V : Type*} [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐈Σ₀] + +/-- The SPPow2 construction in `FFL.FirstOrder.Arithmetic`. -/ +def SPPow2 (m : V) : Prop := + ¬LenBit 1 m ∧ + LenBit 2 m ∧ ∀ i ≤ m, Pow2 i → 2 < i → (LenBit i m ↔ (√i) ^ 2 = i ∧ LenBit (√i) m) + +/-- The sppow2Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.sppow2Def : Σ₀.Semisentence 1 := + .mkSigma + (“m. + ¬!lenbitDef 1m ∧ + !lenbitDef 2m ∧ + ∀ i <⁺ m, + !pow2Def i → + 2 < i → (!lenbitDef i m ↔ ∃ s <⁺ i, !sqrtDef s i ∧ s * s = i ∧ !lenbitDef s m)”) + +instance sppow2_defined : Σ₀-Predicate[V] SPPow2 via sppow2Def := + .mk fun v ↦ by simp [SPPow2, sppow2Def, sq] + +/-- The PPow2 construction in `FFL.FirstOrder.Arithmetic`. -/ +def PPow2 (i : V) : Prop := + Pow2 i ∧ ∃ m < 2 * i, SPPow2 m ∧ LenBit i m + +/-- The ppow2Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.ppow2Def : Σ₀.Semisentence 1 := + .mkSigma (“i. !pow2Def i ∧ ∃ m < 2 * i, !sppow2Def m ∧ !lenbitDef i m”) + +instance ppow2_defined : Σ₀-Predicate (PPow2 : V → Prop) via ppow2Def := + .mk fun v ↦ by simp [PPow2, ppow2Def] + +instance ppow2_definable : Σ₀-Predicate (PPow2 : V → Prop) := + ppow2_defined.to_definable + +namespace SPPow2 + +variable {m : V} + +lemma not_lenbit_one (hm : SPPow2 m) : ¬LenBit 1 m := + hm.1 + +lemma lenbit_two (hm : SPPow2 m) : LenBit 2 m := + hm.2.1 + +lemma lenbit_iff (hm : SPPow2 m) {i : V} (hi : i ≤ m) (pi : Pow2 i) (lt2 : 2 < i) : + LenBit i m ↔ (√i) ^ 2 = i ∧ LenBit (√i) m := + hm.2.2 i hi pi lt2 + +lemma one_lt (hm : SPPow2 m) {i : V} (hi : LenBit i m) : 1 < i := + by + by_contra A + rcases (le_one_iff_eq_zero_or_one.mp (show i ≤ 1 from by simpa using A)) with (rfl | rfl) + · simp at hi + · exact hm.1 hi + +lemma two_lt (hm : SPPow2 m) {i : V} (hi : LenBit i m) (ne2 : i ≠ 2) : 2 < i := + lt_of_le_of_ne (one_lt_iff_two_le.mp <| hm.one_lt hi) (Ne.symm ne2) + +lemma sqrt (hm : SPPow2 m) {i : V} (hi : LenBit i m) (pi : Pow2 i) (ne2 : i ≠ 2) : + LenBit (√i) m := + ((hm.lenbit_iff hi.le pi (hm.two_lt hi ne2)).mp hi).2 + +lemma sq_sqrt_eq (hm : SPPow2 m) {i : V} (hi : LenBit i m) (pi : Pow2 i) (ne2 : i ≠ 2) : + (√i) ^ 2 = i := + ((hm.lenbit_iff hi.le pi (hm.two_lt hi ne2)).mp hi).1 + +lemma of_sqrt (hm : SPPow2 m) {i : V} (pi : Pow2 i) (him : i ≤ m) (hsqi : (√i) ^ 2 = i) + (hi : LenBit (√i) m) : LenBit i m := + by + by_cases ne1 : i = 1 + · rcases ne1; simpa using hi + · have ne2 : i ≠ 2 := by rintro rfl; simp [sqrt_two] at hsqi + have : 2 < i := + lt_of_le_of_ne + (one_lt_iff_two_le.mp <| lt_of_le_of_ne (pos_iff_one_le.mp pi.pos) <| Ne.symm ne1) + (Ne.symm ne2) + exact (hm.lenbit_iff him pi this).mpr ⟨hsqi, hi⟩ + +@[simp] +lemma two : SPPow2 (2 : V) := + ⟨by simp [LenBit.one], by simp, by + intro i hi pi + rcases le_two_iff_eq_zero_or_one_or_two.mp hi with (rfl | rfl | rfl) <;> simp⟩ + +@[simp] +lemma not_zero : ¬SPPow2 (0 : V) := by rintro ⟨_, h, _⟩; simp at h + +@[simp] +lemma not_one : ¬SPPow2 (1 : V) := by rintro ⟨_, h, _⟩; simp [LenBit.iff_rem] at h + +lemma sq_le_of_lt (hm : SPPow2 m) {i j : V} (pi : Pow2 i) (pj : Pow2 j) (hi : LenBit i m) + (hj : LenBit j m) : i < j → i ^ 2 ≤ j := + by + intro hij + suffices ∀ i < j, Pow2 i → Pow2 j → LenBit i m → LenBit j m → i ^ 2 ≤ j from + this i hij pi pj hi hj + clear i pi hi hij pj hj + induction j using ISigma0.order_induction + · definability + case ind j IH => + intro i hij pi pj hi hj + by_cases jne2 : j = 2 + · rcases jne2 with rfl + have : 2 ≤ i := one_lt_iff_two_le.mp (hm.one_lt hi) + exact False.elim ((not_lt.mpr this) hij) + · by_cases ine2 : i = 2 + · rcases ine2 with rfl + simpa [sq, two_mul_two_eq_four] using pj.four_le hij + · have : √i < √j := by + by_contra A + have : j ≤ i := by + simpa [hm.sq_sqrt_eq hi pi ine2, hm.sq_sqrt_eq hj pj jne2] using + sq_le_sq.mpr (show √j ≤ √i from by simpa using A) + exact False.elim ((not_lt.mpr this) (by simpa using hij)) + have : i ≤ √j := by + simpa [hm.sq_sqrt_eq hi pi ine2] using + IH (√j) (sqrt_lt_self_of_one_lt (hm.one_lt hj)) (√i) this + (pi.sqrt (hm.sq_sqrt_eq hi pi ine2)) (pj.sqrt (hm.sq_sqrt_eq hj pj jne2)) + (hm.sqrt hi pi ine2) (hm.sqrt hj pj jne2) + simpa [hm.sq_sqrt_eq hj pj jne2] using sq_le_sq.mpr this + +lemma last_uniq (hm : SPPow2 m) {i j : V} (pi : Pow2 i) (pj : Pow2 j) (hi : LenBit i m) + (hj : LenBit j m) (hsqi : m < i ^ 2) (hsqj : m < j ^ 2) : i = j := + by + by_contra ne + wlog hij : i < j + · exact + this hm pj pi hj hi hsqj hsqi (Ne.symm ne) + (lt_of_le_of_ne (by simpa using hij) (Ne.symm ne)) + have : i ^ 2 ≤ m := le_trans (hm.sq_le_of_lt pi pj hi hj hij) hj.le + have ltsqi : 2 < i ^ 2 := + lt_of_le_of_ne (one_lt_iff_two_le.mp <| by simpa using hm.one_lt hi) (by simp) + have : LenBit (i ^ 2) m ↔ LenBit i m := by simpa using hm.lenbit_iff this pi.sq ltsqi + have : LenBit (i ^ 2) m := this.mpr hi + have : ¬m < i ^ 2 := by simpa using this.le + contradiction + +end SPPow2 + +namespace PPow2 + +lemma pow2 {i : V} (h : PPow2 i) : Pow2 i := + h.1 + +lemma pos {i : V} (ppi : PPow2 i) : 0 < i := + ppi.pow2.pos + +lemma one_lt {i : V} (ppi : PPow2 i) : 1 < i := by + rcases ppi with ⟨_, m, _, sppm, lb⟩; + exact sppm.one_lt lb + +lemma sq_sqrt_eq {i : V} (ppi : PPow2 i) (ne2 : i ≠ 2) : (√i) ^ 2 = i := + by + rcases ppi with ⟨pi, m, _, sppm, lb⟩ + exact + ((sppm.lenbit_iff lb.le pi + (lt_of_le_of_ne (one_lt_iff_two_le.mp <| sppm.one_lt lb) (Ne.symm ne2))).mp + lb).1 + +lemma sqrt {i : V} (ppi : PPow2 i) (ne2 : i ≠ 2) : PPow2 (√i) := + by + rcases ppi with ⟨pi, m, _, sppm, him⟩ + have : LenBit i m ↔ (√i) ^ 2 = i ∧ LenBit (√i) m := + sppm.lenbit_iff him.le pi + (lt_of_le_of_ne (one_lt_iff_two_le.mp <| sppm.one_lt him) (Ne.symm ne2)) + rcases this.mp him with ⟨e, H⟩ + have psqi : Pow2 (√i) := Pow2.sq_iff.mp (by simp [e, pi]) + have one_lt_sqi : 1 < √i := one_lt_sq_iff.mp (by simpa [e] using sppm.one_lt him) + have : SPPow2 (m % (2 * √i)) := + ⟨by simpa [LenBit.mod] using sppm.not_lenbit_one, + (LenBit.mod_pow2 (by simp) (by simp [psqi]) (by simp [one_lt_sqi])).mpr sppm.lenbit_two, + by + intro j hj pj lt2 + have hjsi : j < 2 * √i := lt_of_le_of_lt hj <| mod_lt _ <| by simp [psqi.pos] + have hjm : LenBit j m ↔ (√j) ^ 2 = j ∧ LenBit (√j) m := + sppm.lenbit_iff (le_trans hj (by simp)) pj lt2 + have : LenBit j (m % (2 * √i)) ↔ LenBit j m := + LenBit.mod_pow2 pj (by simp [psqi]) (by simp [hjsi]) + calc + LenBit j (m % (2 * √i)) ↔ LenBit j m := + LenBit.mod_pow2 pj (by simp [psqi]) (by simp [hjsi]) + _ ↔ (√j) ^ 2 = j ∧ LenBit (√j) m := (sppm.lenbit_iff (le_trans hj (by simp)) pj lt2) + _ ↔ (√j) ^ 2 = j ∧ LenBit (√j) (m % (2 * √i)) := + and_congr_right <| fun hsqj ↦ + Iff.symm <| + LenBit.mod_pow2 (pj.sqrt hsqj) (by simp [psqi]) (lt_of_le_of_lt (by simp) hjsi)⟩ + exact ⟨psqi, m % (2 * √i), mod_lt _ (by simp [psqi.pos]), this, by simp [H]⟩ + +lemma exists_spp {i : V} (h : PPow2 i) : ∃ m < 2 * i, SPPow2 m ∧ LenBit i m := + h.2 + +protected lemma sq {i : V} (ppi : PPow2 i) : PPow2 (i ^ 2) := + by + rcases ppi.exists_spp with ⟨m, hm, sppm, hi⟩ + have sppm' : SPPow2 (m + i ^ 2) := by + refine ⟨?_, ?_, ?_⟩ + · rw [LenBit.add_pow2] <;> simp [ppi.pow2, sppm.not_lenbit_one, sppm.one_lt hi] + · have : i ≠ 1 := by rintro rfl; exact sppm.not_lenbit_one hi + have : 2 < i ^ 2 := lt_of_le_of_ne (ppi.pow2.sq.two_le <| by simp [this]) (by simp) + rw [LenBit.add_pow2] <;> simp [ppi.pow2, sppm.lenbit_two, this] + · intro j hj pj lt2 + have hsqi : i < i ^ 2 := lt_square_of_lt ppi.one_lt + have hmi : m < i ^ 2 := + lt_of_lt_of_le hm <| two_mul_le_sq <| one_lt_iff_two_le.mp <| sppm.one_lt hi + calc + LenBit j (m + i ^ 2) ↔ j = i ^ 2 ∨ LenBit j m := + LenBit.add_pow2_iff_of_lt pj (by simpa using ppi.pow2) hmi + _ ↔ (√j) ^ 2 = j ∧ LenBit (√j) (m + i ^ 2) := ⟨?_, ?_⟩ + · rintro (rfl | hj) + · simp only [sqrt_sq, true_and]; rw [LenBit.add_pow2] <;> simp [hi, ppi.pow2, hsqi] + · have : (√j) ^ 2 = j := sppm.sq_sqrt_eq hj pj (ne_of_gt lt2) + rw [LenBit.add_pow2_iff_of_lt] <;> try simp [ppi.pow2, pj.sqrt this, hmi] + simp [sppm.sqrt hj pj (ne_of_gt lt2), this] + · rintro ⟨ej, lb⟩ + have hsqj : √j < i ^ 2 := + lt_of_mul_lt_mul_left (a := 2) + (by + calc + 2 * √j ≤ (√j) ^ 2 := + two_mul_le_sq + (one_lt_iff_two_le.mp <| + one_lt_sq_iff.mp <| by rw [ej]; exact lt_trans one_lt_two lt2) + _ ≤ j := by simp + _ ≤ m + i ^ 2 := hj + _ < 2 * i ^ 2 := by simp [two_mul, hmi]) + have hsqj : LenBit (√j) m := (LenBit.add_pow2 (pj.sqrt ej) ppi.pow2.sq hsqj).mp lb + by_cases hjm : j ≤ m + · exact Or.inr <| sppm.of_sqrt pj hjm ej hsqj + · have : i = √j := + sppm.last_uniq ppi.pow2 (pj.sqrt ej) hi hsqj hmi (by simpa [ej] using hjm) + left; simp [this, ej] + by_cases ne1 : i = 1 + · rcases ne1; simpa using ppi + have : m < i ^ 2 := + lt_of_lt_of_le hm + (two_mul_le_sq <| + one_lt_iff_two_le.mp <| lt_of_le_of_ne (pos_iff_one_le.mp <| ppi.pos) (Ne.symm ne1)) + exact ⟨ppi.pow2.sq, m + i ^ 2, by simp [two_mul, this], sppm', LenBit.add_self this⟩ + +@[simp] +lemma two : PPow2 (2 : V) := + ⟨by simp, 2, by simp⟩ + +@[simp] +lemma not_zero : ¬PPow2 (0 : V) := by intro h; simpa using h.pow2 + +@[simp] +lemma not_one : ¬PPow2 (1 : V) := by + rintro ⟨_, m, hm, H, _⟩ + have : m ≤ 1 := lt_two_iff_le_one.mp (by simpa using hm) + rcases le_one_iff_eq_zero_or_one.mp this with (rfl | rfl) <;> simp at H + +lemma elim {i : V} : PPow2 i ↔ i = 2 ∨ ∃ b, i = b ^ 2 ∧ PPow2 b := + by + by_cases ei : i = 2 + · rcases ei with rfl; simp + · simp only [ei, false_or] + constructor + · rintro ppi + exact ⟨√i, Eq.symm <| ppi.sq_sqrt_eq ei, ppi.sqrt ei⟩ + · rintro ⟨j, rfl, ppj⟩ + exact ppj.sq + +lemma elim' {i : V} : PPow2 i ↔ i = 2 ∨ 2 < i ∧ ∃ j, i = j ^ 2 ∧ PPow2 j := + by + by_cases ha : 2 < i + · simp [ha, ← elim] + · have : i = 0 ∨ i = 1 ∨ i = 2 := by simpa [le_two_iff_eq_zero_or_one_or_two] using ha + rcases this with (rfl | rfl | rfl) <;> simp + +@[simp] +lemma four : PPow2 (4 : V) := + elim.mpr (Or.inr <| ⟨2, by simp [two_pow_two_eq_four]⟩) + +lemma two_le {i : V} (hi : PPow2 i) : 2 ≤ i := by + simp [← one_add_one_eq_two, ← lt_iff_succ_le, hi.one_lt] + +lemma not_three : ¬PPow2 (3 : V) := by intro h; simpa [sqrt_three] using h.sqrt (by simp) + +lemma two_lt {i : V} (hi : PPow2 i) (ne : i ≠ 2) : 2 < i := + by + by_contra A + rcases show i = 0 ∨ i = 1 by simpa [ne, le_iff_lt_or_eq, lt_two_iff_le_one] using A with + (rfl | rfl) <;> + simp at hi + +lemma four_le {i : V} (hi : PPow2 i) (ne : i ≠ 2) : 4 ≤ i := + by + by_contra A + have : i ≤ 3 := by simpa [← three_add_one_eq_four, ← le_iff_lt_succ] using A + rcases le_three_iff_eq_zero_or_one_or_two_or_three.mp this with (rfl | rfl | rfl | rfl) <;> + simp at ne hi + · have : PPow2 (1 : V) := by simpa [sqrt_three] using hi.sqrt (by simp) + simp at this + +lemma four_lt {i : V} (hi : PPow2 i) (ne2 : i ≠ 2) (ne4 : i ≠ 4) : 4 < i := + Ne.lt_of_le (Ne.symm ne4) (hi.four_le ne2) + +lemma sq_ne_two {i : V} (hi : PPow2 i) : i ^ 2 ≠ 2 := + by + intro e; have : i < 2 := by simpa [← e] using lt_square_of_lt hi.one_lt + exact not_le.mpr this hi.two_le + +lemma sqrt_ne_two {i : V} (hi : PPow2 i) (ne2 : i ≠ 2) (ne4 : i ≠ 4) : √i ≠ 2 := + by + intro e + have : i = 4 := by simpa [e, two_pow_two_eq_four] using Eq.symm <| hi.sq_sqrt_eq ne2 + contradiction + +lemma sq_ne_four {i : V} (hi : PPow2 i) (ne2 : i ≠ 2) : i ^ 2 ≠ 4 := by + simpa [two_pow_two_eq_four] using ne_of_gt (sq_lt_sq.mpr (hi.two_lt ne2)) + +lemma sq_le_of_lt {i j : V} (hi : PPow2 i) (hj : PPow2 j) : i < j → i ^ 2 ≤ j := + by + intro hij + suffices ∀ i < j, PPow2 i → PPow2 j → i ^ 2 ≤ j from this i hij hi hj + clear hi hij hj + induction j using ISigma0.order_induction + · definability + case ind j IH => + intro i hij hi hj + by_cases ej : j = 2 + · have : 2 ≤ i := by simpa [one_add_one_eq_two] using lt_iff_succ_le.mp hi.one_lt + exact False.elim ((not_lt.mpr this) (by simpa [ej] using hij)) + · by_cases ei : i = 2 + · rcases ei with rfl + simpa [sq, two_mul_two_eq_four] using hj.four_le ej + · have : √i < √j := by + by_contra A + have : j ≤ i := by + simpa [hi.sq_sqrt_eq ei, hj.sq_sqrt_eq ej] using + sq_le_sq.mpr (show √j ≤ √i from by simpa using A) + exact False.elim ((not_lt.mpr this) (by simpa using hij)) + have : i ≤ √j := by + simpa [hi.sq_sqrt_eq ei] using + IH (√j) (sqrt_lt_self_of_one_lt hj.one_lt) (√i) this (hi.sqrt ei) (hj.sqrt ej) + simpa [hj.sq_sqrt_eq ej] using sq_le_sq.mpr this + +lemma sq_uniq {y i j : V} (py : Pow2 y) (ppi : PPow2 i) (ppj : PPow2 j) (hi : y < i ∧ i ≤ y ^ 2) + (hj : y < j ∧ j ≤ y ^ 2) : i = j := by + by_contra ne + wlog hij : i < j + · exact this py ppj ppi hj hi (Ne.symm ne) (Ne.lt_of_le' ne (by simpa using hij)) + have : y ^ 2 < y ^ 2 := + calc + y ^ 2 < i ^ 2 := sq_lt_sq.mpr hi.1 + _ ≤ j := (sq_le_of_lt ppi ppj hij) + _ ≤ y ^ 2 := hj.2 + simp_all + +lemma two_mul_sq_uniq {y i j : V} (py : Pow2 y) (ppi : PPow2 i) (ppj : PPow2 j) + (hi : y < i ∧ i ≤ 2 * y ^ 2) (hj : y < j ∧ j ≤ 2 * y ^ 2) : i = j := + by + by_contra ne + wlog hij : i < j + · exact this py ppj ppi hj hi (Ne.symm ne) (Ne.lt_of_le' ne (by simpa using hij)) + have : i ^ 2 < (2 * y) ^ 2 := + calc + i ^ 2 ≤ j := sq_le_of_lt ppi ppj hij + _ ≤ 2 * y ^ 2 := hj.2 + _ = 2 * (y * y) := by simp [sq] + _ < 2 * (2 * (y * y)) := + (lt_mul_of_pos_of_one_lt_left (by simpa using pos_iff_ne_zero.mp py.pos) (by simp)) + _ = (2 * y) ^ 2 := by simp [sq, mul_assoc, mul_left_comm] + have : i < 2 * y := sq_lt_sq.mp this + have : y < y := lt_of_lt_of_le hi.1 ((ppi.pow2.le_iff_lt_two py).mpr this) + simp_all + +end PPow2 + +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Exponential/Pow2.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Exponential/Pow2.lean new file mode 100644 index 000000000..e037be0ec --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Exponential/Pow2.lean @@ -0,0 +1,510 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.IOpen.Basic + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +/-! +# On $\mathrm{Pow2}(x)$ and $\mathrm{BitLen}(x, y)$ + +$\mathrm{Pow2}(n)$ is a property that holds iff $n = 2^i$ for some $i$. +-/ + +namespace FFL +namespace FirstOrder +namespace Arithmetic + +variable {V : Type*} [ORingStructure V] + +section IOpen + +variable [V↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + +/-- The Pow2 construction in `FFL.FirstOrder.Arithmetic`. -/ +def Pow2 (a : V) : Prop := + 0 < a ∧ ∀ r ≤ a, 1 < r → r ∣ a → 2 ∣ r + +/-- The pow2Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.pow2Def : Σ₀.Semisentence 1 := + .mkSigma (“a. 0 < a ∧ ∀ r <⁺ a, 1 < r → r ∣ a → 2 ∣ r”) + +instance pow2_defined : Σ₀-Predicate (Pow2 : V → Prop) via pow2Def := + .mk fun v ↦ by simp [Semiformula.eval_substs, Pow2, pow2Def, le_iff_lt_succ] + +instance pow2_definable : Σ₀-Predicate (Pow2 : V → Prop) := + pow2_defined.to_definable + +lemma Pow2.pos {a : V} (h : Pow2 a) : 0 < a := + h.1 + +lemma Pow2.dvd {a : V} (h : Pow2 a) {r} (hr : r ≤ a) : 1 < r → r ∣ a → 2 ∣ r := + h.2 r hr + +@[simp] +lemma pow2_one : Pow2 (1 : V) := + ⟨by simp, by + intro r hr hhr hd + rcases show r = 0 ∨ r = 1 from le_one_iff_eq_zero_or_one.mp hr with (rfl | rfl) + · simp + · simp at hhr⟩ + +@[simp] +lemma not_pow2_zero : ¬Pow2 (0 : V) := by intro h; have := h.pos; simp at this + +lemma Pow2.two_dvd {a : V} (h : Pow2 a) (lt : 1 < a) : 2 ∣ a := + h.dvd (le_refl _) lt (by simp) + +lemma Pow2.two_dvd' {a : V} (h : Pow2 a) (lt : a ≠ 1) : 2 ∣ a := + h.dvd (le_refl _) + (by + by_contra A + rcases show a = 0 ∨ a = 1 by simpa [le_one_iff_eq_zero_or_one] using A with + (rfl | rfl) <;> + simp at h lt) + (by simp) + +lemma Pow2.of_dvd {a b : V} (h : b ∣ a) : Pow2 a → Pow2 b := + by + intro ha + have : 0 < b := by + by_contra e + have : a = 0 := by simpa [show b = 0 from by simpa using e] using h + rcases this with rfl + simpa using ha.pos + exact + ⟨this, fun r hr ltr hb ↦ + ha.dvd (show r ≤ a from le_trans hr (le_of_dvd ha.pos h)) ltr (dvd_trans hb h)⟩ + +lemma pow2_mul_two {a : V} : Pow2 (2 * a) ↔ Pow2 a := + ⟨by + intro H + have : ∀ r ≤ a, 1 < r → r ∣ a → 2 ∣ r := + by + intro r hr ltr dvd + exact + H.dvd (show r ≤ 2 * a from le_trans hr (le_mul_of_one_le_left (by simp) one_le_two)) ltr + (Dvd.dvd.mul_left dvd 2) + exact ⟨by simpa using H.pos, this⟩, by + intro H + exact + ⟨by simpa using H.pos, by + intro r _ hr hd + rcases two_prime.left_dvd_or_dvd_right_of_dvd_mul hd with (hd | hd) + · exact hd + · exact H.dvd (show r ≤ a from le_of_dvd H.pos hd) hr hd⟩⟩ + +lemma pow2_mul_four {a : V} : Pow2 (4 * a) ↔ Pow2 a := by + simp [← two_mul_two_eq_four, mul_assoc, pow2_mul_two] + +lemma Pow2.elim {p : V} : Pow2 p ↔ p = 1 ∨ ∃ q, p = 2 * q ∧ Pow2 q := + ⟨by + intro H + by_cases hp : 1 < p + · have : 2 ∣ p := H.two_dvd hp + rcases this with ⟨q, rfl⟩ + right; exact ⟨q, rfl, pow2_mul_two.mp H⟩ + · have : p = 1 := le_antisymm (by simpa using hp) (pos_iff_one_le.mp H.pos) + left; exact this, by rintro (rfl | ⟨q, rfl, hq⟩) <;> simp [pow2_one, pow2_mul_two, *]⟩ + +@[simp] +lemma pow2_two : Pow2 (2 : V) := + Pow2.elim.mpr (Or.inr ⟨1, by simp⟩) + +lemma Pow2.div_two {p : V} (h : Pow2 p) (ne : p ≠ 1) : Pow2 (p / 2) := + by + rcases Pow2.elim.mp h with (rfl | ⟨q, rfl, pq⟩) + · simp at ne + simpa + +lemma Pow2.two_mul_div_two {p : V} (h : Pow2 p) (ne : p ≠ 1) : 2 * (p / 2) = p := + by + rcases Pow2.elim.mp h with (rfl | ⟨q, rfl, _⟩) + · simp at ne + simp + +lemma Pow2.div_two_mul_two {p : V} (h : Pow2 p) (ne : p ≠ 1) : (p / 2) * 2 = p := by + simp [mul_comm, h.two_mul_div_two ne] + +lemma Pow2.elim' {p : V} : Pow2 p ↔ p = 1 ∨ 1 < p ∧ ∃ q, p = 2 * q ∧ Pow2 q := + by + by_cases hp : 1 < p + · simpa [hp] using Pow2.elim + · have : p = 0 ∨ p = 1 := le_one_iff_eq_zero_or_one.mp (show p ≤ 1 from by simpa using hp) + rcases this with (rfl | rfl) <;> simp + +section LenBit + +/-- $\mathrm{LenBit} (2^i, a) \iff \text{$i$th-bit of $a$ is $1$}$. -/ +def LenBit (i a : V) : Prop := + ¬2 ∣ (a / i) + +/-- The lenbit Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.lenbitDef : Σ₀.Semisentence 2 := + .mkSigma (“i a. ∃ z <⁺ a, !divDef.val z a i ∧ ¬2 ∣ z”) + +instance lenbit_defined : Σ₀-Relation (LenBit : V → V → Prop) via lenbitDef := + .mk fun v ↦ by simp [lenbitDef, LenBit] + +instance lenbit_definable : Σ₀-Relation (LenBit : V → V → Prop) := + lenbit_defined.to_definable + +lemma LenBit.le {i a : V} (h : LenBit i a) : i ≤ a := by + by_contra A; + simp [LenBit, show a < i from by simpa using A] at h + +lemma not_lenbit_of_lt {i a : V} (h : a < i) : ¬LenBit i a := by + intro A; + exact not_le.mpr h A.le + +@[simp] +lemma LenBit.zero (a : V) : ¬LenBit 0 a := by simp [LenBit] + +@[simp] +lemma LenBit.on_zero (a : V) : ¬LenBit a 0 := by simp [LenBit] + +lemma LenBit.one (a : V) : LenBit 1 a ↔ ¬2 ∣ a := by simp [LenBit] + +lemma LenBit.iff_rem {i a : V} : LenBit i a ↔ (a / i) % 2 = 1 := + by + simp only [LenBit] + rcases mod_two (a / i) with (h | h) <;> simp [h, ← mod_eq_zero_iff_dvd] + +lemma not_lenbit_iff_rem {i a : V} : ¬LenBit i a ↔ (a / i) % 2 = 0 := by + simp [LenBit, ← mod_eq_zero_iff_dvd] + +@[simp] +lemma LenBit.self {a : V} (pos : 0 < a) : LenBit a a := by simp [LenBit.iff_rem, pos] + +lemma LenBit.mod {i a k : V} (h : 2 * i ∣ k) : LenBit i (a % k) ↔ LenBit i a := + by + have : 0 ≤ i := Arithmetic.zero_le i + rcases (eq_or_lt_of_le this) with (rfl | pos) + · simp + rcases h with ⟨k', hk'⟩ + calc + LenBit i (a % k) ↔ ((a % k) / i) % 2 = 1 := LenBit.iff_rem + _ ↔ ((2 * k') * (a / k) + a % k / i) % 2 = 1 := by simp [mul_assoc] + _ ↔ (((2 * k') * (a / k) * i + a % k) / i) % 2 = 1 := by simp [div_mul_add_self, pos] + _ ↔ ((k * (a / k) + a % k) / i) % 2 = 1 := + (iff_of_eq + (by + congr 3 + simp [mul_right_comm _ (a / k), mul_right_comm 2 k' i, ← hk'])) + _ ↔ LenBit i a := by simp [div_add_mod a k, LenBit.iff_rem] + +@[simp] +lemma LenBit.mod_two_mul_self {a i : V} : LenBit i (a % (2 * i)) ↔ LenBit i a := + LenBit.mod (by simp) + +lemma LenBit.add {i a b : V} (h : 2 * i ∣ b) : LenBit i (a + b) ↔ LenBit i a := + by + have : 0 ≤ i := Arithmetic.zero_le i + rcases (eq_or_lt_of_le this) with (rfl | pos) + · simp + rcases h with ⟨b', hb'⟩ + have hb' : b = 2 * b' * i := by simp [hb', mul_right_comm] + calc + LenBit i (a + b) ↔ ((a + b) / i) % 2 = 1 := LenBit.iff_rem + _ ↔ (a / i + 2 * b') % 2 = 1 := by rw [hb', div_add_mul_self _ _ pos] + _ ↔ LenBit i a := by simp [LenBit.iff_rem] + +lemma LenBit.add_self {i a : V} (h : a < i) : LenBit i (a + i) := + by + have pos : 0 < i := by exact pos_of_gt h + simp [LenBit.iff_rem, div_add_self_right _ pos, h] + +lemma LenBit.add_self_of_not_lenbit {a i : V} (pos : 0 < i) (h : ¬LenBit i a) : + LenBit i (a + i) := + by + have : a / i % 2 = 0 := by simpa [LenBit.iff_rem] using h + simp only [iff_rem, pos, div_add_self_right] + rw [mod_add] <;> simp [this] + +lemma LenBit.add_self_of_lenbit {a i : V} (pos : 0 < i) (h : LenBit i a) : ¬LenBit i (a + i) := + by + have : a / i % 2 = 1 := by simpa [LenBit.iff_rem] using h + simp only [iff_rem, pos, div_add_self_right, mod_two_not_one_iff] + rw [mod_add] <;> simp [this, one_add_one_eq_two] + +lemma LenBit.sub_self_of_lenbit {a i : V} (pos : 0 < i) (h : LenBit i a) : ¬LenBit i (a - i) := + by + intro h' + have : ¬LenBit i a := by + simpa [sub_add_self_of_le h.le] using LenBit.add_self_of_lenbit pos h' + contradiction + +end LenBit + +end IOpen + +section ISigma0 + +variable [V↓[ℒₒᵣ] ⊧* 𝐈Σ₀] + +namespace Pow2 + +lemma mul {a b : V} (ha : Pow2 a) (hb : Pow2 b) : Pow2 (a * b) := + by + wlog hab : a ≤ b + · simpa [mul_comm] using this hb ha (LT.lt.le (by simpa using hab)) + suffices ∀ b : V, ∀ a ≤ b, Pow2 a → Pow2 b → Pow2 (a * b) by exact this b a hab ha hb + intro b + induction b using ISigma0.order_induction + · definability + case ind IH a b IH => + intro a hab ha hb + have : a = 1 ∨ 1 < a ∧ ∃ a', a = 2 * a' ∧ Pow2 a' := Pow2.elim'.mp ha + rcases this with (rfl | ⟨lta, a, rfl, ha⟩) + · simpa using hb + · have : b = 1 ∨ 1 < b ∧ ∃ b', b = 2 * b' ∧ Pow2 b' := Pow2.elim'.mp hb + rcases this with (rfl | ⟨ltb, b, rfl, hb⟩) + · simpa using ha + · have ltb : b < 2 * b := + lt_two_mul_self (pos_iff_ne_zero.mpr <| by rintro rfl; simp at ltb) + have hab : a ≤ b := le_of_mul_le_mul_left hab (by simp) + have : Pow2 (a * b) := IH b ltb a hab (by assumption) (by assumption) + suffices Pow2 (4 * a * b) + by + have : (2 * a) * (2 * b) = 4 * a * b := by + simp [mul_assoc, mul_left_comm a 2 b, ← two_mul_two_eq_four] + simpa [this] + simpa [mul_assoc, pow2_mul_four] using this + +@[simp] +lemma mul_iff {a b : V} : Pow2 (a * b) ↔ Pow2 a ∧ Pow2 b := + ⟨fun h ↦ ⟨h.of_dvd (by simp), h.of_dvd (by simp)⟩, by rintro ⟨ha, hb⟩; exact ha.mul hb⟩ + +@[simp] +lemma sq_iff {a : V} : Pow2 (a ^ 2) ↔ Pow2 a := by simp [_root_.sq] + +lemma sq {a : V} : Pow2 a → Pow2 (a ^ 2) := by simp [_root_.sq] + +lemma dvd_of_le {a b : V} (ha : Pow2 a) (hb : Pow2 b) : a ≤ b → a ∣ b := + by + suffices ∀ b : V, ∀ a ≤ b, Pow2 a → Pow2 b → a ∣ b by intro hab; exact this b a hab ha hb + intro b; induction b using ISigma0.order_induction + · definability + case ind b IH => + intro a hab ha hb + have : b = 1 ∨ 1 < b ∧ ∃ b', b = 2 * b' ∧ Pow2 b' := Pow2.elim'.mp hb + rcases this with (rfl | ⟨ltb, b, rfl, hb⟩) + · rcases le_one_iff_eq_zero_or_one.mp hab with (rfl | rfl) <;> simp + · simp at ha + · have : a = 1 ∨ 1 < a ∧ ∃ a', a = 2 * a' ∧ Pow2 a' := Pow2.elim'.mp ha + rcases this with (rfl | ⟨lta, a, rfl, ha⟩) + · simp + · have ltb : b < 2 * b := + lt_two_mul_self (pos_iff_ne_zero.mpr <| by rintro rfl; simp at ltb) + have hab : a ≤ b := le_of_mul_le_mul_left hab (by simp) + exact mul_dvd_mul_left 2 <| IH b ltb a hab (by assumption) (by assumption) + +lemma le_iff_dvd {a b : V} (ha : Pow2 a) (hb : Pow2 b) : a ≤ b ↔ a ∣ b := + ⟨Pow2.dvd_of_le ha hb, le_of_dvd hb.pos⟩ + +lemma two_le {a : V} (pa : Pow2 a) (ne1 : a ≠ 1) : 2 ≤ a := + le_of_dvd pa.pos (pa.two_dvd' ne1) + +lemma le_iff_lt_two {a b : V} (ha : Pow2 a) (hb : Pow2 b) : a ≤ b ↔ a < 2 * b := + by + constructor + · intro h; exact lt_of_le_of_lt h (lt_two_mul_self hb.pos) + · intro h + by_cases ea : a = 1 + · rcases ea with rfl + simpa [← pos_iff_one_le] using hb.pos + · suffices a ∣ b from le_of_dvd hb.pos this + have : a / 2 ∣ b := + by + have : 2 * (a / 2) ∣ 2 * b := by + simpa [ha.two_mul_div_two ea] using dvd_of_le ha (by simpa using hb) (LT.lt.le h) + exact (mul_dvd_mul_iff_left (by simp)).mp this + rcases this with ⟨b', rfl⟩ + have hb' : Pow2 b' := (show Pow2 (a / 2) ∧ Pow2 b' by simpa using hb).2 + have : 2 ∣ b' := hb'.two_dvd' (by rintro rfl; simp [ha.two_mul_div_two ea] at h) + rcases this with ⟨b'', rfl⟩ + simp [← mul_assoc, ha.div_two_mul_two ea] + +lemma lt_iff_two_mul_le {a b : V} (ha : Pow2 a) (hb : Pow2 b) : a < b ↔ 2 * a ≤ b := + by + by_cases eb : b = 1 + · simp [eb, ← lt_two_iff_le_one] + · rw [← hb.two_mul_div_two eb]; simp [le_iff_lt_two ha (hb.div_two eb)] + +lemma sq_or_dsq {a : V} (pa : Pow2 a) : ∃ b, a = b ^ 2 ∨ a = 2 * b ^ 2 := + by + suffices ∃ b ≤ a, a = b ^ 2 ∨ a = 2 * b ^ 2 + by + rcases this with ⟨b, _, h⟩ + exact ⟨b, h⟩ + induction a using ISigma0.order_induction + · definability + case ind a IH => + rcases Pow2.elim'.mp pa with (rfl | ⟨ha, a, rfl, pa'⟩) + · exact ⟨1, by simp⟩ + · have : 0 < a := by simpa [← pos_iff_one_le] using one_lt_iff_two_le.mp ha + rcases IH a (lt_mul_of_one_lt_left this one_lt_two) pa' with ⟨b, _, (rfl | rfl)⟩ + · exact ⟨b, le_trans (by simp) le_two_mul_left, by right; rfl⟩ + · refine ⟨2 * b, ?_, ?_⟩ + · simpa using le_trans (by simp) le_two_mul_left + · left + simp [_root_.sq, mul_assoc, mul_left_comm] + +lemma sqrt {a : V} (h : Pow2 a) (hsq : (√a) ^ 2 = a) : Pow2 (√a) := by + rw [← hsq] at h; + simpa using h + +@[simp] +lemma not_three : ¬Pow2 (3 : V) := by + intro h + have : (2 : V) ∣ 3 := h.two_dvd (by simp [← two_add_one_eq_three]) + simp [← two_add_one_eq_three, ← mod_eq_zero_iff_dvd] at this + +lemma four_le {i : V} (hi : Pow2 i) (lt : 2 < i) : 4 ≤ i := + by + by_contra A + have : i ≤ 3 := by simpa [← three_add_one_eq_four, ← le_iff_lt_succ] using A + rcases le_three_iff_eq_zero_or_one_or_two_or_three.mp this with (rfl | rfl | rfl | rfl) <;> + simp at lt hi + +lemma mul_add_lt_of_mul_lt_of_pos {a b p q : V} (hp : Pow2 p) (hq : Pow2 q) (h : a * p < q) + (hb : b < p) (hbq : b < q) : a * p + b < q := + by + rcases Arithmetic.zero_le a with (rfl | pos) + · simp [hbq] + have : p ∣ q := dvd_of_le hp hq (le_of_lt <| lt_of_le_of_lt (le_mul_of_pos_left pos) h) + rcases this with ⟨q, rfl⟩ + have : a < q := lt_of_mul_lt_mul_right (a := p) (by simpa [mul_comm] using h) + calc + a * p + b < (a + 1) * p := by simp [add_mul, hb] + _ ≤ p * q := by simpa [mul_comm p q] using mul_le_mul_right (lt_iff_succ_le.mp this) + +end Pow2 + +lemma LenBit.mod_pow2 {a i j : V} (pi : Pow2 i) (pj : Pow2 j) (h : i < j) : + LenBit i (a % j) ↔ LenBit i a := + LenBit.mod (by rw [← Pow2.le_iff_dvd] <;> simp [pi, pj, ← Pow2.lt_iff_two_mul_le, h]) + +lemma LenBit.add_pow2 {a i j : V} (pi : Pow2 i) (pj : Pow2 j) (h : i < j) : + LenBit i (a + j) ↔ LenBit i a := + LenBit.add (by rw [← Pow2.le_iff_dvd] <;> simp [pi, pj, ← Pow2.lt_iff_two_mul_le, h]) + +lemma LenBit.add_pow2_iff_of_lt {a i j : V} (pi : Pow2 i) (pj : Pow2 j) (h : a < j) : + LenBit i (a + j) ↔ i = j ∨ LenBit i a := + by + rcases show i < j ∨ i = j ∨ i > j from lt_trichotomy i j with (hij | rfl | hij) + · simp [LenBit.add_pow2 pi pj hij, hij.ne] + · simp [LenBit.add_self h] + · have : a + j < i := + calc + a + j < 2 * j := by simp [two_mul, h] + _ ≤ i := (pj.lt_iff_two_mul_le pi).mp hij + simp [not_lenbit_of_lt this, not_lenbit_of_lt (show a < i from lt_trans h hij), hij.ne.symm] + +lemma lenbit_iff_add_mul {i a : V} (hi : Pow2 i) : + LenBit i a ↔ ∃ k, ∃ r < i, a = k * (2 * i) + i + r := + by + constructor + · intro h + have : 2 * ((a / i) / 2) + 1 = a / i := by + simpa [LenBit.iff_rem.mp h] using div_add_mod (a / i) 2 + have : a = ((a / i) / 2) * (2 * i) + i + (a % i) := + calc + a = i * (a / i) + (a % i) := Eq.symm <| div_add_mod a i + _ = i * (2 * ((a / i) / 2) + 1) + (a % i) := by simp [this] + _ = ((a / i) / 2) * (2 * i) + i + (a % i) := by + simp [mul_add, ← mul_assoc, mul_comm i 2, mul_comm (2 * i)] + exact ⟨(a / i) / 2, a % i, by simp [hi.pos], this⟩ + · rintro ⟨k, r, h, rfl⟩ + simp [LenBit.iff_rem, ← mul_assoc, add_assoc, div_mul_add_self, hi.pos, h] + +lemma not_lenbit_iff_add_mul {i a : V} (hi : Pow2 i) : + ¬LenBit i a ↔ ∃ k, ∃ r < i, a = k * (2 * i) + r := + by + constructor + · intro h + have : 2 * ((a / i) / 2) = a / i := by + simpa [not_lenbit_iff_rem.mp h] using div_add_mod (a / i) 2 + have : a = ((a / i) / 2) * (2 * i) + (a % i) := + calc + a = i * (a / i) + (a % i) := Eq.symm <| div_add_mod a i + _ = i * (2 * ((a / i) / 2)) + (a % i) := by simp [this] + _ = ((a / i) / 2) * (2 * i) + (a % i) := by + simp [← mul_assoc, mul_comm i 2, mul_comm (2 * i)] + exact ⟨(a / i) / 2, a % i, by simp [hi.pos], this⟩ + · rintro ⟨k, r, h, rfl⟩ + simp [not_lenbit_iff_rem, ← mul_assoc, div_mul_add_self, hi.pos, h] + +lemma lenbit_mul_add {i j a r : V} (pi : Pow2 i) (pj : Pow2 j) (hr : r < j) : + LenBit (i * j) (a * j + r) ↔ LenBit i a := + by + by_cases h : LenBit i a + · suffices LenBit (i * j) (a * j + r) by simpa [h] + rcases (lenbit_iff_add_mul pi).mp h with ⟨a, b, hb, rfl⟩ + have : b * j + r < i * j := + pj.mul_add_lt_of_mul_lt_of_pos (by simp [pi, pj]) ((mul_lt_mul_iff_left₀ pj.pos).mpr hb) + hr (lt_of_lt_of_le hr <| le_mul_of_pos_left <| pi.pos) + exact + (lenbit_iff_add_mul (by simp [pi, pj])).mpr + ⟨a, b * j + r, this, by simp [add_mul, add_assoc, mul_assoc]⟩ + · suffices ¬LenBit (i * j) (a * j + r) by simpa [h] + rcases (not_lenbit_iff_add_mul pi).mp h with ⟨a, b, hb, rfl⟩ + have : b * j + r < i * j := + pj.mul_add_lt_of_mul_lt_of_pos (by simp [pi, pj]) ((mul_lt_mul_iff_left₀ pj.pos).mpr hb) + hr (lt_of_lt_of_le hr <| le_mul_of_pos_left <| pi.pos) + exact + (not_lenbit_iff_add_mul (by simp [pi, pj])).mpr + ⟨a, b * j + r, this, by simp [add_mul, add_assoc, mul_assoc]⟩ + +lemma lenbit_add_pow2_iff_of_not_lenbit {a i j : V} (pi : Pow2 i) (pj : Pow2 j) + (h : ¬LenBit j a) : LenBit i (a + j) ↔ i = j ∨ LenBit i a := + by + rcases show i < j ∨ i = j ∨ i > j from lt_trichotomy i j with (hij | rfl | hij) + · simp [LenBit.add_pow2 pi pj hij, hij.ne] + · simp [LenBit.add_self_of_not_lenbit pi.pos, h] + · suffices LenBit i (a + j) ↔ LenBit i a by simpa [ne_of_gt hij] + have : 2 * j ∣ i := Pow2.dvd_of_le (by simp [pj]) pi <| (pj.lt_iff_two_mul_le pi).mp hij + rcases this with ⟨i, rfl⟩ + rcases (not_lenbit_iff_add_mul pj).mp h with ⟨a, r, hr, rfl⟩ + have pi' : Pow2 i := And.right (by simpa using pi) + have pj' : Pow2 j := And.left (by simpa using pi) + calc + LenBit (2 * j * i) (a * (2 * j) + r + j) ↔ LenBit (i * (2 * j)) (a * (2 * j) + (r + j)) := + by simp [mul_comm (2 * j), add_assoc] + _ ↔ LenBit i a := (lenbit_mul_add pi' (by simpa using pj') (by simp [two_mul, hr])) + _ ↔ LenBit (i * (2 * j)) (a * (2 * j) + r) := + (Iff.symm <| lenbit_mul_add pi' (by simpa using pj') (lt_of_lt_of_le hr <| by simp)) + _ ↔ LenBit (2 * j * i) (a * (2 * j) + r) := by simp [mul_comm] + +lemma lenbit_sub_pow2_iff_of_lenbit {a i j : V} (pi : Pow2 i) (pj : Pow2 j) (h : LenBit j a) : + LenBit i (a - j) ↔ i ≠ j ∧ LenBit i a := + by + generalize ha' : a - j = a' + have h' : ¬LenBit j a' := by simpa [← ha'] using LenBit.sub_self_of_lenbit pj.pos h + have : a = a' + j := by simp [← ha', sub_add_self_of_le h.le] + rcases this with rfl + have e : LenBit i (a' + j) ↔ i = j ∨ LenBit i a' := lenbit_add_pow2_iff_of_not_lenbit pi pj h' + suffices LenBit i a' → ¬i = j by simpa [e, and_or_left] + rintro _ rfl; contradiction + +end ISigma0 + +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/HFS.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/HFS.lean new file mode 100644 index 000000000..d7589d364 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/HFS.lean @@ -0,0 +1,23 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.HFS.Basic +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.HFS.Seq +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.HFS.PRF +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.HFS.Fixpoint +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.HFS.Vec +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.HFS.Coding + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/HFS/Basic.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/HFS/Basic.lean new file mode 100644 index 000000000..80ace72d3 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/HFS/Basic.lean @@ -0,0 +1,919 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Exponential + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +/-! +# Hereditary Finite Set Theory in $\mathsf{I}\Sigma_1$ + +-/ + +namespace FFL +namespace FirstOrder +namespace Arithmetic + +variable {V : Type*} [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +@[simp] +lemma susbset_insert (x a : V) : a ⊆ insert x a := by intro z hz; simp [hz] + +@[simp] +lemma bitRemove_susbset (x a : V) : bitRemove x a ⊆ a := by intro z; simp + +lemma lt_of_mem_dom {x y m : V} (h : ⟪x, y⟫ ∈ m) : x < m := + lt_of_le_of_lt (by simp) (lt_of_mem h) + +lemma lt_of_mem_rng {x y m : V} (h : ⟪x, y⟫ ∈ m) : y < m := + lt_of_le_of_lt (by simp) (lt_of_mem h) + +lemma insert_subset_insert_of_subset {a b : V} (x : V) (h : a ⊆ b) : insert x a ⊆ insert x b := + by + intro z hz + rcases mem_bitInsert_iff.mp hz with (rfl | hz) + · simp + · simp [h hz] + +section under + +@[simp] +lemma under_subset_under_of_le {i j : V} : under i ⊆ under j ↔ i ≤ j := + ⟨by + intro h; by_contra hij + have : j < i := by simpa using hij + simpa using h (mem_under_iff.mpr this), + by + intro hij x + simp only [mem_under_iff] + intro hx + exact lt_of_lt_of_le hx hij⟩ + +end under + +section sUnion + +lemma sUnion_exists_unique (s : V) : ∃! u : V, ∀ x, (x ∈ u ↔ ∃ t ∈ s, x ∈ t) := + by + have : Σ₁-Predicate fun x ↦ ∃ t ∈ s, x ∈ t := by definability + exact + finite_comprehension₁Proof this + ⟨s, fun i ↦ by rintro ⟨t, ht, hi⟩; exact lt_trans (lt_of_mem hi) (lt_of_mem ht)⟩ + +/-- The s Union construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def sUnion (s : V) : V := + Classical.chooseUnique (sUnion_exists_unique s) + +/-- The «term⋃ʰᶠ » construction in `FFL.FirstOrder.Arithmetic`. -/ +prefix:80 "⋃ʰᶠ " => sUnion + +@[simp] +lemma mem_sUnion_iff {a b : V} : a ∈ ⋃ʰᶠ b ↔ ∃ c ∈ b, a ∈ c := + Classical.chooseUnique_spec (sUnion_exists_unique b) a + +@[simp] +lemma sUnion_empty : (⋃ʰᶠ ∅ : V) = ∅ := + mem_ext (by simp) + +lemma sUnion_lt_of_pos {a : V} (ha : 0 < a) : ⋃ʰᶠ a < a := + lt_of_lt_log ha <| by + suffices ∀ i x, x ∈ a → i ∈ x → i < log a by simpa + intro i x hx hi + exact lt_of_lt_of_le (lt_of_mem hi) (le_log_of_mem hx) + +@[simp] +lemma sUnion_le (a : V) : ⋃ʰᶠ a ≤ a := + by + rcases Arithmetic.zero_le a with (rfl | pos) + · simp [← emptyset_def] + · exact le_of_lt (sUnion_lt_of_pos pos) + +lemma sUnion_graph {u s : V} : u = ⋃ʰᶠ s ↔ ∀ x < u + s, (x ∈ u ↔ ∃ t ∈ s, x ∈ t) := + ⟨by rintro rfl; simp, by + intro h; apply mem_ext + intro x + suffices x ∈ u ↔ ∃ c ∈ s, x ∈ c by simpa + constructor + · intro hx + exact h x (lt_of_lt_of_le (lt_of_mem hx) (by simp)) |>.mp hx + · rintro ⟨c, hc, hx⟩ + exact + h x (lt_of_lt_of_le (lt_trans (lt_of_mem hx) (lt_of_mem hc)) (by simp)) |>.mpr + ⟨c, hc, hx⟩⟩ + +/-- The s Union Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.sUnionDef : Σ₀.Semisentence 2 := + .mkSigma (“u s. ∀ x < u + s, (x ∈ u ↔ ∃ t ∈' s, x ∈ t)”) + +instance sUnion_defined : Σ₀-Function₁[V] sUnion via sUnionDef := + .mk fun v ↦ by simp [sUnionDef, sUnion_graph] + +instance sUnion_definable : Σ₀-Function₁[V] sUnion := + sUnion_defined.to_definable + +instance sUnion_definable' (ℌ : HierarchySymbol) : ℌ-Function₁[V] sUnion := + sUnion_definable.of_zero + +end sUnion + +section union + +/-- The union construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def union (a b : V) : V := + ⋃ʰᶠ { a, b } + +/-- The inst Union lean Pool construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable scoped instance instUnionModel : Union V := + ⟨union⟩ + +@[simp] +lemma mem_cup_iff {a b c : V} : a ∈ b ∪ c ↔ a ∈ b ∨ a ∈ c := by simp [Union.union, union] + +private lemma union_graph {u s t : V} : u = s ∪ t ↔ ∀ x < u + s + t, (x ∈ u ↔ x ∈ s ∨ x ∈ t) := + ⟨by rintro rfl; simp, by + intro h; apply mem_ext + intro x + suffices x ∈ u ↔ x ∈ s ∨ x ∈ t by simpa + constructor + · intro hx; exact h x (lt_of_lt_of_le (lt_of_mem hx) (by simp [add_assoc])) |>.mp hx + · rintro (hx | hx) + · exact h x (lt_of_lt_of_le (lt_of_mem hx) (by simp)) |>.mpr (Or.inl hx) + · exact h x (lt_of_lt_of_le (lt_of_mem hx) (by simp)) |>.mpr (Or.inr hx)⟩ + +/-- The union Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.unionDef : Σ₀.Semisentence 3 := + .mkSigma (“∀¹[#0 < #1 + #2 + #3] (#0 ∈ #1 ↔ #0 ∈ #2 ∨ #0 ∈ #3)”) + +instance union_defined : Σ₀-Function₂ ((· ∪ ·) : V → V → V) via unionDef := + .mk fun v ↦ by simp [unionDef, union_graph] + +instance union_definable : Σ₀-Function₂ ((· ∪ ·) : V → V → V) := + union_defined.to_definable + +instance union_definable' (ℌ : HierarchySymbol) : ℌ-Function₂ ((· ∪ ·) : V → V → V) := + union_definable.of_zero + +lemma insert_eq_union_singleton (a s : V) : insert a s = { a } ∪ s := + mem_ext (fun x ↦ by simp) + +@[simp] +lemma union_polybound (a b : V) : a ∪ b ≤ 2 * (a + b) := + by + suffices ∀ i, i ∈ a ∨ i ∈ b → i < log (2 * (a + b) + 1) from + le_iff_lt_succ.mpr <| lt_of_lt_log (by simp) <| by simpa + rintro i (hi | hi) + · calc + i ≤ log (a + b) := le_trans (le_log_of_mem hi) (log_monotone (by simp)) + _ < log (2 * (a + b)) := by + simp [log_two_mul_of_pos (show 0 < a + b from by simp [pos_of_nonempty hi])] + _ ≤ log (2 * (a + b) + 1) := log_monotone (by simp) + · calc + i ≤ log (a + b) := le_trans (le_log_of_mem hi) (log_monotone (by simp)) + _ < log (2 * (a + b)) := by + simp [log_two_mul_of_pos (show 0 < a + b from by simp [pos_of_nonempty hi])] + _ ≤ log (2 * (a + b) + 1) := log_monotone (by simp) + +instance : Bounded₂ ((· ∪ ·) : V → V → V) := + ⟨‘x y. 2 * (x + y)’, fun _ ↦ by simp⟩ + +lemma union_comm (a b : V) : a ∪ b = b ∪ a := + mem_ext (by simp [or_comm]) + +@[simp] +lemma union_succ_union_left (a b : V) : a ⊆ a ∪ b := by intro x hx; simp [hx] + +@[simp] +lemma union_succ_union_right (a b : V) : b ⊆ a ∪ b := by intro x hx; simp [hx] + +@[simp] +lemma union_succ_union_union_left (a b c : V) : a ⊆ a ∪ b ∪ c := by intro x hx; simp [hx] + +@[simp] +lemma union_succ_union_union_right (a b c : V) : b ⊆ a ∪ b ∪ c := by intro x hx; simp [hx] + +@[simp] +lemma union_empty_eq_right (a : V) : a ∪ ∅ = a := + mem_ext <| by simp + +@[simp] +lemma union_empty_eq_left (a : V) : ∅ ∪ a = a := + mem_ext <| by simp + +end union + +section sInter + +lemma sInter_exists_unique (s : V) : ∃! u : V, ∀ x, (x ∈ u ↔ s ≠ ∅ ∧ ∀ t ∈ s, x ∈ t) := + by + have : Σ₁-Predicate fun x ↦ s ≠ ∅ ∧ ∀ t ∈ s, x ∈ t := by definability + exact + finite_comprehension₁Proof this + ⟨s, fun i ↦ by + rintro ⟨hs, h⟩ + have : log s ∈ s := log_mem_of_pos <| pos_iff_ne_zero.mpr hs + exact _root_.trans (lt_of_mem <| h (log s) this) (lt_of_mem this)⟩ + +/-- The s Inter construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def sInter (s : V) : V := + Classical.chooseUnique (sInter_exists_unique s) + +/-- The «term⋂ʰᶠ » construction in `FFL.FirstOrder.Arithmetic`. -/ +prefix:80 "⋂ʰᶠ " => sInter + +lemma mem_sInter_iff {x s : V} : x ∈ ⋂ʰᶠ s ↔ s ≠ ∅ ∧ ∀ t ∈ s, x ∈ t := + Classical.chooseUnique_spec (sInter_exists_unique s) x + +@[simp] +lemma mem_sInter_iff_empty : ⋂ʰᶠ (∅ : V) = ∅ := + mem_ext (by simp [mem_sInter_iff]) + +lemma mem_sInter_iff_of_pos {x s : V} (h : s ≠ ∅) : x ∈ ⋂ʰᶠ s ↔ ∀ t ∈ s, x ∈ t := by + simp [mem_sInter_iff, h] + +end sInter + +section inter + +/-- The inter construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def inter (a b : V) : V := + ⋂ʰᶠ { a, b } + +/-- The inst Inter lean Pool construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable scoped instance instInterModel : Inter V := + ⟨inter⟩ + +@[simp] +lemma mem_inter_iff {a b c : V} : a ∈ b ∩ c ↔ a ∈ b ∧ a ∈ c := by + simp [Inter.inter, inter, + mem_sInter_iff_of_pos (s := { b, c }) (nonempty_iff.mpr ⟨b, by simp⟩)] + +lemma inter_comm (a b : V) : a ∩ b = b ∩ a := + mem_ext (by simp [and_comm]) + +lemma inter_eq_self_of_subset {a b : V} (h : a ⊆ b) : a ∩ b = a := + mem_ext (by simpa using fun i hi ↦ h hi) + +end inter + +section product + +lemma product_exists_unique (a b : V) : ∃! u : V, ∀ x, (x ∈ u ↔ ∃ y ∈ a, ∃ z ∈ b, x = ⟪y, z⟫) := + by + have : Σ₁-Predicate fun x ↦ ∃ y ∈ a, ∃ z ∈ b, x = ⟪y, z⟫ := by definability + exact + finite_comprehension₁Proof this + ⟨⟪log a, log b⟫ + 1, fun i ↦ by + rintro ⟨y, hy, z, hz, rfl⟩ + simpa [lt_succ_iff_le] using pair_le_pair (le_log_of_mem hy) (le_log_of_mem hz)⟩ + +/-- The product construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def product (a b : V) : V := + Classical.chooseUnique (product_exists_unique a b) + +/-- The «term ×ʰᶠ » construction in `FFL.FirstOrder.Arithmetic`. -/ +infixl:60 " ×ʰᶠ " => product + +lemma mem_product_iff {x a b : V} : x ∈ a ×ʰᶠ b ↔ ∃ y ∈ a, ∃ z ∈ b, x = ⟪y, z⟫ := + Classical.chooseUnique_spec (product_exists_unique a b) x + +lemma mem_product_iff' {x a b : V} : x ∈ a ×ʰᶠ b ↔ π₁ x ∈ a ∧ π₂ x ∈ b := + by + suffices (∃ y ∈ a, ∃ z ∈ b, x = ⟪y, z⟫) ↔ π₁ x ∈ a ∧ π₂ x ∈ b by simpa [mem_product_iff] + constructor + · rintro ⟨y, hy, z, hz, rfl⟩; simp [*] + · rintro ⟨h₁, h₂⟩; exact ⟨π₁ x, h₁, π₂ x, h₂, by simp⟩ + +@[simp] +lemma pair_mem_product_iff {x y a b : V} : ⟪x, y⟫ ∈ a ×ʰᶠ b ↔ x ∈ a ∧ y ∈ b := by + simp [mem_product_iff'] + +lemma pair_mem_product {x y a b : V} (hx : x ∈ a) (hy : y ∈ b) : ⟪x, y⟫ ∈ a ×ʰᶠ b := by + simpa [mem_product_iff] using ⟨hx, hy⟩ + +private lemma product_graph {u a b : V} : + u = a ×ʰᶠ b ↔ ∀ x < u + (a + b + 1) ^ 2, (x ∈ u ↔ ∃ y ∈ a, ∃ z ∈ b, x = ⟪y, z⟫) := + ⟨by rintro rfl x _; simp [mem_product_iff], + by + intro h + apply mem_ext; intro x + suffices x ∈ u ↔ ∃ y ∈ a, ∃ z ∈ b, x = ⟪y, z⟫ by simpa [mem_product_iff] + constructor + · intro hx; exact h x (lt_of_lt_of_le (lt_of_mem hx) (by simp)) |>.mp hx + · rintro ⟨y, hy, z, hz, rfl⟩ + exact + h ⟪y, z⟫ + (lt_of_lt_of_le (pair_lt_pair (lt_of_mem hy) (lt_of_mem hz)) + (le_trans (pair_polybound a b) <| by simp)) |>.mpr + ⟨y, hy, z, hz, rfl⟩⟩ + +/-- The product Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.productDef : Σ₀.Semisentence 3 := + .mkSigma (“u a b. ∀ x < u + (a + b + 1)², (x ∈ u ↔ ∃ y ∈' a, ∃ z ∈' b, !pairDef x y z)”) + +instance product_defined : Σ₀-Function₂ ((· ×ʰᶠ ·) : V → V → V) via productDef := + .mk fun v ↦ by simp [productDef, product_graph] + +instance product_definable : Σ₀-Function₂ ((· ×ʰᶠ ·) : V → V → V) := + product_defined.to_definable + +instance product_definable' (ℌ : HierarchySymbol) : ℌ-Function₂ ((· ×ʰᶠ ·) : V → V → V) := + product_definable.of_zero + +end product + +section domain + +lemma domain_exists_unique (s : V) : ∃! d : V, ∀ x, x ∈ d ↔ ∃ y, ⟪x, y⟫ ∈ s := + by + have : Σ₁-Predicate fun x ↦ ∃ y, ⟪x, y⟫ ∈ s := + HierarchySymbol.DefinablePred.of_iff (Q := fun x ↦ ∃ y < s, ⟪x, y⟫ ∈ s) (by definability) + (fun x ↦ + ⟨by rintro ⟨y, hy⟩; exact ⟨y, lt_of_le_of_lt (le_pair_right x y) (lt_of_mem hy), hy⟩, by + rintro ⟨y, _, hy⟩; exact ⟨y, hy⟩⟩) + exact + finite_comprehension₁Proof this + (⟨s, fun x ↦ by rintro ⟨y, hy⟩; exact lt_of_le_of_lt (le_pair_left x y) (lt_of_mem hy)⟩) + +/-- The domain construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def domain (s : V) : V := + Classical.chooseUnique (domain_exists_unique s) + +lemma mem_domain_iff {x s : V} : x ∈ domain s ↔ ∃ y, ⟪x, y⟫ ∈ s := + Classical.chooseUnique_spec (domain_exists_unique s) x + +private lemma domain_graph {u s : V} : + u = domain s ↔ ∀ x < u + s, (x ∈ u ↔ ∃ y < s, ∃ z ∈ s, z = ⟪x, y⟫) := + by + constructor + · rintro rfl x _ + suffices (∃ y, ⟪x, y⟫ ∈ s) ↔ ∃ y < s, ⟪x, y⟫ ∈ s by simpa [mem_domain_iff] + exact + ⟨by rintro ⟨y, hy⟩; exact ⟨y, lt_of_le_of_lt (le_pair_right x y) (lt_of_mem hy), hy⟩, by + rintro ⟨y, _, hy⟩; exact ⟨y, hy⟩⟩ + · intro h; apply mem_ext; intro x + suffices x ∈ u ↔ ∃ y, ⟪x, y⟫ ∈ s by simpa [mem_domain_iff] + constructor + · intro hx + rcases h x (lt_of_lt_of_le (lt_of_mem hx) (by simp)) |>.mp hx with ⟨y, _, _, hy, rfl⟩; + exact ⟨y, hy⟩ + · rintro ⟨y, hy⟩ + exact + h x (lt_of_lt_of_le (lt_of_le_of_lt (le_pair_left x y) (lt_of_mem hy)) (by simp)) |>.mpr + ⟨y, lt_of_le_of_lt (le_pair_right x y) (lt_of_mem hy), _, hy, rfl⟩ + +/-- The domain Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.domainDef : Σ₀.Semisentence 2 := + .mkSigma (“u s. ∀ x < u + s, (x ∈ u ↔ ∃ y < s, ∃ z ∈' s, !pairDef z x y)”) + +instance domain_defined : Σ₀-Function₁ (domain : V → V) via domainDef := + .mk fun v ↦ by simp [domainDef, domain_graph] + +instance domain_definable : Σ₀-Function₁ (domain : V → V) := + domain_defined.to_definable + +instance domain_definable' (ℌ : HierarchySymbol) : ℌ-Function₁ (domain : V → V) := + domain_definable.of_zero + +@[simp] +lemma domain_empty : domain (∅ : V) = ∅ := + mem_ext (by simp [mem_domain_iff]) + +@[simp] +lemma domain_union (a b : V) : domain (a ∪ b) = domain a ∪ domain b := + mem_ext + (by + suffices ∀ i, (∃ y, ⟪i, y⟫ ∈ a ∨ ⟪i, y⟫ ∈ b) ↔ (∃ y, ⟪i, y⟫ ∈ a) ∨ ∃ y, ⟪i, y⟫ ∈ b by + simpa [mem_domain_iff] + intro x; constructor + · rintro ⟨y, (hy | hy)⟩ + · left; exact ⟨y, hy⟩ + · right; exact ⟨y, hy⟩ + · rintro (⟨y, hy⟩ | ⟨y, hy⟩) + · exact ⟨y, Or.inl hy⟩ + · exact ⟨y, Or.inr hy⟩) + +@[simp] +lemma domain_singleton (x y : V) : (domain {⟪x, y⟫} : V) = { x } := + mem_ext (by simp [mem_domain_iff]) + +@[simp] +lemma domain_insert (x y s : V) : domain (insert ⟪x, y⟫ s) = insert x (domain s) := by + simp [insert_eq_union_singleton] + +@[simp] +lemma domain_bound (s : V) : domain s ≤ 2 * s := + le_iff_lt_succ.mpr <| + lt_of_lt_log (by simp) + (by + simp only [mem_domain_iff, forall_exists_index] + intro i x hix + exact + lt_of_le_of_lt (le_trans (le_pair_left i x) (le_log_of_mem hix)) + (by simp [log_two_mul_add_one_of_pos (pos_of_nonempty hix)])) + +instance : Bounded₁ (domain : V → V) := + ⟨‘x. 2 * x’, fun _ ↦ by simp⟩ + +lemma mem_domain_of_pair_mem {x y s : V} (h : ⟪x, y⟫ ∈ s) : x ∈ domain s := + mem_domain_iff.mpr ⟨y, h⟩ + +lemma domain_subset_domain_of_subset {s t : V} (h : s ⊆ t) : domain s ⊆ domain t := + by + intro x hx + rcases mem_domain_iff.mp hx with ⟨y, hy⟩ + exact mem_domain_iff.mpr ⟨y, h hy⟩ + +@[simp] +lemma domain_eq_empty_iff_eq_empty {s : V} : domain s = ∅ ↔ s = ∅ := + ⟨by + simp only [isempty_iff, mem_domain_iff, not_exists] + intro h x hx + exact h (π₁ x) (π₂ x) (by simpa using hx), by rintro rfl; simp⟩ + /- + @[simp] lemma domain_le_self {P : V → Prop} + (hempty : P ∅) (hinsert : ∀ s x, x ∉ s → P s → P (insert x s)) : ∀ x, P x := by { } + + @[simp] lemma domain_le_self (P : V → Prop) (s : V) : domain s ≤ s := le_iff_lt_succ.mpr + -/ + +end domain + +/-! +### Range -/ + +section range + +lemma range_exists_unique (s : V) : ∃! r : V, ∀ y, y ∈ r ↔ ∃ x, ⟪x, y⟫ ∈ s := + by + have : Σ₁-Predicate fun y ↦ ∃ x, ⟪x, y⟫ ∈ s := + HierarchySymbol.DefinablePred.of_iff (Q := fun y ↦ ∃ x < s, ⟪x, y⟫ ∈ s) (by definability) + (fun y ↦ + ⟨by rintro ⟨x, hy⟩; exact ⟨x, lt_of_le_of_lt (le_pair_left x y) (lt_of_mem hy), hy⟩, by + rintro ⟨y, _, hy⟩; exact ⟨y, hy⟩⟩) + exact + finite_comprehension₁Proof this + (⟨s, fun y ↦ by rintro ⟨x, hx⟩; exact lt_of_le_of_lt (le_pair_right x y) (lt_of_mem hx)⟩) + +/-- The range construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def range (s : V) : V := + Classical.chooseUnique (range_exists_unique s) + +lemma mem_range_iff {y s : V} : y ∈ range s ↔ ∃ x, ⟪x, y⟫ ∈ s := + Classical.chooseUnique_spec (range_exists_unique s) y + +private lemma range_graph {s' s : V} : + s' = range s ↔ ∀ y < s' + s, (y ∈ s' ↔ ∃ x < s, ∃ z ∈ s, z = ⟪x, y⟫) := + ⟨by + rintro rfl y _ + suffices (∃ x, ⟪x, y⟫ ∈ s) ↔ ∃ x < s, ⟪x, y⟫ ∈ s by simpa [mem_range_iff] + exact + ⟨by rintro ⟨x, hx⟩; exact ⟨x, lt_of_mem_dom hx, hx⟩, by rintro ⟨y, _, hy⟩; exact ⟨y, hy⟩⟩, + by + intro h + apply mem_ext + intro y + suffices y ∈ s' ↔ ∃ x, ⟪x, y⟫ ∈ s by simpa [mem_range_iff] + constructor + · intro hy + rcases h y (lt_of_lt_of_le (lt_of_mem hy) (by simp)) |>.mp hy with ⟨y, _, _, hy, rfl⟩; + exact ⟨y, hy⟩ + · rintro ⟨x, hx⟩ + exact + h y (lt_of_lt_of_le (lt_of_mem_rng hx) (by simp)) |>.mpr + ⟨x, lt_of_mem_dom hx, _, hx, rfl⟩⟩ + +/-- The range Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.rangeDef : Σ₀.Semisentence 2 := + .mkSigma (“s' s. ∀ y < s' + s, (y ∈ s' ↔ ∃ x < s, ∃ z ∈' s, !pairDef z x y)”) + +instance range_defined : Σ₀-Function₁ (range : V → V) via rangeDef := + .mk fun v ↦ by simp [rangeDef, range_graph] + +instance range_definable : Σ₀-Function₁ (range : V → V) := + range_defined.to_definable + +instance range_definable' (ℌ : HierarchySymbol) : ℌ-Function₁ (range : V → V) := + range_definable.of_zero + +@[simp] +lemma range_empty : range (∅ : V) = ∅ := + mem_ext (by simp [mem_range_iff]) + +end range + +/-! +### Disjoint -/ + +section disjoint + +/-- The Disjoint construction in `FFL.FirstOrder.Arithmetic`. -/ +def Disjoint (s t : V) : Prop := + s ∩ t = ∅ + +lemma Disjoint.iff {s t : V} : Disjoint s t ↔ ∀ x, x ∉ s ∨ x ∉ t := by + simp [Disjoint, isempty_iff, imp_iff_not_or] + +lemma Disjoint.not_of_mem {s t x : V} (hs : x ∈ s) (ht : x ∈ t) : ¬Disjoint s t := by + simpa [Disjoint.iff, not_or] using ⟨x, hs, ht⟩ + +lemma Disjoint.symm {s t : V} (h : Disjoint s t) : Disjoint t s := by + simpa [Disjoint, inter_comm t s] using h + +@[simp] +lemma Disjoint.singleton_iff {a : V} : Disjoint ({ a } : V) s ↔ a ∉ s := by + simp [Disjoint, isempty_iff] + +end disjoint + +/-! +### Mapping -/ + +section mapping + +/-- The Is Mapping construction in `FFL.FirstOrder.Arithmetic`. -/ +def IsMapping (m : V) : Prop := + ∀ x ∈ domain m, ∃! y, ⟪x, y⟫ ∈ m + +section + +private lemma isMapping_iff {m : V} : + IsMapping m ↔ + ∃ d ≤ 2 * m, + d = domain m ∧ ∀ x ∈ d, ∃ y < m, ⟪x, y⟫ ∈ m ∧ ∀ y' < m, ⟪x, y'⟫ ∈ m → y' = y := + ⟨by + intro hm + exact + ⟨domain m, by simp, rfl, fun x hx ↦ + by + rcases hm x hx with ⟨y, hy, uniq⟩ + exact ⟨y, lt_of_mem_rng hy, hy, fun y' _ h' ↦ uniq y' h'⟩⟩, + by + rintro ⟨_, _, rfl, h⟩ x hx + rcases h x hx with ⟨y, _, hxy, h⟩ + exact ExistsUnique.intro y hxy (fun y' hxy' ↦ h y' (lt_of_mem_rng hxy') hxy')⟩ + +/-- The is Mapping Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.isMappingDef : Σ₀.Semisentence 1 := + .mkSigma + (“m. + ∃ d <⁺ 2 * m, !domainDef d m ∧ ∀ x ∈' d, ∃ y < m, x ∼[m]y ∧ ∀ y' < m, x ∼[m]y' → y' = y”) + +instance isMapping_defined : Σ₀-Predicate (IsMapping : V → Prop) via isMappingDef := + .mk <| by intro v; simp [isMappingDef, isMapping_iff] + +instance isMapping_definable : Σ₀-Predicate (IsMapping : V → Prop) := + isMapping_defined.to_definable + +instance isMapping_definable' (ℌ) : ℌ-Predicate (IsMapping : V → Prop) := + isMapping_definable.of_zero + +end + +lemma IsMapping.get_exists_uniq {m : V} (h : IsMapping m) {x : V} (hx : x ∈ domain m) : + ∃! y, ⟪x, y⟫ ∈ m := + h x hx + +/-- The get construction in `FFL.FirstOrder.Arithmetic.IsMapping`. -/ +noncomputable def IsMapping.get {m : V} (h : IsMapping m) {x : V} (hx : x ∈ domain m) : V := + Classical.chooseUnique (IsMapping.get_exists_uniq h hx) + +@[simp] +lemma IsMapping.get_mem {m : V} (h : IsMapping m) {x : V} (hx : x ∈ domain m) : + ⟪x, h.get hx⟫ ∈ m := + Classical.chooseUnique_spec (IsMapping.get_exists_uniq h hx) + +lemma IsMapping.get_uniq {m : V} (h : IsMapping m) {x : V} (hx : x ∈ domain m) + (hy : ⟪x, y⟫ ∈ m) : y = h.get hx := + (h x hx).unique hy (by simp) + +@[simp] +lemma IsMapping.empty : IsMapping (∅ : V) := by intro x; simp + +lemma IsMapping.union_of_disjoint_domain {m₁ m₂ : V} (h₁ : IsMapping m₁) (h₂ : IsMapping m₂) + (disjoint : Disjoint (domain m₁) (domain m₂)) : IsMapping (m₁ ∪ m₂) := + by + intro x + suffices x ∈ domain m₁ ∨ x ∈ domain m₂ → ∃! y, ⟪x, y⟫ ∈ m₁ ∨ ⟪x, y⟫ ∈ m₂ by simpa + rintro (hx | hx) + · exact + ExistsUnique.intro (h₁.get hx) (by simp) + (by + intro y + rintro (hy | hy) + · exact h₁.get_uniq hx hy + · by_contra; exact Disjoint.not_of_mem hx (mem_domain_of_pair_mem hy) disjoint) + · exact + ExistsUnique.intro (h₂.get hx) (by simp) + (by + intro y + rintro (hy | hy) + · by_contra; exact Disjoint.not_of_mem hx (mem_domain_of_pair_mem hy) disjoint.symm + · exact h₂.get_uniq hx hy) + +@[simp] +lemma IsMapping.singleton (x y : V) : IsMapping ({⟪x, y⟫} : V) := + by + intro x; simp only [domain_singleton, mem_singleton_iff, pair_ext_iff] + rintro rfl; exact ExistsUnique.intro y (by simp) (by rintro _ ⟨_, rfl⟩; simp) + +lemma IsMapping.insert {x y m : V} (h : IsMapping m) (disjoint : x ∉ domain m) : + IsMapping (insert ⟪x, y⟫ m) := by + simpa [insert_eq_union_singleton] using + IsMapping.union_of_disjoint_domain (by simp) h (by simpa) + +lemma IsMapping.of_subset {m m' : V} (h : IsMapping m) (ss : m' ⊆ m) : IsMapping m' := + fun x hx ↦ by + rcases mem_domain_iff.mp hx with ⟨y, hy⟩ + have : ∃! y, ⟪x, y⟫ ∈ m := h x (domain_subset_domain_of_subset ss hx) + exact ExistsUnique.intro y hy (fun y' hy' ↦ this.unique (ss hy') (ss hy)) + +lemma IsMapping.uniq {m x y₁ y₂ : V} (h : IsMapping m) : ⟪x, y₁⟫ ∈ m → ⟪x, y₂⟫ ∈ m → y₁ = y₂ := + fun h₁ h₂ ↦ h x (mem_domain_iff.mpr ⟨y₁, h₁⟩) |>.unique h₁ h₂ + +end mapping + +/-! +### Restriction of mapping -/ + +section restriction + +lemma restr_exists_unique (f s : V) : ∃! g : V, ∀ x, (x ∈ g ↔ x ∈ f ∧ π₁ x ∈ s) := + by + have : Σ₁-Predicate fun x ↦ x ∈ f ∧ π₁ x ∈ s := by definability + exact finite_comprehension₁Proof this ⟨f, fun i ↦ by rintro ⟨hi, _⟩; exact lt_of_mem hi⟩ + +/-- The restr construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def restr (f s : V) : V := + Classical.chooseUnique (restr_exists_unique f s) + +/-- The «term ↾ » construction in `FFL.FirstOrder.Arithmetic`. -/ +scoped infix:80 " ↾ " => restr + +lemma mem_restr_iff {x f s : V} : x ∈ f ↾ s ↔ x ∈ f ∧ π₁ x ∈ s := + Classical.chooseUnique_spec (restr_exists_unique f s) x + +@[simp] +lemma pair_mem_restr_iff {x y f s : V} : ⟪x, y⟫ ∈ f ↾ s ↔ ⟪x, y⟫ ∈ f ∧ x ∈ s := by + simp [mem_restr_iff] + +@[simp] +lemma restr_empty (f : V) : f ↾ ∅ = ∅ := + mem_ext (by simp [mem_restr_iff]) + +@[simp] +lemma restr_subset_self (f s : V) : f ↾ s ⊆ f := fun _ hx ↦ (mem_restr_iff.mp hx).1 + +@[simp] +lemma restr_le_self (f s : V) : f ↾ s ≤ f := + le_of_subset (by simp) + +lemma IsMapping.restr {m : V} (h : IsMapping m) (s : V) : IsMapping (m ↾ s) := + h.of_subset (by simp) + +lemma domain_restr (f s : V) : domain (f ↾ s) = domain f ∩ s := + mem_ext (by simp [mem_domain_iff, pair_mem_restr_iff, exists_and_right, mem_inter_iff]) + +lemma domain_restr_of_subset_domain {f s : V} (h : s ⊆ domain f) : domain (f ↾ s) = s := by + simp [domain_restr, inter_comm, inter_eq_self_of_subset h] + +end restriction + +theorem insert_induction {P : V → Prop} (hP : Γ-[1]-Predicate P) (hempty : P ∅) + (hinsert : ∀ a s, a ∉ s → P s → P (insert a s)) : ∀ s, P s := + InductionOnHierarchy.order_induction_sigma Γ 1 hP <| + by + intro s IH + rcases eq_empty_or_nonempty s with (rfl | ⟨x, hx⟩) + · exact hempty + · simpa [insert_remove hx] using + hinsert x (bitRemove x s) (by simp) (IH _ (bitRemove_lt_of_mem hx)) + +@[elab_as_elim] +lemma insert_induction_sigmaOne {P : V → Prop} (hP : Σ₁-Predicate P) (hempty : P ∅) + (hinsert : ∀ a s, a ∉ s → P s → P (insert a s)) : ∀ s, P s := + insert_induction hP hempty hinsert + +@[elab_as_elim] +lemma insert_induction_piOne {P : V → Prop} (hP : Π₁-Predicate P) (hempty : P ∅) + (hinsert : ∀ a s, a ∉ s → P s → P (insert a s)) : ∀ s, P s := + insert_induction hP hempty hinsert + +theorem sigmaOne_skolem {R : V → V → Prop} (hP : Σ₁-Relation R) {s : V} + (H : ∀ x ∈ s, ∃ y, R x y) : ∃ f, IsMapping f ∧ domain f = s ∧ ∀ x y, ⟪x, y⟫ ∈ f → R x y := + by + have : ∀ u, u ⊆ s → ∃ f, IsMapping f ∧ domain f = u ∧ ∀ x y, ⟪x, y⟫ ∈ f → R x y := + by + intro u hu + induction u using insert_induction_sigmaOne + · have : + Σ₁-Predicate fun u ↦ + u ⊆ s → ∃ f, IsMapping f ∧ domain f = u ∧ ∀ x < f, ∀ y < f, ⟪x, y⟫ ∈ f → R x y := + by definability + exact + this.of_iff + (fun _ => + imp_congr_right + (fun _ => + exists_congr + (fun f => + and_congr_right + (fun _ => + and_congr_right + (fun _ => + ⟨fun h x _ y _ hxy => h x y hxy, fun h x y hxy => + h x (lt_of_mem_dom hxy) y (lt_of_mem_rng hxy) hxy⟩))))) + case hempty => exact ⟨∅, by simp⟩ + case hinsert a u ha + ih => + have : ∃ f, IsMapping f ∧ domain f = u ∧ ∀ x y, ⟪x, y⟫ ∈ f → R x y := + ih (subset_trans (susbset_insert a u) hu) + rcases this with ⟨f, mf, rfl, hf⟩ + have : ∃ b, R a b := H a <| And.left <| by simpa [subset_iff] using hu + rcases this with ⟨b, hb⟩ + let f' := insert ⟪a, b⟫ f + exact + ⟨f', mf.insert (by simpa using ha), by simp [f'], + by + intro x y hxy + rcases (show x = a ∧ y = b ∨ ⟪x, y⟫ ∈ f by simpa [f'] using hxy) with (⟨rfl, rfl⟩ | h) + · exact hb + · exact hf x y h⟩ + exact this s (by rfl) + +theorem sigma₁_replacement {f : V → V} (hf : Σ₁-Function₁ f) (s : V) : + ∃! t : V, ∀ y, y ∈ t ↔ ∃ x ∈ s, y = f x := + by + have : ∀ x ∈ s, ∃ y, y = f x := by intro x _; exact ⟨f x, rfl⟩ + have : ∃ F, IsMapping F ∧ domain F = s ∧ ∀ (x y : V), ⟪x, y⟫ ∈ F → y = f x := + sigmaOne_skolem (by definability) this + rcases this with ⟨F, _, rfl, hF⟩ + refine ExistsUnique.intro (range F) ?_ ?_ + · intro y + simp only [mem_range_iff] + constructor + · rintro ⟨x, hx⟩; exact ⟨x, by simpa [mem_domain_iff] using ⟨y, hx⟩, hF _ _ hx⟩ + · simp only [mem_domain_iff, forall_exists_index, and_imp] + rintro x y hxy rfl; exact ⟨x, by rcases hF _ _ hxy; exact hxy⟩ + · intro s' hs' + apply mem_ext; intro y + suffices (∃ x, (∃ y, ⟪x, y⟫ ∈ F) ∧ y = f x) ↔ ∃ x, ⟪x, y⟫ ∈ F by + simpa [hs', mem_domain_iff, mem_range_iff] + constructor + · rintro ⟨x, ⟨y, hxy⟩, rfl⟩; exact ⟨x, by rcases hF _ _ hxy; exact hxy⟩ + · rintro ⟨x, hxy⟩; exact ⟨x, ⟨y, hxy⟩, hF _ _ hxy⟩ + +theorem sigma₁_replacement₂ {f : V → V → V} (hf : Σ₁-Function₂ f) (s₁ s₂ : V) : + ∃! t : V, ∀ y, y ∈ t ↔ ∃ x₁ ∈ s₁, ∃ x₂ ∈ s₂, y = f x₁ x₂ := + by + have : Σ₁-Function₁ (fun x ↦ f (π₁ x) (π₂ x)) := by definability + exact + (existsUnique_congr + (by + intro t; apply forall_congr'; intro y; apply iff_congr (by rfl) + simp only [mem_product_iff'] + constructor + · rintro ⟨x, ⟨h₁, h₂⟩, rfl⟩; exact ⟨π₁ x, h₁, π₂ x, h₂, by rfl⟩ + · rintro ⟨x₁, h₁, x₂, h₂, rfl⟩; exact ⟨⟪x₁, x₂⟫, by simp [h₁, h₂]⟩)).mp + (sigma₁_replacement this (s₁ ×ʰᶠ s₂)) + +/-! +### Image of HFS -/ + +/-- The hfs Image construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def hfsImage (f : V → V) [Σ₁-Function₁ f] (s : V) : V := + Classical.chooseUnique (sigma₁_replacement (f := f) inferInstance s) + +variable {L} + +section hfsImage + +variable {f : V → V} [Σ₁-Function₁ f] + +lemma mem_hfsImage_iff {s y : V} : y ∈ hfsImage f s ↔ ∃ x ∈ s, y = f x := + Classical.chooseUnique_spec (sigma₁_replacement (f := f) inferInstance s) y + +lemma app_mem_hfsImage {p s : V} (h : p ∈ s) : f p ∈ hfsImage f s := + mem_hfsImage_iff.mpr ⟨p, h, rfl⟩ + +lemma hfsImage_subset_of_subset {s t : V} (h : s ⊆ t) : hfsImage f s ⊆ hfsImage f t := + by + intro y hy + rcases mem_hfsImage_iff.mp hy with ⟨x, hx, rfl⟩ + exact app_mem_hfsImage (h hx) + +@[simp] +lemma mem_hfsImage_union {s t : V} : hfsImage f (s ∪ t) = hfsImage f s ∪ hfsImage f t := + mem_ext <| by simp only [mem_hfsImage_iff, mem_cup_iff]; grind + +@[simp] +lemma mem_hfsImage_insert {x s : V} : hfsImage f (insert x s) = insert (f x) (hfsImage f s) := + mem_ext <| by simp [mem_hfsImage_iff] + +@[simp] +lemma hfsImage_empty : hfsImage f (∅ : V) = ∅ := + mem_ext <| by simp [mem_hfsImage_iff] + +section + +private lemma hfsImage_graph (t s : V) : + t = hfsImage f s ↔ (∀ y ∈ t, ∃ x ∈ s, y = f x) ∧ (∀ x ∈ s, f x ∈ t) := + by + constructor + · rintro rfl + constructor + · intro y hy; exact mem_hfsImage_iff.mp hy + · intro x hx; exact mem_hfsImage_iff.mpr ⟨x, hx, rfl⟩ + · rintro ⟨h₁, h₂⟩ + apply mem_ext; intro y; constructor + · intro hy; exact mem_hfsImage_iff.mpr (h₁ y hy) + · intro hy + rcases mem_hfsImage_iff.mp hy with ⟨x, hx, rfl⟩ + exact h₂ x hx + +/-- The graph construction in `FFL.FirstOrder.Arithmetic.hfsImage`. -/ +noncomputable def hfsImage.graph (δ : Σ₁.Semisentence 2) : Σ₁.Semisentence 2 := + .mkSigma (“t s. (∀ y ∈' t, ∃ x ∈' s, !δ y x) ∧ (∀ x ∈' s, ∃ y, !δ y x ∧ y ∈ t)”) + +/-- The defined construction in `FFL.FirstOrder.Arithmetic.hfsImage`. -/ +abbrev hfsImage.defined (f : V → V) [Σ₁-Function₁ f] (δ : Σ₁.Semisentence 2) + [Σ₁-Function₁ f via δ] : Σ₁-Function₁[V] (hfsImage f) via (hfsImage.graph δ) := + .mk fun v ↦ by simp [hfsImage.graph, hfsImage_graph] + +/-- The definable construction in `FFL.FirstOrder.Arithmetic.hfsImage`. -/ +abbrev hfsImage.definable (f : V → V) [Σ₁-Function₁ f] (δ : Σ₁.Semisentence 2) + [Σ₁-Function₁ f via δ] : Σ₁-Function₁[V] hfsImage f := + (hfsImage.defined f δ).to_definable + +end + +end hfsImage + +section fstIdx + +/-- The fst Idx construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def fstIdx (p : V) : V := + π₁(p - 1) + +@[simp] +lemma fstIdx_le_self (p : V) : fstIdx p ≤ p := + le_trans (by simp [fstIdx]) (show p - 1 ≤ p by simp) + +/-- The fst Idx Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.fstIdxDef : Σ₀.Semisentence 2 := + .mkSigma (“n p. ∃ p' <⁺ p, !subDef p' p 1 ∧ !pi₁Def n p'”) + +instance fstIdx_defined : Σ₀-Function₁ (fstIdx : V → V) via fstIdxDef := + .mk <| by intro v; simp [fstIdxDef, fstIdx] + +instance fstIdx_definable : Σ₀-Function₁ (fstIdx : V → V) := + fstIdx_defined.to_definable + +instance fstIdx_definable' (Γ) : Γ-Function₁ (fstIdx : V → V) := + fstIdx_definable.of_zero + +end fstIdx + +section sndIdx + +/-- The snd Idx construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def sndIdx (p : V) : V := + π₂(p - 1) + +@[simp] +lemma sndIdx_le_self (p : V) : sndIdx p ≤ p := + le_trans (by simp [sndIdx]) (show p - 1 ≤ p by simp) + +/-- The snd Idx Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.sndIdxDef : Σ₀.Semisentence 2 := + .mkSigma (“n p. ∃ p' <⁺ p, !subDef p' p 1 ∧ !pi₂Def n p'”) + +instance sndIdx_defined : Σ₀-Function₁ (sndIdx : V → V) via sndIdxDef := + .mk fun v ↦ by simp [sndIdxDef, sndIdx] + +instance sndIdx_definable : Σ₀-Function₁ (sndIdx : V → V) := + sndIdx_defined.to_definable + +instance sndIdx_definable' (Γ) : Γ-Function₁ (sndIdx : V → V) := + sndIdx_definable.of_zero + +end sndIdx + +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/HFS/Coding.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/HFS/Coding.lean new file mode 100644 index 000000000..91b2bfb26 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/HFS/Coding.lean @@ -0,0 +1,68 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.HFS.Vec + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace FFL +namespace FirstOrder +namespace Arithmetic + +variable {V : Type*} [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +/-- The finset Arithmetize Aux construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def finsetArithmetizeAux : List V → V + | [] => ∅ + | x :: xs => insert x (finsetArithmetizeAux xs) + +@[simp] +lemma finsetArithmetizeAux_nil : finsetArithmetizeAux ([] : List V) = ∅ := + rfl + +@[simp] +lemma finsetArithmetizeAux_cons (x : V) (xs) : + finsetArithmetizeAux (x :: xs) = insert x (finsetArithmetizeAux xs) := + rfl + +@[simp] +lemma mem_finsetArithmetizeAux_iff {x : V} {s : List V} : x ∈ finsetArithmetizeAux s ↔ x ∈ s := + by induction s <;> simp [*] + +/-- The arithmetize construction in `Finset`. -/ +noncomputable def _root_.PointwiseComposition.Finset.arithmetize (s : Finset V) : V := + finsetArithmetizeAux s.toList + +@[simp] +lemma mem_finsetArithmetize_iff {x : V} {s : Finset V} : + x ∈ (PointwiseComposition.Finset.arithmetize s) ↔ x ∈ s := by simp [Finset.arithmetize] + +@[simp] +lemma finset_empty_arithmetize : (PointwiseComposition.Finset.arithmetize (∅ : Finset V)) = ∅ := + by simp [Finset.arithmetize] + +@[simp] +lemma finset_insert_arithmetize (a : V) (s : Finset V) : + (PointwiseComposition.Finset.arithmetize (insert a s)) = + insert a (PointwiseComposition.Finset.arithmetize s) := + mem_ext <| by intro x; simp + +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/HFS/Fixpoint.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/HFS/Fixpoint.lean new file mode 100644 index 000000000..76d0e9aec --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/HFS/Fixpoint.lean @@ -0,0 +1,360 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.HFS.PRF + +/-! Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section +/-! + +# Fixpoint Construction + +-/ + +namespace FFL +namespace FirstOrder +namespace Arithmetic + +variable {V : Type*} [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +namespace Fixpoint + +-- `Fixpoint` is intentionally re-opened here even though the ambient namespace +-- already contains it; renaming would break the widely-used public API +-- (`Arithmetic.Fixpoint.*`). Suppress the new dupNamespace linter for the +-- declarations in this namespace (the option is scoped by `namespace`/`end` and +-- reverts automatically at `end Fixpoint`). + +/-- Data specifying the encoded construction in `FFL.FirstOrder.Arithmetic.Fixpoint`. -/ +structure Blueprint (k : ℕ) where + /-- The core construction in `FFL.FirstOrder.Arithmetic.Fixpoint.Blueprint`. -/ + core : ∆₁.Semisentence (k + 2) + +namespace Blueprint + +variable {k} (φ : Blueprint k) + +instance : Coe (Blueprint k) (∆₁.Semisentence (k + 2)) := + ⟨Blueprint.core⟩ + +/-- The succ Def construction in `FFL.FirstOrder.Arithmetic.Fixpoint.Blueprint`. -/ +def succDef : Σ₁.Semisentence (k + 3) := .mkSigma + “u ih s. ∀ x < u + (s + 1), (x ∈ u → x ≤ s ∧ !φ.core.sigma x ih ⋯) ∧ (x ≤ s ∧ !φ.core.pi x ih + ⋯ → x ∈ u)” + + + +/-- The pr Blueprint construction in `FFL.FirstOrder.Arithmetic.Fixpoint.Blueprint`. -/ +def prBlueprint : PR.Blueprint k where + zero := .mkSigma “x. x = 0” + succ := φ.succDef + +/-- The lim Seq Def construction in `FFL.FirstOrder.Arithmetic.Fixpoint.Blueprint`. -/ +def limSeqDef : Σ₁.Semisentence (k + 2) := + (φ.prBlueprint).resultDef + +/-- The fixpoint Def construction in `FFL.FirstOrder.Arithmetic.Fixpoint.Blueprint`. -/ +def fixpointDef : Σ₁.Semisentence (k + 1) := + .mkSigma “x. ∃ s L, !φ.limSeqDef L s ⋯ ∧ x ∈ L” + +/-- The fixpoint DefΔ₁ construction in `FFL.FirstOrder.Arithmetic.Fixpoint.Blueprint`. -/ +def fixpointDefΔ₁ : ∆₁.Semisentence (k + 1) := .mkDelta + (.mkSigma “x. ∃ L, !φ.limSeqDef L (x + 1) ⋯ ∧ x ∈ L”) + (.mkPi “x. ∀ L, !φ.limSeqDef L (x + 1) ⋯ → x ∈ L”) + +end Blueprint + +variable (V) + +/-- Data and laws for Construction in `FFL.FirstOrder.Arithmetic.Fixpoint`. -/ +structure Construction {k : ℕ} (φ : Blueprint k) where + /-- The Φ construction in `FFL.FirstOrder.Arithmetic.Fixpoint.Construction`. -/ + Φ : (Fin k → V) → Set V → V → Prop + defined : ∆₁.Defined (fun v ↦ Φ (v ·.succ.succ) {x | x ∈ v 1} (v 0)) φ.core + monotone {C C' : Set V} (h : C ⊆ C') {v x} : Φ v C x → Φ v C' x + +/-- Data and laws for Finite in `FFL.FirstOrder.Arithmetic.Fixpoint.Construction`. -/ +class Construction.Finite {k : ℕ} {φ : Blueprint k} (c : Construction V φ) where + finite {C : Set V} {v x} : c.Φ v C x → ∃ m, c.Φ v {y ∈ C | y < m} x + +/-- Data and laws for Strong Finite in `FFL.FirstOrder.Arithmetic.Fixpoint.Construction`. -/ +class Construction.StrongFinite {k : ℕ} {φ : Blueprint k} (c : Construction V φ) where + strong_finite {C : Set V} {v x} : c.Φ v C x → c.Φ v {y ∈ C | y < x} x + +instance {k : ℕ} {φ : Blueprint k} (c : Construction V φ) [c.StrongFinite] : c.Finite where + finite {_ _ x} := fun h ↦ ⟨x, Construction.StrongFinite.strong_finite h⟩ + +variable {V} + +namespace Construction + +variable {k : ℕ} {φ : Blueprint k} (c : Construction V φ) (v : Fin k → V) + +lemma eval_formula (v : Fin k.succ.succ → V) : + φ.core.val.Evalb v ↔ c.Φ (v ·.succ.succ) {x | x ∈ v 1} (v 0) := + c.defined.iff + +lemma succ_existsUnique (s ih : V) : + ∃! u : V, ∀ x, (x ∈ u ↔ x ≤ s ∧ c.Φ v {z | z ∈ ih} x) := by + have : Σ₁-Predicate fun x ↦ x ≤ s ∧ c.Φ v {z | z ∈ ih} x := by + apply HierarchySymbol.Definable.and (by definability) + ⟨φ.core.sigma.rew <| Rew.embSubsts (#0 :> &ih :> fun i ↦ &(v i)), + by intro x; simp [HierarchySymbol.Semiformula.val_sigma, c.eval_formula]⟩ + exact finite_comprehension₁Proof this + ⟨s + 1, fun i ↦ by rintro ⟨hi, _⟩; exact lt_succ_iff_le.mpr hi⟩ + +/-- The succ construction in `FFL.FirstOrder.Arithmetic.Fixpoint.Construction`. -/ +noncomputable def succ (s ih : V) : V := + Classical.chooseUnique (c.succ_existsUnique v s ih) + +variable {v} + +lemma mem_succ_iff {v s ih} : x ∈ c.succ v s ih ↔ x ≤ s ∧ c.Φ v {z | z ∈ ih} x := + Classical.chooseUnique_spec (c.succ_existsUnique v s ih) x + +private lemma succ_graph {u v s ih} : + u = c.succ v s ih ↔ ∀ x < u + (s + 1), x ∈ u ↔ x ≤ s ∧ c.Φ v {z | z ∈ ih} x := + ⟨by rintro rfl x _; simp [mem_succ_iff], by + intro h; apply mem_ext + intro x; constructor + · intro hx; + exact c.mem_succ_iff.mpr <| h x (lt_of_lt_of_le (lt_of_mem hx) (by simp)) |>.mp hx + · intro hx + exact + h x (lt_of_lt_of_le (lt_succ_iff_le.mpr (c.mem_succ_iff.mp hx).1) (by simp)) |>.mpr + (c.mem_succ_iff.mp hx)⟩ + +lemma succ_defined : + Σ₁.DefinedFunction (fun v : Fin (k + 2) → V ↦ c.succ (v ·.succ.succ) (v 1) (v 0)) + φ.succDef := + .mk fun v ↦ + by + simp [Blueprint.succDef, succ_graph, HierarchySymbol.Semiformula.val_sigma, c.eval_formula, + c.defined.proper.iff', -and_imp, BinderNotation.finSuccItr] + grind + +lemma eval_succDef (v : Fin (k + 3) → V) : + φ.succDef.val.Evalb v ↔ v 0 = c.succ (v ·.succ.succ.succ) (v 2) (v 1) := + c.succ_defined.iff + +/-- The pr Construction construction in `FFL.FirstOrder.Arithmetic.Fixpoint.Construction`. -/ +noncomputable def prConstruction : PR.Construction V φ.prBlueprint + where + zero := fun _ ↦ ∅ + succ := c.succ + zero_defined := .mk fun v ↦ by simp [Blueprint.prBlueprint, emptyset_def] + succ_defined := .mk fun v ↦ by simp [Blueprint.prBlueprint, c.eval_succDef] + +variable (v) + +/-- The lim Seq construction in `FFL.FirstOrder.Arithmetic.Fixpoint.Construction`. -/ +noncomputable def limSeq (s : V) : V := + c.prConstruction.result v s + +variable {v} + +@[simp] +lemma limSeq_zero : c.limSeq v 0 = ∅ := by simp [limSeq, prConstruction] + +lemma limSeq_succ (s : V) : c.limSeq v (s + 1) = c.succ v s (c.limSeq v s) := by + simp [limSeq, prConstruction] + +lemma termSet_defined : Σ₁.DefinedFunction (fun v ↦ c.limSeq (v ·.succ) (v 0)) φ.limSeqDef := + .mk fun v ↦ by simp [c.prConstruction.result_defined_iff, Blueprint.limSeqDef]; rfl + +lemma eval_limSeqDef (v : Fin (k + 2) → V) : + φ.limSeqDef.val.Evalb v ↔ v 0 = c.limSeq (v ·.succ.succ) (v 1) := + c.termSet_defined.iff + +instance limSeq_definable : Σ₁.DefinableFunction (fun v ↦ c.limSeq (v ·.succ) (v 0)) := + c.termSet_defined.to_definable + +@[definability] +instance limSeq_definable' (Γ) : + Γ-[m + 1].DefinableFunction (fun v ↦ c.limSeq (v ·.succ) (v 0)) := + c.limSeq_definable.of_sigmaOne + +@[simp] +lemma mem_limSeq_succ_iff {x s : V} : + x ∈ c.limSeq v (s + 1) ↔ x ≤ s ∧ c.Φ v {z | z ∈ c.limSeq v s} x := by + simp [limSeq_succ, mem_succ_iff] + +lemma limSeq_cumulative {s s' : V} : s ≤ s' → c.limSeq v s ⊆ c.limSeq v s' := by + induction s' using ISigma1.sigma1_succ_induction generalizing s + · apply HierarchySymbol.Definable.ball_le (by definability) + apply HierarchySymbol.Definable.comp₂ + · exact ⟨φ.limSeqDef.rew <| Rew.embSubsts (#0 :> #1 :> fun i ↦ &(v i)), by intro v; simp + [c.eval_limSeqDef]⟩ + · exact ⟨φ.limSeqDef.rew <| Rew.embSubsts (#0 :> #2 :> fun i ↦ &(v i)), by intro v; simp + [c.eval_limSeqDef]⟩ + case zero => + simp only [nonpos_iff_eq_zero, limSeq_zero]; rintro rfl; simp + case succ s' ih => + intro hs u hu + rcases zero_or_succ s with (rfl | ⟨s, rfl⟩) + · simp at hu + have hs : s ≤ s' := by simpa using hs + rcases c.mem_limSeq_succ_iff.mp hu with ⟨hu, Hu⟩ + exact c.mem_limSeq_succ_iff.mpr ⟨_root_.le_trans hu hs, c.monotone (fun z hz ↦ ih hs hz) Hu⟩ + +lemma mem_limSeq_self [c.StrongFinite] {u s : V} : + u ∈ c.limSeq v s → u ∈ c.limSeq v (u + 1) := by + induction u using ISigma1.pi1_order_induction generalizing s + · apply HierarchySymbol.Definable.all + apply HierarchySymbol.Definable.imp + · apply HierarchySymbol.Definable.comp₂ + ⟨φ.limSeqDef.rew <| Rew.embSubsts (#0 :> #1 :> fun i ↦ &(v i)), by intro v; simp + [c.eval_limSeqDef]⟩ + (by definability) + · apply HierarchySymbol.Definable.comp₂ + ⟨φ.limSeqDef.rew <| Rew.embSubsts (#0 :> ‘#2 + 1’ :> fun i ↦ &(v i)), by intro v; simp + [c.eval_limSeqDef]⟩ + (by definability) + case ind u ih => + rcases zero_or_succ s with (rfl | ⟨s, rfl⟩) + · simp + intro hu + rcases c.mem_limSeq_succ_iff.mp hu with ⟨_, Hu⟩ + have : c.Φ v {z | z ∈ c.limSeq v s ∧ z < u} u := StrongFinite.strong_finite Hu + have : c.Φ v {z | z ∈ c.limSeq v u} u := + c.monotone (by + simp only [Set.ofPred_subset_ofPred, and_imp] + intro z hz hzu + exact c.limSeq_cumulative (succ_le_iff_lt.mpr hzu) (ih z hzu hz)) + this + exact c.mem_limSeq_succ_iff.mpr ⟨by rfl, this⟩ + +variable (v) + +/-- The Fixpoint construction in `FFL.FirstOrder.Arithmetic.Fixpoint.Construction`. -/ +def IsFixedPoint (x : V) : Prop := + ∃ s, x ∈ c.limSeq v s + +variable {v} + +lemma fixpoint_iff [c.StrongFinite] {x : V} : c.IsFixedPoint v x ↔ x ∈ c.limSeq v (x + 1) := + ⟨by rintro ⟨s, hs⟩; exact c.mem_limSeq_self hs, fun h ↦ ⟨x + 1, h⟩⟩ + +lemma fixpoint_iff_succ {x : V} : c.IsFixedPoint v x ↔ ∃ u, x ∈ c.limSeq v (u + 1) := + ⟨by + rintro ⟨u, h⟩ + rcases zero_or_succ u with (rfl | ⟨u, rfl⟩) + · simp at h + · exact ⟨u, h⟩, by rintro ⟨u, h⟩; exact ⟨u + 1, h⟩⟩ + +lemma finite_upperbound (m : V) : ∃ s, ∀ z < m, c.IsFixedPoint v z → z ∈ c.limSeq v s := by + have : ∃ F : V, ∀ x, x ∈ F ↔ x < m ∧ c.IsFixedPoint v x := by + have : Σ₁-Predicate fun x ↦ x < m ∧ c.IsFixedPoint v x := + HierarchySymbol.Definable.and (by definability) + (HierarchySymbol.Definable.exs + (HierarchySymbol.Definable.comp₂ + ⟨φ.limSeqDef.rew <| Rew.embSubsts (#0 :> #1 :> fun i ↦ &(v i)), by intro v; simp + [c.eval_limSeqDef]⟩ + (by definability))) + exact finite_comprehension₁Proof this ⟨m, fun i hi ↦ hi.1⟩ |>.exists + rcases this with ⟨F, hF⟩ + have : ∀ x ∈ F, ∃ u, x ∈ c.limSeq v u := by + intro x hx; exact hF x |>.mp hx |>.2 + have : ∃ f, IsMapping f ∧ domain f = F ∧ ∀ (x y : V), ⟪x, y⟫ ∈ f → x ∈ c.limSeq v y := + sigmaOne_skolem + (by apply HierarchySymbol.Definable.comp₂ + ⟨φ.limSeqDef.rew <| Rew.embSubsts (#0 :> #2 :> fun i ↦ &(v i)), by intro v; simp + [c.eval_limSeqDef]⟩ + (by definability)) this + rcases this with ⟨f, mf, rfl, hf⟩ + exact ⟨f, by + intro z hzm hz + have : ∃ u, ⟪z, u⟫ ∈ f := mf.get_exists_uniq ((hF z).mpr ⟨hzm, hz⟩) |>.exists + rcases this with ⟨u, hu⟩ + have : z ∈ c.limSeq v u := hf z u hu + exact c.limSeq_cumulative (le_of_lt <| lt_of_mem_rng hu) this⟩ + +theorem case [c.Finite] : c.IsFixedPoint v x ↔ c.Φ v {z | c.IsFixedPoint v z} x := + ⟨by + intro h + rcases c.fixpoint_iff_succ.mp h with ⟨u, hu⟩ + have : c.Φ v {z | z ∈ c.limSeq v u} x := (c.mem_limSeq_succ_iff.mp hu).2 + exact c.monotone (fun z hx ↦ by exact ⟨u, hx⟩) this, + by + intro hx + rcases Finite.finite hx with ⟨m, hm⟩ + have : ∃ s, ∀ z < m, c.IsFixedPoint v z → z ∈ c.limSeq v s := c.finite_upperbound m + rcases this with ⟨s, hs⟩ + have : c.Φ v {z | z ∈ c.limSeq v s} x := + c.monotone + (by + simp only [Set.ofPred_subset_ofPred, and_imp] + intro z hz hzm; exact hs z hzm hz) + hm + exact + ⟨max s x + 1, + c.mem_limSeq_succ_iff.mpr <| + ⟨by simp, c.monotone (fun z hz ↦ c.limSeq_cumulative (by simp) hz) this⟩⟩⟩ + +section + +lemma fixpoint_defined : Σ₁.Defined (fun v ↦ c.IsFixedPoint (v ·.succ) (v 0)) φ.fixpointDef := + .mk fun v ↦ by simp [Blueprint.fixpointDef, c.eval_limSeqDef]; rfl + +lemma eval_fixpointDef (v : Fin (k + 1) → V) : + φ.fixpointDef.val.Evalb v ↔ c.IsFixedPoint (v ·.succ) (v 0) := + c.fixpoint_defined.iff + +lemma fixpoint_definedΔ₁ [c.StrongFinite] : ∆₁.Defined (fun v ↦ c.IsFixedPoint (v ·.succ) (v 0)) + φ.fixpointDefΔ₁ := + ⟨by intro v; simp [Blueprint.fixpointDefΔ₁, c.eval_limSeqDef], + by intro v; simp [Blueprint.fixpointDefΔ₁, c.eval_limSeqDef, fixpoint_iff]⟩ + + + +lemma eval_fixpointDefΔ₁ [c.StrongFinite] (v : Fin (k + 1) → V) : + φ.fixpointDefΔ₁.val.Evalb v ↔ c.IsFixedPoint (v ·.succ) (v 0) := + c.fixpoint_definedΔ₁.iff + +end + +theorem induction [c.StrongFinite] {P : V → Prop} (hP : Γ-[1]-Predicate P) + (H : ∀ C : Set V, (∀ x ∈ C, c.IsFixedPoint v x ∧ P x) → ∀ x, c.Φ v C x → P x) : + ∀ x, c.IsFixedPoint v x → P x := + by + apply + InductionOnHierarchy.order_induction_sigma (Γ := Γ) (s := 1) (P := fun x ↦ + c.IsFixedPoint v x → P x) + · apply + HierarchySymbol.Definable.imp + (HierarchySymbol.DefinablePred.comp + (by + apply HierarchySymbol.Definable.of_deltaOne + exact + ⟨φ.fixpointDefΔ₁.rew <| Rew.embSubsts <| #0 :> fun x ↦ &(v x), + c.fixpoint_definedΔ₁.proper.rew' _, by intro v; simp [c.eval_fixpointDefΔ₁]⟩) + (by definability)) + (by definability) + intro x ih hx + have : c.Φ v {y | c.IsFixedPoint v y ∧ y < x} x := StrongFinite.strong_finite (c.case.mp hx) + exact + H {y | c.IsFixedPoint v y ∧ y < x} (by intro y ⟨hy, hyx⟩; exact ⟨hy, ih y hyx hy⟩) x this + +end Construction + +attribute [irreducible] Blueprint.fixpointDef + +end Fixpoint + +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/HFS/PRF.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/HFS/PRF.lean new file mode 100644 index 000000000..3ff67254e --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/HFS/PRF.lean @@ -0,0 +1,290 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.HFS.Seq + +/-! Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section +/-! + +# Primitive Recursive Functions in $\mathsf{I} \Sigma_1$ + +-/ + +namespace FFL +namespace FirstOrder +namespace Arithmetic + +variable {V : Type*} [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +namespace PR + +/-- Data specifying the encoded construction in `FFL.FirstOrder.Arithmetic.PR`. -/ +structure Blueprint (k : ℕ) where + /-- The zero construction in `FFL.FirstOrder.Arithmetic.PR.Blueprint`. -/ + zero : Σ₁.Semisentence (k + 1) + /-- The succ construction in `FFL.FirstOrder.Arithmetic.PR.Blueprint`. -/ + succ : Σ₁.Semisentence (k + 3) + +/-- The cseq Def construction in `FFL.FirstOrder.Arithmetic.PR.Blueprint`. -/ +def Blueprint.cseqDef (p : Blueprint k) : Σ₁.Semisentence (k + 1) := .mkSigma + “s. + :Seq s + ∧ (∃ z < s, !p.zero z ⋯ ∧ 0 ∼[s] z) + ∧ (∀ i < 2 * s, + (∃ l <⁺ 2 * s, !lhDef l s ∧ i + 1 < l) → + ∀ z < s, i ∼[s] z → ∃ u < s, !p.succ u z i ⋯ ∧ i + 1 ∼[s] u)” + +/-- The result Def construction in `FFL.FirstOrder.Arithmetic.PR.Blueprint`. -/ +def Blueprint.resultDef (p : Blueprint k) : Σ₁.Semisentence (k + 2) := .mkSigma + “z u. ∃ s, !p.cseqDef s ⋯ ∧ u ∼[s] z” + +/-- The result Delta Def construction in `FFL.FirstOrder.Arithmetic.PR.Blueprint`. -/ +def Blueprint.resultDeltaDef (p : Blueprint k) : ∆₁.Semisentence (k + 2) := + p.resultDef.graphDelta + +variable (V) + +/-- Data and laws for Construction in `FFL.FirstOrder.Arithmetic.PR`. -/ +structure Construction {k : ℕ} (p : Blueprint k) where + /-- The zero construction in `FFL.FirstOrder.Arithmetic.PR.Construction`. -/ + zero : (Fin k → V) → V + /-- The succ construction in `FFL.FirstOrder.Arithmetic.PR.Construction`. -/ + succ : (Fin k → V) → V → V → V + zero_defined : Σ₁.DefinedFunction zero p.zero + succ_defined : Σ₁.DefinedFunction (fun v ↦ succ (v ·.succ.succ) (v 1) (v 0)) p.succ + +variable {V} + +namespace Construction + +variable {k : ℕ} {p : Blueprint k} (c : Construction V p) (v : Fin k → V) + +/-- The CSeq construction in `FFL.FirstOrder.Arithmetic.PR.Construction`. -/ +def CSeq (s : V) : Prop := + Seq s ∧ ⟪0, c.zero v⟫ ∈ s ∧ ∀ i < lh s - 1, ∀ z, ⟪i, z⟫ ∈ s → ⟪i + 1, c.succ v i z⟫ ∈ s + +private lemma cseq_iff (s : V) : + c.CSeq v s ↔ + Seq s ∧ + (∃ z < s, z = c.zero v ∧ ⟪0, z⟫ ∈ s) ∧ + (∀ i < 2 * s, + (∃ l ≤ 2 * s, l = lh s ∧ i + 1 < l) → + ∀ z < s, ⟪i, z⟫ ∈ s → ∃ u < s, u = c.succ v i z ∧ ⟪i + 1, u⟫ ∈ s) := + ⟨by + rintro ⟨Hs, hz, hs⟩ + exact + ⟨Hs, ⟨c.zero v, lt_of_mem_rng hz, rfl, hz⟩, fun i _ hi z _ hiz ↦ + ⟨c.succ v i z, + by + have := hs i (by rcases hi with ⟨l, _, rfl, hl⟩; simp [lt_tsub_iff_right, hl]) z hiz + exact ⟨lt_of_mem_rng this, rfl, this⟩⟩⟩, + by + rintro ⟨Hs, ⟨z, _, rfl, hz⟩, h⟩ + exact + ⟨Hs, hz, fun i hi z hiz ↦ + by + rcases + h i (lt_of_lt_of_le hi (by simpa using le_trans (lh_bound _) (by simp))) + ⟨lh s, by simp, rfl, by simpa [lt_tsub_iff_right] using hi⟩ z (lt_of_mem_rng hiz) + hiz with + ⟨_, _, rfl, h⟩ + exact h⟩⟩ + +lemma cseq_defined : + Σ₁.Defined (fun v ↦ c.CSeq (v ·.succ) (v 0) : (Fin (k + 1) → V) → Prop) p.cseqDef := + .mk fun v ↦ by simp [Blueprint.cseqDef, cseq_iff, c.zero_defined.iff, c.succ_defined.iff] + +lemma cseq_defined_iff (v : Fin (k + 1) → V) : + p.cseqDef.val.Evalb v ↔ c.CSeq (v ·.succ) (v 0) := + c.cseq_defined.iff + +variable {c v} + +/-! ## Helper lemmas for `Cseq`s -/ + +namespace CSeq + +variable {s : V} + +lemma seq (h : c.CSeq v s) : Seq s := + h.1 + +lemma zero (h : c.CSeq v s) : ⟪0, c.zero v⟫ ∈ s := + h.2.1 + +lemma succ (h : c.CSeq v s) : ∀ i < lh s - 1, ∀ z, ⟪i, z⟫ ∈ s → ⟪i + 1, c.succ v i z⟫ ∈ s := + h.2.2 + +lemma unique {s₁ s₂ : V} (H₁ : c.CSeq v s₁) (H₂ : c.CSeq v s₂) (h₁₂ : lh s₁ ≤ lh s₂) {i} (hi : i + < lh s₁) {z₁ z₂} : + ⟪i, z₁⟫ ∈ s₁ → ⟪i, z₂⟫ ∈ s₂ → z₁ = z₂ := by + revert z₁ z₂ + suffices ∀ z₁ < s₁, ∀ z₂ < s₂, ⟪i, z₁⟫ ∈ s₁ → ⟪i, z₂⟫ ∈ s₂ → z₁ = z₂ + by intro z₁ z₂ hz₁ hz₂; exact this z₁ (lt_of_mem_rng hz₁) z₂ (lt_of_mem_rng hz₂) hz₁ hz₂ + intro z₁ hz₁ z₂ hz₂ h₁ h₂ + induction i using ISigma1.sigma1_succ_induction generalizing z₁ z₂ + · definability + case zero => + have : z₁ = c.zero v := H₁.seq.isMapping.uniq h₁ H₁.zero + have : z₂ = c.zero v := H₂.seq.isMapping.uniq h₂ H₂.zero + simp_all + case succ i ih => + have hi' : i < lh s₁ := lt_of_le_of_lt (by simp) hi + let z' := H₁.seq.nth hi' + have ih₁ : ⟪i, z'⟫ ∈ s₁ := H₁.seq.nth_mem hi' + have ih₂ : ⟪i, z'⟫ ∈ s₂ := by + have : z' = H₂.seq.nth (lt_of_lt_of_le hi' h₁₂) := + ih hi' z' (by simp [z']) (H₂.seq.nth (lt_of_lt_of_le hi' h₁₂)) (by simp) (by simp [z']) + (by simp) + simp [this] + have h₁' : ⟪i + 1, c.succ v i z'⟫ ∈ s₁ := H₁.succ i (by simp [lt_tsub_iff_right, hi]) z' ih₁ + have h₂' : ⟪i + 1, c.succ v i z'⟫ ∈ s₂ := + H₂.succ i (by simpa [lt_tsub_iff_right] using lt_of_lt_of_le hi h₁₂) z' ih₂ + have e₁ : z₁ = c.succ v i z' := H₁.seq.isMapping.uniq h₁ h₁' + have e₂ : z₂ = c.succ v i z' := H₂.seq.isMapping.uniq h₂ h₂' + simp [e₁, e₂] + + + +lemma initial : c.CSeq v !⟦c.zero v⟧ := + ⟨by simp, by simp [seqCons], by simp⟩ + +lemma successor {s l z : V} (Hs : c.CSeq v s) (hl : l + 1 = lh s) (hz : ⟪l, z⟫ ∈ s) : + c.CSeq v (s ⁀' c.succ v l z) := + ⟨Hs.seq.seqCons _, by simp [seqCons, Hs.zero], + by + simp only [Hs.seq.lh_seqCons, add_tsub_cancel_right] + intro i hi w hiw + have hiws : ⟪i, w⟫ ∈ s := + by + rcases + show i = lh s ∧ w = c.succ v l z ∨ ⟪i, w⟫ ∈ s by simpa [mem_seqCons_iff] using hiw with + (⟨rfl, rfl⟩ | h) + · simp at hi + · assumption + have : i ≤ l := by simpa [← hl, lt_succ_iff_le] using hi + rcases this with (rfl | hil) + · have : w = z := Hs.seq.isMapping.uniq hiws hz + simp [this, hl] + · simp only [mem_seqCons_iff]; right + exact Hs.succ i (by simp [← hl, hil]) w hiws⟩ + +end CSeq + +/-! ## Result of primitive recursion -/ + +variable (c v) + +open _root_.Classical Classical in +lemma CSeq.exists (l : V) : ∃ s, c.CSeq v s ∧ l + 1 = lh s := by + induction l using ISigma1.sigma1_succ_induction + · apply HierarchySymbol.Definable.exs + apply HierarchySymbol.Definable.and + · exact ⟨p.cseqDef.rew (Rew.embSubsts <| #0 :> fun i ↦ &(v i)), by + intro w; simpa [Matrix.comp_vecCons''] using! c.cseq_defined_iff (w 0 :> v)⟩ + · definability + case zero => + exact ⟨!⟦c.zero v⟧, CSeq.initial, by simp⟩ + case succ l ih => + rcases ih with ⟨s, Hs, hls⟩ + have hl : l < lh s := by simp [←hls] + have : ∃ z, ⟪l, z⟫ ∈ s := Hs.seq.exists hl + rcases this with ⟨z, hz⟩ + exact ⟨s ⁀' c.succ v l z, Hs.successor hls hz, by simp [Hs.seq, hls]⟩ + +lemma cSeq_result_existsUnique (l : V) : ∃! z, ∃ s, c.CSeq v s ∧ l + 1 = lh s ∧ ⟪l, z⟫ ∈ s := + by + rcases CSeq.exists c v l with ⟨s, Hs, h⟩ + have : ∃ z, ⟪l, z⟫ ∈ s := Hs.seq.exists (show l < lh s from by simp [← h]) + rcases this with ⟨z, hz⟩ + exact + ExistsUnique.intro z ⟨s, Hs, h, hz⟩ + (by + rintro z' ⟨s', Hs', h', hz'⟩ + exact + Eq.symm <| + Hs.unique Hs' (by simp [← h, ← h']) (show l < lh s from by simp [← h]) hz hz') + +/-- The result construction in `FFL.FirstOrder.Arithmetic.PR.Construction`. -/ +noncomputable def result (u : V) : V := + Classical.chooseUnique (c.cSeq_result_existsUnique v u) + +lemma result_spec (u : V) : ∃ s, c.CSeq v s ∧ u + 1 = lh s ∧ ⟪u, c.result v u⟫ ∈ s := + Classical.chooseUnique_spec (c.cSeq_result_existsUnique v u) + +@[simp] +theorem result_zero : c.result v 0 = c.zero v := + by + rcases c.result_spec v 0 with ⟨s, Hs, _, h0⟩ + exact Hs.seq.isMapping.uniq h0 Hs.zero + +@[simp] +theorem result_succ (u : V) : c.result v (u + 1) = c.succ v u (c.result v u) := + by + rcases c.result_spec v u with ⟨s, Hs, hk, h⟩ + have : CSeq c v (s ⁀' c.succ v u (result c v u)) := Hs.successor hk h + exact + Eq.symm <| + Classical.choose_uniq (c.cSeq_result_existsUnique v (u + 1)) + ⟨_, this, by simp [Hs.seq, hk], by simp [hk]⟩ + +lemma result_graph (z u : V) : z = c.result v u ↔ ∃ s, c.CSeq v s ∧ ⟪u, z⟫ ∈ s := + ⟨by + rintro rfl + rcases c.result_spec v u with ⟨s, Hs, _, h⟩ + exact ⟨s, Hs, h⟩, by + rintro ⟨s, Hs, h⟩ + rcases c.result_spec v u with ⟨s', Hs', hu, h'⟩ + exact + Eq.symm <| + Hs'.unique Hs + (by + simpa [← hu, succ_le_iff_lt] using Hs.seq.lt_lh_iff.mpr (mem_domain_of_pair_mem h)) + (by simp [← hu]) h' h⟩ + +lemma result_defined : + Σ₁.DefinedFunction (fun v ↦ c.result (v ·.succ) (v 0) : (Fin (k + 1) → V) → V) + p.resultDef := + .mk fun v ↦ by simp [Blueprint.resultDef, result_graph, c.cseq_defined_iff] + +lemma result_defined_delta : + ∆₁.DefinedFunction (fun v ↦ c.result (v ·.succ) (v 0) : (Fin (k + 1) → V) → V) + p.resultDeltaDef := + c.result_defined.graph_delta + +lemma result_defined_iff (v : Fin (k + 2) → V) : + p.resultDef.val.Evalb v ↔ v 0 = c.result (v ·.succ.succ) (v 1) := + c.result_defined.iff + +instance result_definable : + Σ₁.DefinableFunction (fun v ↦ c.result (v ·.succ) (v 0) : (Fin (k + 1) → V) → V) := + c.result_defined.to_definable + +instance result_definable_delta₁ : + ∆₁.DefinableFunction (fun v ↦ c.result (v ·.succ) (v 0) : (Fin (k + 1) → V) → V) := + c.result_defined_delta.to_definable + +attribute [irreducible] Blueprint.resultDef + +end Construction + +end PR + +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/HFS/Seq.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/HFS/Seq.lean new file mode 100644 index 000000000..a48c4a0c8 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/HFS/Seq.lean @@ -0,0 +1,556 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.HFS.Basic + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +/-! +# Sequence + +-/ + +namespace FFL +namespace FirstOrder +namespace Arithmetic + +variable {V : Type*} [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +/-- The Seq construction in `FFL.FirstOrder.Arithmetic`. -/ +def Seq (s : V) : Prop := + IsMapping s ∧ ∃ l, domain s = under l + +theorem Seq.isMapping {s : V} (h : Seq s) : IsMapping s := + h.1 + +private lemma seq_iff (s : V) : + Seq s ↔ IsMapping s ∧ ∃ l ≤ 2 * s, ∃ d ≤ 2 * s, d = domain s ∧ d = under l := + ⟨by + rintro ⟨hs, l, h⟩ + exact + ⟨hs, l, + (by + calc + l ≤ domain s := by simp [h] + _ ≤ 2 * s := by simp), + ⟨domain s, by simp, rfl, h⟩⟩, + by rintro ⟨hs, l, _, _, _, rfl, h⟩; exact ⟨hs, l, h⟩⟩ + +/-- The seq Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.seqDef : Σ₀.Semisentence 1 := + .mkSigma (“s. !isMappingDef s ∧ ∃ l <⁺ 2 * s, ∃ d <⁺ 2 * s, !domainDef d s ∧ !underDef d l”) + +instance seq_defined : Σ₀-Predicate (Seq : V → Prop) via seqDef := + .mk <| by intro v; simp [seqDef, seq_iff, -existsAndEq] + +instance seq_definable : Σ₀-Predicate (Seq : V → Prop) := + seq_defined.to_definable + +instance seq_definable' (ℌ) : ℌ-Predicate (Seq : V → Prop) := + seq_definable.of_zero + +section + +open _root_.Lean Lean PrettyPrinter Delaborator + +/-- The «first order formula:Seq » construction in `FFL.FirstOrder.Arithmetic`. -/ +syntax ":Seq " firstOrderTerm : firstOrderFormula + +scoped macro_rules + | `(quoteformula($type)[$binders* | $fbinders* | :Seq $t:firstOrderTerm]) => + `(quoteformula($type)[$binders* | $fbinders* | !seqDef.val$t]) + +end + +lemma lh_exists_uniq (s : V) : ∃! l, (Seq s → domain s = under l) ∧ (¬Seq s → l = 0) := + by + by_cases h : Seq s + · rcases h with ⟨h, l, hl⟩ + exact + ExistsUnique.intro l (by simp [show Seq s from ⟨h, l, hl⟩, hl]) + (by simp [show Seq s from ⟨h, l, hl⟩, hl]) + · simp [h] + +/-- The lh construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def lh (s : V) : V := + Classical.chooseUnique (lh_exists_uniq s) + +lemma lh_prop (s : V) : (Seq s → domain s = under (lh s)) ∧ (¬Seq s → lh s = 0) := + Classical.chooseUnique_spec (lh_exists_uniq s) + +lemma lh_prop_of_not_seq {s : V} (h : ¬Seq s) : lh s = 0 := + (lh_prop s).2 h + +lemma Seq.domain_eq {s : V} (h : Seq s) : domain s = under (lh s) := + (lh_prop s).1 h + +@[simp] +lemma lh_bound (s : V) : lh s ≤ 2 * s := + by + by_cases hs : Seq s + · calc + lh s ≤ under (lh s) := le_under _ + _ ≤ 2 * s := by simp [← hs.domain_eq] + · simp [lh_prop_of_not_seq hs] + +private lemma lh_graph (l s : V) : + l = lh s ↔ (Seq s → ∃ d ≤ 2 * s, d = domain s ∧ d = under l) ∧ (¬Seq s → l = 0) := + ⟨by + rintro rfl + by_cases Hs : Seq s <;> simp [Hs, ← Seq.domain_eq, lh_prop_of_not_seq], + by + rintro ⟨h, hn⟩ + by_cases Hs : Seq s + · rcases h Hs with ⟨_, _, rfl, h⟩; simpa [h] using Hs.domain_eq + · simp [lh_prop_of_not_seq Hs, hn Hs]⟩ + +/-- The lh Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.lhDef : Σ₀.Semisentence 2 := + .mkSigma + (“l s. (!seqDef s → ∃ d <⁺ 2 * s, !domainDef d s ∧ !underDef d l) ∧ (¬!seqDef s → l = 0)”) + +instance lh_defined : Σ₀-Function₁ (lh : V → V) via lhDef := + .mk fun v ↦ by simp [lhDef, -exists_eq_right_right, lh_graph] + +instance lh_definable : Σ₀-Function₁ (lh : V → V) := + lh_defined.to_definable + +instance lh_definable' (ℌ) : ℌ-Function₁ (lh : V → V) := + lh_definable.of_zero + +instance : Bounded₁ (lh : V → V) := + ⟨‘x. 2 * x’, fun _ ↦ by simp⟩ + +lemma Seq.exists {s : V} (h : Seq s) {x : V} (hx : x < lh s) : ∃ y, ⟪x, y⟫ ∈ s := + h.isMapping x (by simpa [h.domain_eq] using hx) |>.exists + +lemma Seq.nth_exists_uniq {s : V} (h : Seq s) {x : V} (hx : x < lh s) : ∃! y, ⟪x, y⟫ ∈ s := + h.isMapping x (by simpa [h.domain_eq] using hx) + +/-- The nth construction in `FFL.FirstOrder.Arithmetic.Seq`. -/ +noncomputable def Seq.nth {s : V} (h : Seq s) {x : V} (hx : x < lh s) : V := + Classical.chooseUnique (h.nth_exists_uniq hx) + +@[simp] +lemma Seq.nth_mem {s : V} (h : Seq s) {x : V} (hx : x < lh s) : ⟪x, h.nth hx⟫ ∈ s := + Classical.chooseUnique_spec (h.nth_exists_uniq hx) + +lemma Seq.nth_uniq {s : V} (h : Seq s) {x y : V} (hx : x < lh s) (hy : ⟪x, y⟫ ∈ s) : + y = h.nth hx := + (h.nth_exists_uniq hx).unique hy (by simp) + +@[simp] +lemma Seq.nth_lt {s : V} (h : Seq s) {x} (hx : x < lh s) : h.nth hx < s := + lt_of_mem_rng (h.nth_mem hx) + +lemma Seq.lh_eq_of {s : V} (H : Seq s) {l} (h : domain s = under l) : lh s = l := by + simpa [H.domain_eq] using h + +lemma Seq.lt_lh_iff {s : V} (h : Seq s) {i} : i < lh s ↔ i ∈ domain s := by simp [h.domain_eq] + +lemma Seq.lt_lh_of_mem {s : V} (h : Seq s) {i x} (hix : ⟪i, x⟫ ∈ s) : i < lh s := by + simpa [h.lt_lh_iff, mem_domain_iff] using ⟨x, hix⟩ + +/-- The seq Cons construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def seqCons (s x : V) : V := + insert ⟪lh s, x⟫ s + +section znth + +theorem znth_existsUnique (s i : V) : + ∃! x, (Seq s ∧ i < lh s → ⟪i, x⟫ ∈ s) ∧ (¬(Seq s ∧ i < lh s) → x = 0) := + by + by_cases h : Seq s ∧ i < lh s + · simpa [h] using h.1.nth_exists_uniq h.2 + · simp [h] + +/-- The znth construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def znth (s i : V) : V := + Classical.chooseUnique (znth_existsUnique s i) + +protected lemma Seq.znth {s i : V} (h : Seq s) (hi : i < lh s) : ⟪i, znth s i⟫ ∈ s := + Classical.chooseUnique_spec (znth_existsUnique s i) |>.1 ⟨h, hi⟩ + +lemma Seq.znth_eq_of_mem {s i : V} (h : Seq s) (hi : ⟪i, x⟫ ∈ s) : znth s i = x := + h.isMapping.uniq (h.znth (h.lt_lh_of_mem hi)) hi + +lemma znth_prop_not {s i : V} (h : ¬Seq s ∨ lh s ≤ i) : znth s i = 0 := + Classical.chooseUnique_spec (znth_existsUnique s i) |>.2 + (by simpa [-not_and, not_and_or] using h) + +/-- The znth Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.znthDef : Σ₀.Semisentence 3 := + .mkSigma + (“x s i. + ∃ l <⁺ 2 * s, !lhDef l s ∧ (:Seq s ∧ i < l → i ∼[s]x) ∧ (¬(:Seq s ∧ i < l) → x = 0)”) + +private lemma znth_graph {x s i : V} : + (∃ l ≤ 2 * s, l = lh s ∧ (Seq s ∧ i < l → ⟪i, x⟫ ∈ s) ∧ (¬(Seq s ∧ i < l) → x = 0)) ↔ + x = znth s i := + by simp [znth, Classical.chooseUnique_eq_iff_right] + +instance znth_defined : Σ₀-Function₂ (znth : V → V → V) via znthDef := + .mk fun v ↦ by simpa [znthDef, -not_and, not_and_or] using znth_graph (V := V) + +instance znth_definable : Σ₀-Function₂ (znth : V → V → V) := + znth_defined.to_definable + +instance znth_definable' (ℌ) : ℌ-Function₂ (znth : V → V → V) := + znth_definable.of_zero + +end znth + +/-- The «term ⁀' » construction in `FFL.FirstOrder.Arithmetic`. -/ +infixr:67 " ⁀' " => seqCons + +@[simp] +lemma seq_empty : Seq (∅ : V) := + ⟨by simp, 0, by simp⟩ + +@[simp] +lemma lh_empty : lh (∅ : V) = 0 := + by + have : under (lh ∅ : V) = under 0 := by + simpa using Eq.symm <| Seq.domain_eq (V := V) (s := ∅) (by simp) + exact under_inj.mp this + +lemma Seq.isempty_of_lh_eq_zero {s : V} (Hs : Seq s) (h : lh s = 0) : s = ∅ := by + simpa [h] using Hs.domain_eq + +@[simp] +lemma Seq.subset_seqCons (s x : V) : s ⊆ s ⁀' x := by simp [seqCons] + +lemma Seq.lt_seqCons {s} (hs : Seq s) (x : V) : s < s ⁀' x := + lt_iff_le_and_ne.mpr <| + ⟨le_of_subset <| by simp, by + simp only [seqCons, ne_eq]; intro A + have : ⟪lh s, x⟫ ∈ s := by simpa [← A] using mem_insert ⟪lh s, x⟫ s + simpa using hs.lt_lh_of_mem this⟩ + +lemma Seq.mem_seqCons (s x : V) : ⟪lh s, x⟫ ∈ s ⁀' x := by simp [seqCons] + +protected lemma Seq.seqCons {s : V} (h : Seq s) (x : V) : Seq (s ⁀' x) := + ⟨h.isMapping.insert (by simp [h.domain_eq]), lh s + 1, by simp [seqCons, h.domain_eq]⟩ + +@[simp] +lemma Seq.lh_seqCons (x : V) {s} (h : Seq s) : lh (s ⁀' x) = lh s + 1 := + by + have : under (lh s + 1) = under (lh (s ⁀' x)) := by + simpa [seqCons, h.domain_eq] using (h.seqCons x).domain_eq + exact Eq.symm <| under_inj.mp this + +lemma mem_seqCons_iff {i x z s : V} : ⟪i, x⟫ ∈ s ⁀' z ↔ (i = lh s ∧ x = z) ∨ ⟪i, x⟫ ∈ s := by + simp [seqCons] + +@[simp] +lemma lh_mem_seqCons (s z : V) : ⟪lh s, z⟫ ∈ s ⁀' z := by simp [seqCons] + +@[simp] +lemma lh_mem_seqCons_iff {s x z : V} (H : Seq s) : ⟪lh s, x⟫ ∈ s ⁀' z ↔ x = z := + by + suffices ⟪lh s, x⟫ ∈ s → x = z by simpa [seqCons] + intro h; have := H.lt_lh_of_mem h; simp at this + +lemma Seq.mem_seqCons_iff_of_lt {s x z : V} (hi : i < lh s) : ⟪i, x⟫ ∈ s ⁀' z ↔ ⟪i, x⟫ ∈ s := + by + suffices i = lh s → x = z → ⟪i, x⟫ ∈ s by simpa [seqCons, hi] + rintro rfl; simp at hi + +@[simp] +lemma lh_not_mem {s} (Ss : Seq s) (x : V) : ⟪lh s, x⟫ ∉ s := fun h ↦ by + have := Ss.lt_lh_of_mem h; simp at this + +section + +lemma seqCons_graph (t x s : V) : + t = s ⁀' x ↔ + ∃ l ≤ 2 * s, l = lh s ∧ ∃ p ≤ (2 * s + x + 1) ^ 2, p = ⟪l, x⟫ ∧ t = insert p s := + ⟨by + rintro rfl + exact + ⟨lh s, by simp, rfl, ⟪lh s, x⟫, + le_trans (pair_le_pair_left (by simp) x) (pair_polybound (2 * s) x), rfl, by rfl⟩, + by rintro ⟨l, _, rfl, p, _, rfl, rfl⟩; rfl⟩ + +/-- The seq Cons Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.seqConsDef : Σ₀.Semisentence 3 := + .mkSigma + (“t s x. + ∃ l <⁺ 2 * s, !lhDef l s ∧ ∃ p <⁺ (2 * s + x + 1)², !pairDef p l x ∧ !insertDef t p s”) + +instance seqCons_defined : Σ₀-Function₂ (seqCons : V → V → V) via seqConsDef := + .mk fun v ↦ by simp [seqConsDef, seqCons_graph] + +instance seqCons_definable : Σ₀-Function₂ (seqCons : V → V → V) := + seqCons_defined.to_definable + +instance seqCons_definable' (ℌ) : ℌ-Function₂ (seqCons : V → V → V) := + seqCons_definable.of_zero + +@[simp] +lemma natCast_empty : ((∅ : ℕ) : V) = ∅ := by simp [emptyset_def] + +lemma seqCons_absolute (s a : ℕ) : ((s ⁀' a : ℕ) : V) = (s : V) ⁀' (a : V) := by + simpa using DefinedFunction.shigmaZero_absolute_func V seqCons_defined seqCons_defined ![s, a] + +end + +lemma Seq.restr {s : V} (H : Seq s) {i : V} (hi : i ≤ lh s) : Seq (s ↾ under i) := + ⟨H.isMapping.restr (under i), i, domain_restr_of_subset_domain (by simp [H.domain_eq, hi])⟩ + +lemma Seq.restr_lh {s : V} (H : Seq s) {i : V} (hi : i ≤ lh s) : lh (s ↾ under i) = i := + (H.restr hi).lh_eq_of (domain_restr_of_subset_domain <| by simp [H.domain_eq, hi]) + +lemma domain_bitRemove_of_isMapping_of_mem {x y s : V} (hs : IsMapping s) (hxy : ⟪x, y⟫ ∈ s) : + domain (bitRemove ⟪x, y⟫ s) = bitRemove x (domain s) := + by + suffices ∀ x₁, (∃ y₁, (x₁ = x → y₁ ≠ y) ∧ ⟪x₁, y₁⟫ ∈ s) ↔ x₁ ≠ x ∧ ∃ y, ⟪x₁, y⟫ ∈ s by + apply mem_ext; simpa [mem_domain_iff] + intro x₁ + constructor + · rintro ⟨y₁, hy₁, hx₁y₁⟩; exact ⟨by rintro rfl; exact hy₁ rfl (hs.uniq hx₁y₁ hxy), y₁, hx₁y₁⟩ + · intro ⟨hx, y₁, hx₁y₁⟩ + exact ⟨y₁, by intro _; contradiction, hx₁y₁⟩ + +lemma Seq.eq_of_eq_of_subset {s₁ s₂ : V} (H₁ : Seq s₁) (H₂ : Seq s₂) (hl : lh s₁ = lh s₂) + (h : s₁ ⊆ s₂) : s₁ = s₂ := by + apply mem_ext; intro u + constructor + · intro hu; exact h hu + · intro hu + have : π₁ u < lh s₁ := by + simpa [hl] using H₂.lt_lh_of_mem (show ⟪π₁ u, π₂ u⟫ ∈ s₂ from by simpa using hu) + have : ∃ y, ⟪π₁ u, y⟫ ∈ s₁ := H₁.exists this + rcases this with ⟨y, hy⟩ + have : y = π₂ u := H₂.isMapping.uniq (h hy) (show ⟪π₁ u, π₂ u⟫ ∈ s₂ from by simpa using hu) + rcases this with rfl + simpa using hy + +lemma subset_pair {s t : V} (h : ∀ i x, ⟪i, x⟫ ∈ s → ⟪i, x⟫ ∈ t) : s ⊆ t := + by + intro u hu + simpa using h (π₁ u) (π₂ u) (by simpa using hu) + +lemma Seq.lh_ext {s₁ s₂ : V} (H₁ : Seq s₁) (H₂ : Seq s₂) (h : lh s₁ = lh s₂) + (H : ∀ i x₁ x₂, ⟪i, x₁⟫ ∈ s₁ → ⟪i, x₂⟫ ∈ s₂ → x₁ = x₂) : s₁ = s₂ := + H₁.eq_of_eq_of_subset H₂ h <| + subset_pair <| by + intro i x hx + have hi : i < lh s₂ := by simpa [← h] using H₁.lt_lh_of_mem hx + rcases H i _ _ hx (H₂.nth_mem hi) + simp + +@[simp] +lemma Seq.seqCons_ext {a₁ a₂ s₁ s₂ : V} (H₁ : Seq s₁) (H₂ : Seq s₂) : + s₁ ⁀' a₁ = s₂ ⁀' a₂ ↔ a₁ = a₂ ∧ s₁ = s₂ := + ⟨by + intro h + have hs₁s₂ : lh s₁ = lh s₂ := by simpa [H₁, H₂] using congr_arg lh h + have hs₁ : ⟪lh s₁, a₁⟫ ∈ s₂ ⁀' a₂ := by simpa [h] using lh_mem_seqCons s₁ a₁ + have hs₂ : ⟪lh s₁, a₂⟫ ∈ s₂ ⁀' a₂ := by simp [hs₁s₂] + have ha₁a₂ : a₁ = a₂ := (H₂.seqCons a₂).isMapping.uniq hs₁ hs₂ + have : s₁ ⊆ s₂ := + subset_pair <| by + intro i x hix + have : i = lh s₂ ∧ x = a₂ ∨ ⟪i, x⟫ ∈ s₂ := by + simpa [mem_seqCons_iff, h] using Seq.subset_seqCons s₁ a₁ hix + rcases this with (⟨rfl, rfl⟩ | hix₂) + · have := H₁.lt_lh_of_mem hix; simp [hs₁s₂] at this + · assumption + exact ⟨ha₁a₂, H₁.eq_of_eq_of_subset H₂ hs₁s₂ this⟩, by rintro ⟨rfl, rfl⟩; rfl⟩ + +/-- TODO: move to Lemmata.lean -/ +lemma ne_zero_iff_one_le {a : V} : a ≠ 0 ↔ 1 ≤ a := + Iff.trans pos_iff_ne_zero.symm (pos_iff_one_le (a := a)) + +lemma Seq.cases_iff {s : V} : Seq s ↔ s = ∅ ∨ ∃ x s', Seq s' ∧ s = s' ⁀' x := + ⟨fun h ↦ by + by_cases hs : lh s = 0 + · left + simpa [hs] using h.domain_eq + · right + let i := lh s - 1 + have hi : i < lh s := pred_lt_self_of_pos (pos_iff_ne_zero.mpr hs) + have lhs_eq : lh s = i + 1 := Eq.symm <| tsub_add_cancel_of_le <| ne_zero_iff_one_le.mp hs + let s' := bitRemove ⟪i, h.nth hi⟫ s + have his : ⟪i, h.nth hi⟫ ∈ s := h.nth_mem hi + have hdoms' : domain s' = under i := + by + simp only [domain_bitRemove_of_isMapping_of_mem h.isMapping his, h.domain_eq, s'] + apply mem_ext + simpa [lhs_eq, and_or_left] using fun j hj ↦ ne_of_lt hj + have hs' : Seq s' := ⟨h.isMapping.of_subset (by simp [s']), i, hdoms'⟩ + have hs'i : lh s' = i := by simpa [hs'.domain_eq] using hdoms' + exact + ⟨h.nth hi, s', hs', + mem_ext <| fun v ↦ by + simp only [seqCons, hs'i, mem_bitInsert_iff] + simp [s'] + by_cases hv : v = ⟪i, h.nth hi⟫ <;> simp [hv]⟩, + by + rintro (rfl | ⟨x, s', hs', rfl⟩) + · simp + · exact hs'.seqCons x⟩ + +alias ⟨Seq.cases, _⟩ := Seq.cases_iff + +@[elab_as_elim] +theorem seq_induction (Γ) {P : V → Prop} (hP : Γ-[1]-Predicate P) (hnil : P ∅) + (hcons : ∀ s x, Seq s → P s → P (s ⁀' x)) : ∀ {s : V}, Seq s → P s := + by + intro s sseq + induction s using ISigma1.order_induction + · exact Γ + · definability + case ind s ih => + have : s = ∅ ∨ ∃ x s', Seq s' ∧ s = s' ⁀' x := sseq.cases + rcases this with (rfl | ⟨x, s, hs, rfl⟩) + · exact hnil + · exact hcons s x hs (ih s (hs.lt_seqCons x) hs) + +/-- `!⟦x, y, z, ...⟧` notation for `Seq` -/ +syntax "!⟦" term,* "⟧" : term + +macro_rules + | `(!⟦$terms:term,*, $term:term⟧) => `(seqCons !⟦$terms,*⟧ $term) + | `(!⟦$term:term⟧) => `(seqCons ∅ $term) + | `(!⟦⟧) => `(∅) + +/-- The vec Cons Unexpander construction in `FFL.FirstOrder.Arithmetic`. -/ +@[app_unexpander seqCons] +meta def vecConsUnexpander : Lean.PrettyPrinter.Unexpander + | `($_ !⟦$term2, $terms,*⟧ $term) => `(!⟦$term2, $terms,*, $term⟧) + | `($_ !⟦$term2⟧ $term) => `(!⟦$term2, $term⟧) + | `($_ ∅ $term) => `(!⟦$term⟧) + | _ => throw () + + + +@[simp] +lemma singleton_seq (x : V) : Seq !⟦x⟧ := by apply Seq.seqCons; simp + +@[simp] +lemma doubleton_seq (x y : V) : Seq !⟦x, y⟧ := by apply Seq.seqCons; simp + +@[simp] +lemma mem_singleton_seq_iff (x y : V) : ⟪0, x⟫ ∈ !⟦y⟧ ↔ x = y := by simp [mem_seqCons_iff] + +section + +/-- Fix the first input of a binary graph to zero, retaining its output variable. -/ +def binaryGraphAtZero (φ : Σ₀.Semisentence 3) : Σ₀.Semisentence 2 := + .mkSigma “s x. !φ s 0 x” + +-- Keep the formula abstract while reducing substitution and evaluation. +omit [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] in +lemma eval_binaryGraphAtZero (φ : Σ₀.Semisentence 3) (v : Fin 2 → V) : + (binaryGraphAtZero φ).val.Evalb v ↔ φ.val.Evalb ![v 0, 0, v 1] := by + simp [binaryGraphAtZero] + +/-- The mk Seq₁Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.mkSeq₁Def : Σ₀.Semisentence 2 := + binaryGraphAtZero seqConsDef + +instance mkSeq₁_defined : Σ₀-Function₁ (fun x : V ↦ !⟦x⟧) via mkSeq₁Def := + .mk fun v ↦ by + rw [mkSeq₁Def, eval_binaryGraphAtZero, HierarchySymbol.Defined.iff] + simp only [Matrix.cons_val_zero, emptyset_def] + rfl + +instance mkSeq₁_definable : Σ₀-Function₁ (fun x : V ↦ !⟦x⟧) := + mkSeq₁_defined.to_definable + +instance mkSeq₁_definable' (Γ) : Γ-Function₁ (fun x : V ↦ !⟦x⟧) := + mkSeq₁_definable.of_zero + +/-- The mk Seq₂Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.mkSeq₂Def : Σ₁.Semisentence 3 := + .mkSigma (“s x y. ∃ sx, !mkSeq₁Def sx x ∧ !seqConsDef s sx y”) + +instance mkSeq₂_defined : Σ₁-Function₂ (fun x y : V ↦ !⟦x, y⟧) via mkSeq₂Def := + .mk fun v ↦ by simp [mkSeq₂Def] + +instance mkSeq₂_definable : Σ₁-Function₂ (fun x y : V ↦ !⟦x, y⟧) := + mkSeq₂_defined.to_definable + +instance mkSeq₂_definable' (Γ m) : Γ-[m + 1]-Function₂ (fun x y : V ↦ !⟦x, y⟧) := + mkSeq₂_definable.of_sigmaOne + +end + +theorem sigmaOne_skolem_seq {R : V → V → Prop} (hP : Σ₁-Relation R) {l} + (H : ∀ x < l, ∃ y, R x y) : ∃ s, Seq s ∧ lh s = l ∧ ∀ i x, ⟪i, x⟫ ∈ s → R i x := + by + rcases sigmaOne_skolem hP (show ∀ x ∈ under l, ∃ y, R x y by simpa using H) with + ⟨s, ms, sdom, h⟩ + have : Seq s := ⟨ms, l, sdom⟩ + exact ⟨s, this, by simpa [this.domain_eq] using sdom, h⟩ + +theorem sigmaOne_skolem_seqProof {R : V → V → Prop} (hP : Σ₁-Relation R) {l} + (H : ∀ x < l, ∃! y, R x y) : ∃! s, Seq s ∧ lh s = l ∧ ∀ i x, ⟪i, x⟫ ∈ s → R i x := + by + have : ∀ x < l, ∃ y, R x y := fun x hx ↦ (H x hx).exists + rcases sigmaOne_skolem_seq hP this with ⟨s, Ss, rfl, hs⟩ + exact + ExistsUnique.intro s ⟨Ss, rfl, hs⟩ + (by + rintro s' ⟨Ss', hss', hs'⟩ + exact + Seq.lh_ext Ss' Ss hss' + (fun i x₁ x₂ h₁ h₂ ↦ H i (Ss.lt_lh_of_mem h₂) |>.unique (hs' i x₁ h₁) (hs i x₂ h₂))) + +section seqToVec + +/-- The vec To Seq construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def vecToSeq : {n : ℕ} → (Fin n → V) → V + | 0, _ => ∅ + | n + 1, v => vecToSeq (v ·.castSucc) ⁀' v (Fin.last n) + +@[simp] +lemma vecToSeq_nil : vecToSeq ![] = (∅ : V) := by simp [vecToSeq] + +@[simp] +lemma vecToSeq_vecCons {n} (v : Fin n → V) (a : V) : vecToSeq (v <: a) = vecToSeq v ⁀' a := by + simp [vecToSeq] + +@[simp] +lemma vecToSeq_seq {n} (v : Fin n → V) : Seq (vecToSeq v) := by + induction n with + | zero => simp [vecToSeq] + | succ n ih => exact (ih _).seqCons _ + +@[simp] +lemma lh_vecToSeq {n} (v : Fin n → V) : lh (vecToSeq v) = n := by + induction n with + | zero => simp [vecToSeq] + | succ n ih => simp [vecToSeq, ih] + +lemma mem_vectoSeq {n : ℕ} (v : Fin n → V) (i : Fin n) : ⟪(i : V), v i⟫ ∈ vecToSeq v := by + induction n with + | zero => exact i.elim0 + | succ n ih => + refine Fin.lastCases ?_ (fun i => ?_) i + · simp [vecToSeq, mem_seqCons_iff] + · simpa [vecToSeq, mem_seqCons_iff] using Or.inr <| ih (v ·.castSucc) i + +end seqToVec + +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/HFS/Vec.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/HFS/Vec.lean new file mode 100644 index 000000000..3e03da943 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/HFS/Vec.lean @@ -0,0 +1,1390 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.HFS.Fixpoint + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +/-! +# Vec + +-/ + +namespace FFL +namespace FirstOrder +namespace Arithmetic + +variable {V : Type*} [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +section adjoin + +noncomputable instance : Adjoin V V := + ⟨(⟪·, ·⟫ + 1)⟩ + +/-- The «term ∷ » construction in `FFL.FirstOrder.Arithmetic`. -/ +scoped infixr:67 " ∷ " => adjoin + +/-- The «term?[ ]» construction in `FFL.FirstOrder.Arithmetic`. -/ +syntax "?[" term,* "]" : term + +macro_rules + | `(?[$term:term, $terms:term,*]) => `(adjoin $term ?[$terms,*]) + | `(?[$term:term]) => `(adjoin $term 0) + | `(?[]) => `(0) + +/-- The adjoin Unexpander construction in `FFL.FirstOrder.Arithmetic`. -/ +@[app_unexpander Adjoin.adjoin] +meta def adjoinUnexpander : Lean.PrettyPrinter.Unexpander + | `($_ $term ?[$terms,*]) => `(?[$term, $terms,*]) + | `($_ $term 0) => `(?[$term]) + | _ => throw () + + + +lemma adjoin_def (x v : V) : x ∷ v = ⟪x, v⟫ + 1 := + rfl + +@[simp] +lemma fstIdx_adjoin (x v : V) : fstIdx (x ∷ v) = x := by simp [adjoin_def, fstIdx] + +@[simp] +lemma sndIdx_adjoin (x v : V) : sndIdx (x ∷ v) = v := by simp [adjoin_def, sndIdx] + +lemma succ_eq_adjoin (x : V) : x + 1 = π₁ x ∷ π₂ x := by simp [adjoin_def] + +@[simp] +lemma lt_adjoin (x v : V) : x < x ∷ v := by simp [adjoin_def, lt_succ_iff_le] + +@[simp] +lemma lt_adjoin' (x v : V) : v < x ∷ v := by simp [adjoin_def, lt_succ_iff_le] + +@[simp] +lemma zero_lt_adjoin (x v : V) : 0 < x ∷ v := by simp [adjoin_def] + +@[simp] +lemma adjoin_ne_zero (x v : V) : x ∷ v ≠ 0 := by simp [adjoin_def] + +@[simp] +lemma zero_ne_adjoin (x v : V) : 0 ≠ x ∷ v := by symm; simp [adjoin_def] + +lemma nil_or_adjoin (z : V) : z = 0 ∨ ∃ x v, z = x ∷ v := + by + rcases zero_or_succ z with (rfl | ⟨z, rfl⟩) + · left; rfl + · right; exact ⟨π₁ z, π₂ z, by simp [succ_eq_adjoin]⟩ + +@[simp] +lemma adjoin_inj (x₁ x₂ v₁ v₂ : V) : x₁ ∷ v₁ = x₂ ∷ v₂ ↔ x₁ = x₂ ∧ v₁ = v₂ := by + simp [adjoin_def] + +lemma adjoin_le_adjoin {x₁ x₂ v₁ v₂ : V} (hx : x₁ ≤ x₂) (hv : v₁ ≤ v₂) : x₁ ∷ v₁ ≤ x₂ ∷ v₂ := by + simpa [adjoin_def] using pair_le_pair hx hv + +section + +/-- The adjoin Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.adjoinDef : Σ₀.Semisentence 3 := + .mkSigma (“w x v. ∃ xv < w, !pairDef xv x v ∧ w = xv + 1”) + +instance adjoin_defined : Σ₀-Function₂ (adjoin : V → V → V) via adjoinDef := + .mk fun v ↦ by simp_all [adjoinDef, adjoin_def] + +instance adjoin_definable : Σ₀-Function₂ (adjoin : V → V → V) := + adjoin_defined.to_definable + +instance adjoin_definable' (ℌ) : ℌ-Function₂ (adjoin : V → V → V) := + adjoin_definable.of_zero + +/-- The mk Vec₁Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.mkVec₁Def : Σ₀.Semisentence 2 := + .mkSigma (“s x. !adjoinDef s x 0”) + +instance mkVec₁_defined : Σ₀-Function₁ (fun x : V ↦ ?[x]) via mkVec₁Def := + .mk fun v ↦ by simp [mkVec₁Def] + +instance mkVec₁_definable : Σ₀-Function₁ (fun x : V ↦ ?[x]) := + mkVec₁_defined.to_definable + +instance mkVec₁_definable' (ℌ) : ℌ-Function₁ (fun x : V ↦ ?[x]) := + mkVec₁_definable.of_zero + +/-- The mk Vec₂Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.mkVec₂Def : Σ₁.Semisentence 3 := + .mkSigma (“s x y. ∃ sy, !mkVec₁Def sy y ∧ !adjoinDef s x sy”) + +instance mkVec₂_defined : Σ₁-Function₂ (fun x y : V ↦ ?[x, y]) via mkVec₂Def := + .mk fun v ↦ by simp [mkVec₂Def] + +instance mkVec₂_definable : Σ₁-Function₂ (fun x y : V ↦ ?[x, y]) := + mkVec₂_defined.to_definable + +instance mkVec₂_definable' (Γ m) : Γ-[m + 1]-Function₂ (fun x y : V ↦ ?[x, y]) := + mkVec₂_definable.of_sigmaOne + +end + +end adjoin + +/-! +### N-th element of List + +-/ + +namespace Nth + +/-- The Phi construction in `FFL.FirstOrder.Arithmetic.Nth`. -/ +def Phi (C : Set V) (pr : V) : Prop := + (∃ v, pr = ⟪v, 0, fstIdx v⟫) ∨ (∃ v i x, pr = ⟪v, i + 1, x⟫ ∧ ⟪sndIdx v, i, x⟫ ∈ C) + +private lemma phi_iff (C pr : V) : + Phi {x | x ∈ C} pr ↔ + (∃ v ≤ pr, ∃ fst ≤ v, fst = fstIdx v ∧ pr = ⟪v, 0, fst⟫) ∨ + (∃ v ≤ pr, + ∃ i ≤ pr, + ∃ x ≤ pr, + pr = ⟪v, i + 1, x⟫ ∧ + ∃ snd ≤ v, snd = sndIdx v ∧ ∃ six < C, six = ⟪snd, i, x⟫ ∧ six ∈ C) := + by + constructor + · rintro (⟨v, rfl⟩ | ⟨v, i, x, rfl, hC⟩) + · left; exact ⟨v, by simp, _, by simp, rfl, rfl⟩ + · right; + exact + ⟨v, by simp, i, le_trans (le_trans (by simp) (le_pair_left _ _)) (le_pair_right _ _), x, + le_trans (by simp) (le_pair_right _ _), rfl, _, by simp, rfl, _, lt_of_mem hC, rfl, + hC⟩ + · rintro (⟨v, _, _, _, rfl, rfl⟩ | ⟨v, _, i, _, x, _, rfl, _, _, rfl, _, _, rfl, hC⟩) + · left; exact ⟨v, rfl⟩ + · right; exact ⟨v, i, x, rfl, hC⟩ + +/-- The blueprint construction in `FFL.FirstOrder.Arithmetic.Nth`. -/ +def blueprint : Fixpoint.Blueprint 0 where + core := + .ofZero + (.mkSigma + (“pr C. + (∃ v <⁺ pr, ∃ fst <⁺ v, !fstIdxDef fst v ∧ !pair₃Def pr v 0fst) ∨ + (∃ v <⁺ pr, + ∃ i <⁺ pr, + ∃ x <⁺ pr, + !pair₃Def pr v(i + 1)x ∧ + ∃ snd <⁺ v, + !sndIdxDef snd v ∧ ∃ six < C, !pair₃Def six snd i x ∧ six ∈ C)”) + (by simp)) + _ + +/-- The adjointruction construction in `FFL.FirstOrder.Arithmetic.Nth`. -/ +def adjointruction : Fixpoint.Construction V blueprint + where + Φ := fun _ ↦ Phi + defined := .of_zero <| .mk fun v ↦ by simp [phi_iff] + monotone := by + rintro C C' hC _ x (h | ⟨v, i, x, rfl, h⟩) + · left; exact h + · right; exact ⟨v, i, x, rfl, hC h⟩ + +instance : adjointruction.Finite V where + finite := by + rintro C v x (h | ⟨v, i, x, rfl, h⟩) + · exact ⟨0, Or.inl h⟩ + · exact ⟨⟪sndIdx v, i, x⟫ + 1, Or.inr ⟨v, i, x, rfl, h, by simp⟩⟩ + +/-- The Graph construction in `FFL.FirstOrder.Arithmetic.Nth`. -/ +def Graph : V → Prop := + adjointruction.IsFixedPoint ![] + +section + +/-- The graph Def construction in `FFL.FirstOrder.Arithmetic.Nth`. -/ +def graphDef : Σ₁.Semisentence 1 := + blueprint.fixpointDef + +instance graph_defined : Σ₁-Predicate (Graph : V → Prop) via graphDef := + adjointruction.fixpoint_defined + +instance graph_definable : Σ₁-Predicate (Graph : V → Prop) := + graph_defined.to_definable + +instance graph_definable' : Σ-[0 + 1]-Predicate (Graph : V → Prop) := + graph_definable + +end + +/-- TODO: move -/ +lemma zero_ne_add_one (x : V) : 0 ≠ x + 1 := + ne_of_lt (by simp) + +lemma graph_case {pr : V} : + Graph pr ↔ + (∃ v, pr = ⟪v, 0, fstIdx v⟫) ∨ (∃ v i x, pr = ⟪v, i + 1, x⟫ ∧ Graph ⟪sndIdx v, i, x⟫) := + adjointruction.case + +lemma graph_zero {v x : V} : Graph ⟪v, 0, x⟫ ↔ x = fstIdx v := + by + constructor + · intro h + rcases graph_case.mp h with (⟨w, h⟩ | ⟨w, i, x, h, _⟩) + · rcases show v = w ∧ x = fstIdx w by simpa using h with ⟨rfl, rfl, rfl⟩; rfl + · simp at h + · rintro rfl; exact graph_case.mpr <| Or.inl ⟨v, rfl⟩ + +lemma graph_succ {v i x : V} : Graph ⟪v, i + 1, x⟫ ↔ Graph ⟪sndIdx v, i, x⟫ := + by + constructor + · intro h + rcases graph_case.mp h with (⟨w, h⟩ | ⟨w, j, y, h, hw⟩) + · simp at h + · rcases show v = w ∧ i = j ∧ x = y by simpa using h with ⟨rfl, rfl, rfl⟩; exact hw + · intro h; exact graph_case.mpr <| Or.inr ⟨v, i, x, rfl, h⟩ + +lemma graph_exists (v i : V) : ∃ x, Graph ⟪v, i, x⟫ := + by + suffices ∀ i' ≤ i, ∀ v' ≤ v, ∃ x, Graph ⟪v', i', x⟫ from this i (by simp) v (by simp) + intro i' hi' + induction i' using ISigma1.sigma1_succ_induction + · definability + case zero => + intro v' _ + exact ⟨fstIdx v', graph_case.mpr <| Or.inl ⟨v', rfl⟩⟩ + case succ i' ih => + intro v' hv' + rcases ih (le_trans le_self_add hi') (sndIdx v') (le_trans (by simp) hv') with ⟨x, hx⟩ + exact ⟨x, graph_case.mpr <| Or.inr ⟨v', i', x, rfl, hx⟩⟩ + +lemma graph_unique {v i x₁ x₂ : V} : Graph ⟪v, i, x₁⟫ → Graph ⟪v, i, x₂⟫ → x₁ = x₂ := + by + induction i using ISigma1.pi1_succ_induction generalizing v x₁ x₂ + · definability + case zero => + simp only [graph_zero] + rintro rfl rfl; rfl + case succ i ih => + simp only [graph_succ] + exact ih + +lemma graph_existsUnique (v i : V) : ∃! x, Graph ⟪v, i, x⟫ := + by + rcases graph_exists v i with ⟨x, hx⟩ + exact ExistsUnique.intro x hx (fun y hy ↦ graph_unique hy hx) + +end Nth + +section nth + +open Nth + +/-- The nth construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def nth (v i : V) : V := + Classical.chooseUnique (graph_existsUnique v i) + +/-- The [ ]» construction in `FFL.FirstOrder.Arithmetic.«term_`. -/ +scoped notation:max v:max ".[" i "]" => nth v i + +lemma nth_graph (v i : V) : Graph ⟪v, i, v.[i]⟫ := + Classical.chooseUnique_spec (graph_existsUnique v i) + +lemma nth_eq_of_graph {v i x : V} (h : Graph ⟪v, i, x⟫) : nth v i = x := + graph_unique (nth_graph v i) h + +lemma nth_zero (v : V) : v.[0] = fstIdx v := + nth_eq_of_graph (graph_zero.mpr rfl) + +lemma nth_succ (v i : V) : v.[i + 1] = (sndIdx v).[i] := + nth_eq_of_graph (graph_succ.mpr <| nth_graph _ _) + +@[simp] +lemma nth_adjoin_zero (x v : V) : (x ∷ v).[0] = x := by simp [nth_zero] + +@[simp] +lemma nth_adjoin_succ (x v i : V) : (x ∷ v).[i + 1] = v.[i] := by simp [nth_succ] + +@[simp] +lemma nth_adjoin_one (x v : V) : (x ∷ v).[1] = v.[0] := by simpa using nth_adjoin_succ x v 0 + +@[simp] +lemma nth_adjoin_two (x v : V) : (x ∷ v).[2] = v.[1] := by + simpa [-nth_adjoin_succ, one_add_one_eq_two] using nth_adjoin_succ x v 1 + +lemma adjoin_cases (x : V) : x = 0 ∨ ∃ y v, x = y ∷ v := + by + rcases zero_or_succ x with (rfl | ⟨z, rfl⟩) + · simp + · right; exact ⟨π₁ z, π₂ z, by simp [adjoin]⟩ + +lemma adjoin_induction (Γ) {P : V → Prop} (hP : Γ-[1]-Predicate P) (nil : P 0) + (adjoin : ∀ x v, P v → P (x ∷ v)) : ∀ v, P v := + ISigma1.order_induction Γ hP + (by + intro v ih + rcases nil_or_adjoin v with (rfl | ⟨x, v, rfl⟩) + · exact nil + · exact adjoin _ _ (ih v (by simp))) + +@[elab_as_elim] +lemma adjoin_ISigma1.sigma1_succ_induction {P : V → Prop} (hP : Σ₁-Predicate P) (nil : P 0) + (adjoin : ∀ x v, P v → P (x ∷ v)) : ∀ v, P v := + adjoin_induction Σ hP nil adjoin + +@[elab_as_elim] +lemma adjoin_ISigma1.pi1_succ_induction {P : V → Prop} (hP : Π₁-Predicate P) (nil : P 0) + (adjoin : ∀ x v, P v → P (x ∷ v)) : ∀ v, P v := + adjoin_induction Π hP nil adjoin + +section + +/-- The nth Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.nthDef : Σ₁.Semisentence 3 := + .mkSigma (“y v i. ∃ pr, !pair₃Def pr v i y ∧ !graphDef pr”) + +instance nth_defined : Σ₁-Function₂ (nth : V → V → V) via nthDef := + .mk fun v ↦ by + simp only [Nat.reduceAdd, nthDef, Nat.succ_eq_add_one, Fin.isValue, + HierarchySymbol.Semiformula.val_mkSigma, Semiformula.eval_ex, + LogicalConnective.HomClass.map_and, Semiformula.eval_substs, Matrix.comp₄, + Semiterm.val_bvar, Matrix.cons_val_zero, Matrix.cons_app_two, Matrix.cons_app_three, + Matrix.cons_val_one, HierarchySymbol.Defined.iff, Fin.succ_zero_eq_one, Fin.succ_one_eq_two, + Fin.succ_two_eq_three, Matrix.cons_val_fin_one, Matrix.comp₁, LogicalConnective.Prop.and_eq, + exists_eq_left] + constructor + · intro h; simp [nth_eq_of_graph h] + · intro h; rw [h]; exact nth_graph _ _ + +instance nth_definable : Σ₁-Function₂ (nth : V → V → V) := + nth_defined.to_definable + +instance nth_definable' (Γ m) : Γ-[m + 1]-Function₂ (nth : V → V → V) := + nth_definable.of_sigmaOne + +end + +lemma adjoin_absolute (a v : ℕ) : ((a ∷ v : ℕ) : V) = (a : V) ∷ (v : V) := by + simpa using DefinedFunction.shigmaZero_absolute_func V adjoin_defined adjoin_defined ![a, v] + +/-- TODO: move -/ +lemma pi₁_zero : π₁(0 : V) = 0 := + nonpos_iff_eq_zero.mp (pi₁_le_self 0) + +lemma pi₂_zero : π₂(0 : V) = 0 := + nonpos_iff_eq_zero.mp (pi₂_le_self 0) + +@[simp] +lemma nth_zero_idx (i : V) : (0).[i] = 0 := + by + induction i using ISigma1.sigma1_succ_induction + · definability + case zero => simp [nth_zero, fstIdx, pi₁_zero] + case succ i ih => simp [nth_succ, sndIdx, pi₂_zero, ih] + +lemma nth_lt_of_pos {v} (hv : 0 < v) (i : V) : v.[i] < v := + by + induction i using ISigma1.pi1_succ_induction generalizing v + · definability + case zero => + rcases zero_or_succ v with (rfl | ⟨v, rfl⟩) + · simp at hv + · simp [succ_eq_adjoin] + case succ i ih => + rcases zero_or_succ v with (rfl | ⟨v, rfl⟩) + · simp at hv + · simp only [succ_eq_adjoin v, nth_adjoin_succ] + rcases eq_zero_or_pos (π₂ v) with (h | h) + · simp [h] + · exact lt_trans (ih h) (by simp) + +@[simp] +lemma nth_le (v i : V) : v.[i] ≤ v := + by + rcases eq_zero_or_pos v with (h | h) + · simp [h] + · exact le_of_lt <| nth_lt_of_pos h i + +end nth + +/-! +### Inductivly Construction of Function on List + +-/ + +namespace VecRec + +/-- Data specifying the encoded construction in `FFL.FirstOrder.Arithmetic.VecRec`. -/ +structure Blueprint (arity : ℕ) where + /-- The nil construction in `FFL.FirstOrder.Arithmetic.VecRec.Blueprint`. -/ + nil : Σ₁.Semisentence (arity + 1) + /-- The adjoin construction in `FFL.FirstOrder.Arithmetic.VecRec.Blueprint`. -/ + adjoin : Σ₁.Semisentence (arity + 4) + +namespace Blueprint + +variable {arity : ℕ} (β : Blueprint arity) + +/-- The blueprint construction in `FFL.FirstOrder.Arithmetic.VecRec.Blueprint`. -/ +def blueprint : Fixpoint.Blueprint arity where + core := + .mkDelta + (.mkSigma + (“pr C. + (∃ nil, !β.nil nil⋯ ∧ !pairDef pr 0nil) ∨ + (∃ x < pr, + ∃ xs < pr, + ∃ ih < C, + ∃ xxs, + !adjoinDef xxs x xs ∧ + ∃ adjoin, + !β.adjoin adjoin x xs ih⋯ ∧ !pairDef pr xxs adjoin ∧ :⟪xs, ih⟫:∈ C)”) + (by simp)) + (.mkPi + (“pr C. + (∀ nil, !β.nil nil⋯ → !pairDef pr 0nil) ∨ + (∃ x < pr, + ∃ xs < pr, + ∃ ih < C, + ∀ xxs, + !adjoinDef xxs x xs → + ∀ adjoin, + !β.adjoin adjoin x xs ih⋯ → !pairDef pr xxs adjoin ∧ :⟪xs, ih⟫:∈ C)”) + (by simp)) + +/-- The graph Def construction in `FFL.FirstOrder.Arithmetic.VecRec.Blueprint`. -/ +def graphDef : Σ₁.Semisentence (arity + 1) := + β.blueprint.fixpointDef + +/-- The result Def construction in `FFL.FirstOrder.Arithmetic.VecRec.Blueprint`. -/ +def resultDef : Σ₁.Semisentence (arity + 2) := + .mkSigma (“y xs. ∃ pr, !pairDef pr xs y ∧ !β.graphDef pr⋯”) + +end Blueprint + +variable (V) + +/-- Data and laws for Construction in `FFL.FirstOrder.Arithmetic.VecRec`. -/ +structure Construction {arity : ℕ} (β : Blueprint arity) where + /-- The nil construction in `FFL.FirstOrder.Arithmetic.VecRec.Construction`. -/ + nil (param : Fin arity → V) : V + /-- The adjoin construction in `FFL.FirstOrder.Arithmetic.VecRec.Construction`. -/ + adjoin (param : Fin arity → V) (x xs ih) : V + nil_defined : Σ₁.DefinedFunction nil β.nil + adjoin_defined : + Σ₁.DefinedFunction (fun v ↦ adjoin (v ·.succ.succ.succ) (v 0) (v 1) (v 2)) β.adjoin + +variable {V} + +namespace Construction + +variable {arity : ℕ} {β : Blueprint arity} (c : Construction V β) + +/-- The Phi construction in `FFL.FirstOrder.Arithmetic.VecRec.Construction`. -/ +def Phi (param : Fin arity → V) (C : Set V) (pr : V) : Prop := + pr = ⟪0, c.nil param⟫ ∨ (∃ x xs ih, pr = ⟪x ∷ xs, c.adjoin param x xs ih⟫ ∧ ⟪xs, ih⟫ ∈ C) + +private lemma phi_iff (param : Fin arity → V) (C pr : V) : + c.Phi param {x | x ∈ C} pr ↔ + pr = ⟪0, c.nil param⟫ ∨ + (∃ x < pr, ∃ xs < pr, ∃ ih < C, pr = ⟪x ∷ xs, c.adjoin param x xs ih⟫ ∧ ⟪xs, ih⟫ ∈ C) := + by + constructor + · rintro (h | ⟨x, xs, ih, rfl, hC⟩) + · left; exact h + · right + exact + ⟨x, lt_of_lt_of_le (by simp) (le_pair_left _ _), xs, + lt_of_lt_of_le (by simp) (le_pair_left _ _), ih, lt_of_mem_rng hC, rfl, hC⟩ + · rintro (h | ⟨x, _, xs, _, ih, _, rfl, hC⟩) + · left; exact h + · right; exact ⟨x, xs, ih, rfl, hC⟩ + +/-- The adjointruction construction in `FFL.FirstOrder.Arithmetic.VecRec.Construction`. -/ +def adjointruction : Fixpoint.Construction V β.blueprint + where + Φ := c.Phi + defined := + .mk + ⟨by intro v; simp [Blueprint.blueprint, c.nil_defined.iff, c.adjoin_defined.iff], + by + intro v + symm + simpa [Blueprint.blueprint, c.nil_defined.iff, c.adjoin_defined.iff] using + c.phi_iff _ _ _⟩ + monotone := by + rintro C C' hC _ x (h | ⟨v, i, hv, rfl, h⟩) + · left; exact h + · right; exact ⟨v, i, hv, rfl, hC h⟩ + +instance : c.adjointruction.Finite V where + finite := by + rintro C v x (h | ⟨x, xs, ih, rfl, h⟩) + · exact ⟨0, Or.inl h⟩ + · exact ⟨⟪xs, ih⟫ + 1, Or.inr ⟨x, xs, ih, rfl, h, by simp⟩⟩ + +variable (param : Fin arity → V) + +/-- The Graph construction in `FFL.FirstOrder.Arithmetic.VecRec.Construction`. -/ +def Graph : V → Prop := + c.adjointruction.IsFixedPoint param + +section + +lemma graph_defined : Σ₁.Defined (fun v ↦ c.Graph (v ·.succ) (v 0)) β.graphDef := + c.adjointruction.fixpoint_defined + +instance graph_definable : Σ₁.Definable (fun v ↦ c.Graph (v ·.succ) (v 0)) := + c.graph_defined.to_definable + +instance graph_definable' (param) : Σ₁-Predicate (c.Graph param) := by + simpa using + HierarchySymbol.Definable.retractiont (n := 1) c.graph_definable (#0 :> fun i ↦ &(param i)) + +instance graph_definable'' (param) : Σ-[0 + 1]-Predicate (c.Graph param) := + c.graph_definable' param + +end + +variable {param} + +lemma graph_case {pr : V} : + c.Graph param pr ↔ + pr = ⟪0, c.nil param⟫ ∨ + (∃ x xs ih, pr = ⟪x ∷ xs, c.adjoin param x xs ih⟫ ∧ c.Graph param ⟪xs, ih⟫) := + c.adjointruction.case + +lemma graph_nil {l : V} : c.Graph param ⟪0, l⟫ ↔ l = c.nil param := + by + constructor + · intro h + rcases c.graph_case.mp h with (h | ⟨x, xs, ih, h, _⟩) + · rcases show l = c.nil param by simpa using h with ⟨rfl, rfl⟩; rfl + · simp at h + · rintro rfl; exact c.graph_case.mpr <| Or.inl rfl + +lemma graph_adjoin {x xs y : V} : + c.Graph param ⟪x ∷ xs, y⟫ ↔ ∃ y', y = c.adjoin param x xs y' ∧ c.Graph param ⟪xs, y'⟫ := + by + constructor + · intro h + rcases c.graph_case.mp h with (h | ⟨z, zs, v, h, hg⟩) + · simp at h + · rcases show (x = z ∧ xs = zs) ∧ y = c.adjoin param z zs v by simpa using h with + ⟨⟨rfl, rfl⟩, rfl⟩ + exact ⟨v, rfl, hg⟩ + · rintro ⟨y, rfl, h⟩; exact c.graph_case.mpr <| Or.inr ⟨x, xs, y, rfl, h⟩ + +variable (param) + +lemma graph_exists (xs : V) : ∃ y, c.Graph param ⟪xs, y⟫ := + by + induction xs using adjoin_ISigma1.sigma1_succ_induction + · definability + case nil => exact ⟨c.nil param, c.graph_nil.mpr rfl⟩ + case adjoin x xs ih => + · rcases ih with ⟨y, hy⟩ + exact ⟨c.adjoin param x xs y, c.graph_adjoin.mpr ⟨y, rfl, hy⟩⟩ + +variable {param} + +lemma graph_unique {xs y₁ y₂ : V} : c.Graph param ⟪xs, y₁⟫ → c.Graph param ⟪xs, y₂⟫ → y₁ = y₂ := + by + induction xs using adjoin_ISigma1.pi1_succ_induction generalizing y₁ y₂ + · definability + case nil => simp only [graph_nil]; rintro rfl rfl; rfl + case adjoin x v ih => + simp only [graph_adjoin, forall_exists_index, and_imp] + rintro l₁ rfl h₁ l₂ rfl h₂ + rcases ih h₁ h₂; rfl + +variable (param) + +lemma graph_existsUnique (xs : V) : ∃! y, c.Graph param ⟪xs, y⟫ := + by + rcases c.graph_exists param xs with ⟨y, hy⟩ + exact ExistsUnique.intro y hy (fun y' hy' ↦ c.graph_unique hy' hy) + +/-- The result construction in `FFL.FirstOrder.Arithmetic.VecRec.Construction`. -/ +noncomputable def result (xs : V) : V := + Classical.chooseUnique (c.graph_existsUnique param xs) + +lemma result_graph (xs : V) : c.Graph param ⟪xs, c.result param xs⟫ := + Classical.chooseUnique_spec (c.graph_existsUnique param xs) + +lemma result_eq_of_graph {xs y : V} (h : c.Graph param ⟪xs, y⟫) : c.result param xs = y := + c.graph_unique (c.result_graph param xs) h + +@[simp] +lemma result_nil : c.result param (0 : V) = c.nil param := + c.result_eq_of_graph param (c.graph_nil.mpr rfl) + +@[simp] +lemma result_adjoin (x xs : V) : + c.result param (x ∷ xs) = c.adjoin param x xs (c.result param xs) := + c.result_eq_of_graph param (c.graph_adjoin.mpr ⟨_, rfl, c.result_graph param xs⟩) + +section + +lemma result_defined : Σ₁.DefinedFunction (fun v ↦ c.result (v ·.succ) (v 0)) β.resultDef := + .mk fun v ↦ by + simp only [Blueprint.resultDef, Nat.succ_eq_add_one, Nat.reduceAdd, BinderNotation.finSuccItr, + Nat.add_zero, HierarchySymbol.Semiformula.val_mkSigma, Semiformula.eval_ex, + LogicalConnective.HomClass.map_and, Semiformula.eval_substs, Matrix.comp₃, + Semiterm.val_bvar, Matrix.cons_val_zero, Matrix.cons_app_two, Matrix.cons_val_one, + HierarchySymbol.Defined.iff, Fin.isValue, Fin.succ_zero_eq_one, Fin.succ_one_eq_two, + Matrix.cons_val_fin_one, c.graph_defined.iff, Function.comp_apply, Matrix.cons_val_succ, + LogicalConnective.Prop.and_eq, exists_eq_left] + constructor + · intro h; symm; simpa using c.result_eq_of_graph _ h + · intro h; rw [h]; exact c.result_graph _ _ + +lemma eval_resultDef (v : Fin (arity + 2) → V) : + β.resultDef.val.Evalb v ↔ v 0 = c.result (v ·.succ.succ) (v 1) := + c.result_defined.iff + +instance result_definable : Σ₁.DefinableFunction (fun v ↦ c.result (v ·.succ) (v 0)) := + c.result_defined.to_definable + +instance result_definable' (Γ m) : + Γ-[m + 1].DefinableFunction (fun v ↦ c.result (v ·.succ) (v 0)) := + c.result_definable.of_sigmaOne + +end + +end Construction + +end VecRec + +/-! +### Length of List + +-/ + +namespace Len + +/-- The blueprint construction in `FFL.FirstOrder.Arithmetic.Len`. -/ +def blueprint : VecRec.Blueprint 0 + where + nil := .mkSigma (“y. y = 0”) + adjoin := .mkSigma (“y x xs ih. y = ih + 1”) + +/-- The adjointruction construction in `FFL.FirstOrder.Arithmetic.Len`. -/ +def adjointruction : VecRec.Construction V blueprint + where + nil _ := 0 + adjoin _ _ _ ih := ih + 1 + nil_defined := .mk fun v ↦ by simp [blueprint] + adjoin_defined := .mk fun v ↦ by simp [blueprint] + +end Len + +section len + +open Len + +/-- The len construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def len (v : V) : V := + adjointruction.result ![] v + +@[simp] +lemma len_nil : len (0 : V) = 0 := by simp [len, adjointruction] + +@[simp] +lemma len_adjoin (x v : V) : len (x ∷ v) = len v + 1 := by simp [len, adjointruction] + +section + +/-- The len Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.lenDef : Σ₁.Semisentence 2 := + blueprint.resultDef + +instance len_defined : Σ₁-Function₁ (len : V → V) via lenDef := + adjointruction.result_defined + +instance len_definable : Σ₁-Function₁ (len : V → V) := + len_defined.to_definable + +instance len_definable' (Γ m) : Γ-[m + 1]-Function₁ (len : V → V) := + len_definable.of_sigmaOne + +end + +@[simp] +lemma len_zero_iff_eq_nil {v : V} : len v = 0 ↔ v = 0 := by + rcases nil_or_adjoin v with (rfl | ⟨x, v, rfl⟩) <;> simp + +lemma nth_lt_len {v i : V} (hl : len v ≤ i) : v.[i] = 0 := + by + induction v using adjoin_ISigma1.pi1_succ_induction generalizing i + · definability + case nil => simp + case adjoin x v ih => + rcases zero_or_succ i with (rfl | ⟨i, rfl⟩) + · simp at hl + simpa using ih (by simpa using hl) + +@[simp] +lemma len_le (v : V) : len v ≤ v := + by + induction v using adjoin_ISigma1.pi1_succ_induction + · definability + case nil => simp + case adjoin x v ih => + simp only [len_adjoin] + simp only [adjoin, add_le_add_iff_right] + exact le_trans ih (le_pair_right x v) + +end len + +lemma nth_ext {v₁ v₂ : V} (hl : len v₁ = len v₂) (H : ∀ i < len v₁, v₁.[i] = v₂.[i]) : + v₁ = v₂ := + by + induction v₁ using adjoin_ISigma1.pi1_succ_induction generalizing v₂ + · definability + case nil => exact Eq.symm <| len_zero_iff_eq_nil.mp (by simp [← hl]) + case adjoin x₁ v₁ ih => + rcases nil_or_adjoin v₂ with (rfl | ⟨x₂, v₂, rfl⟩) + · simp at hl + have hx : x₁ = x₂ := by simpa using H 0 (by simp) + have hv : v₁ = v₂ := + ih (by simpa using hl) (by intro i hi; simpa using H (i + 1) (by simpa using hi)) + simp [hx, hv] + +lemma nth_ext' (l : V) {v₁ v₂ : V} (hl₁ : len v₁ = l) (hl₂ : len v₂ = l) + (H : ∀ i < l, v₁.[i] = v₂.[i]) : v₁ = v₂ := by + rcases hl₂; + exact nth_ext hl₁ (by simpa [hl₁] using H) + +lemma le_of_nth_le_nth {v₁ v₂ : V} (hl : len v₁ = len v₂) (H : ∀ i < len v₁, v₁.[i] ≤ v₂.[i]) : + v₁ ≤ v₂ := + by + induction v₁ using adjoin_ISigma1.pi1_succ_induction generalizing v₂ + · definability + case nil => simp + case adjoin x₁ v₁ ih => + rcases nil_or_adjoin v₂ with (rfl | ⟨x₂, v₂, rfl⟩) + · simp at hl + have hx : x₁ ≤ x₂ := by simpa using H 0 (by simp) + have hv : v₁ ≤ v₂ := + ih (by simpa using hl) (by intro i hi; simpa using H (i + 1) (by simpa using hi)) + exact adjoin_le_adjoin hx hv + +lemma nth_lt_self {v i : V} (hi : i < len v) : v.[i] < v := + by + induction v using adjoin_ISigma1.pi1_succ_induction generalizing i + · definability + case nil => simp at hi + case adjoin x v ih => + rcases zero_or_succ i with (rfl | ⟨i, rfl⟩) + · simp + · simpa using lt_trans (ih (by simpa using hi)) (by simp) + +theorem sigmaOne_skolem_vec {R : V → V → Prop} (hP : Σ₁-Relation R) {l} + (H : ∀ x < l, ∃ y, R x y) : ∃ v, len v = l ∧ ∀ i < l, R i v.[i] := + by + have : ∀ k ≤ l, ∃ v, len v = k ∧ ∀ i < k, R (l - k + i) v.[i] := + by + intro k hk + induction k using ISigma1.sigma1_succ_induction + · definability + case zero => exact ⟨0, by simp⟩ + case succ k ih => + rcases ih (le_trans (by simp) hk) with ⟨v, hvk, hv⟩ + have : ∃ y, R (l - (k + 1)) y := H (l - (k + 1)) (by simp [tsub_lt_iff_left hk]) + rcases this with ⟨y, hy⟩ + exact + ⟨y ∷ v, by simp [hvk], fun i hi ↦ + by + rcases zero_or_succ i with (rfl | ⟨i, rfl⟩) + · simpa using hy + · simpa [sub_succ_add_succ (succ_le_iff_lt.mp hk) i] using hv i (by simpa using hi)⟩ + simpa using this l (by rfl) + +lemma eq_singleton_iff_len_eq_one {v : V} : len v = 1 ↔ ∃ x, v = ?[x] := + by + constructor + · intro h; exact ⟨v.[0], nth_ext (by simp [h]) (by simp [h])⟩ + · rintro ⟨x, rfl⟩; simp + +lemma eq_doubleton_of_len_eq_two {v : V} : len v = 2 ↔ ∃ x y, v = ?[x, y] := + by + constructor + · intro h; + exact + ⟨v.[0], v.[1], + nth_ext (by simp [h, one_add_one_eq_two]) + (by simp [lt_two_iff_le_one, le_one_iff_eq_zero_or_one, h])⟩ + · rintro ⟨x, y, rfl⟩; simp [one_add_one_eq_two] + +/-! +### Maximum of List + +-/ + +namespace ListMax + +/-- The blueprint construction in `FFL.FirstOrder.Arithmetic.ListMax`. -/ +def blueprint : VecRec.Blueprint 0 + where + nil := .mkSigma (“y. y = 0”) + adjoin := .mkSigma (“y x xs ih. !max.dfn y x ih”) + +/-- The adjointruction construction in `FFL.FirstOrder.Arithmetic.ListMax`. -/ +noncomputable def adjointruction : VecRec.Construction V blueprint + where + nil _ := 0 + adjoin _ x _ ih := max x ih + nil_defined := .mk fun v ↦ by simp [blueprint] + adjoin_defined := .mk fun v ↦ by simp [blueprint] + +end ListMax + +section listMax + +open ListMax + +/-- The list Max construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def listMax (v : V) : V := + adjointruction.result ![] v + +@[simp] +lemma listMax_nil : listMax (0 : V) = 0 := by simp [listMax, adjointruction] + +@[simp] +lemma listMax_adjoin (x v : V) : listMax (x ∷ v) = max x (listMax v) := by + simp [listMax, adjointruction] + +section + +/-- The list Max Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.listMaxDef : Σ₁.Semisentence 2 := + blueprint.resultDef + +instance listMax_defined : Σ₁-Function₁ (listMax : V → V) via listMaxDef := + adjointruction.result_defined + +instance listMax_definable : Σ₁-Function₁ (listMax : V → V) := + listMax_defined.to_definable + +instance listMax_definable' (Γ m) : Γ-[m + 1]-Function₁ (listMax : V → V) := + listMax_definable.of_sigmaOne + +end + +lemma nth_le_listMax {i v : V} (h : i < len v) : v.[i] ≤ listMax v := + by + induction v using adjoin_ISigma1.pi1_succ_induction generalizing i + · definability + case nil => simp + case adjoin x v ih => + rcases zero_or_succ i with (rfl | ⟨i, rfl⟩) + · simp + · simp [ih (by simpa using h)] + +lemma listMaxss_le {v z : V} (h : ∀ i < len v, v.[i] ≤ z) : listMax v ≤ z := + by + induction v using adjoin_ISigma1.pi1_succ_induction + · definability + case nil => simp + case adjoin x v ih => + simp only [listMax_adjoin, max_le_iff] + constructor + · simpa using h 0 (by simp) + · exact ih (fun i hi ↦ by simpa using h (i + 1) (by simp [hi])) + +lemma listMaxss_le_iff {v z : V} : listMax v ≤ z ↔ ∀ i < len v, v.[i] ≤ z := + by + constructor + · intro h i hi; exact le_trans (nth_le_listMax hi) h + · exact listMaxss_le + +end listMax + +/-! +### Take Last k-Element + +-/ + +namespace TakeLast + +/-- The blueprint construction in `FFL.FirstOrder.Arithmetic.TakeLast`. -/ +def blueprint : VecRec.Blueprint 1 + where + nil := .mkSigma (“y k. y = 0”) + adjoin := + .mkSigma (“y x xs ih k. ∃ l, !lenDef l xs ∧ (l < k → !adjoinDef y x xs) ∧ (k ≤ l → y = ih)”) + +/-- The adjointruction construction in `FFL.FirstOrder.Arithmetic.TakeLast`. -/ +noncomputable def adjointruction : VecRec.Construction V blueprint + where + nil _ := 0 + adjoin (param x xs ih) := if len xs < param 0 then x ∷ xs else ih + nil_defined := .mk fun v ↦ by simp [blueprint] + adjoin_defined := + .mk fun v ↦ + by + suffices + (len (v 2) < v 4 → v 0 = v 1 ∷ v 2) ∧ (v 4 ≤ len (v 2) → v 0 = v 3) ↔ + (v 0 = if len (v 2) < v 4 then v 1 ∷ v 2 else v 3) + by simpa [blueprint, Fin.isValue] + rcases lt_or_ge (len (v 2)) (v 4) with (hv | hv) + · simp [hv] + · simp [hv, not_lt_of_ge hv] + +end TakeLast + +section takeLast + +open TakeLast + +/-- The take Last construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def takeLast (v k : V) : V := + adjointruction.result ![k] v + +@[simp] +lemma takeLast_nil : takeLast (0 : V) k = 0 := by simp [takeLast, adjointruction] + +lemma takeLast_adjoin (x v : V) : + takeLast (x ∷ v) k = if len v < k then x ∷ v else takeLast v k := by + simp [takeLast, adjointruction] + +section + +/-- The take Last Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.takeLastDef : Σ₁.Semisentence 3 := + blueprint.resultDef + +instance takeLast_defined : Σ₁-Function₂ (takeLast : V → V → V) via takeLastDef := + adjointruction.result_defined + +instance takeLast_definable : Σ₁-Function₂ (takeLast : V → V → V) := + takeLast_defined.to_definable + +instance takeLast_definable' (Γ m) : Γ-[m + 1]-Function₂ (takeLast : V → V → V) := + takeLast_definable.of_sigmaOne + +end + +lemma len_takeLast {v k : V} (h : k ≤ len v) : len (takeLast v k) = k := + by + induction v using adjoin_ISigma1.sigma1_succ_induction + · definability + case nil => simp_all + case adjoin x v + ih => + have : k = len v + 1 ∨ k ≤ len v := + by + rcases eq_or_lt_of_le h with (h | h) + · left; simpa using h + · right; simpa [lt_succ_iff_le] using h + rcases this with (rfl | hkv) + · simp [takeLast_adjoin] + · simp [takeLast_adjoin, not_lt_of_ge hkv, ih hkv] + +@[simp] +lemma takeLast_len_self (v : V) : takeLast v (len v) = v := by + rcases nil_or_adjoin v with (rfl | ⟨x, v, rfl⟩) <;> simp [takeLast_adjoin] + +/-- TODO: move -/ +@[simp] +lemma add_sub_add (a b c : V) : (a + c) - (b + c) = a - b := + add_tsub_add_eq_tsub_right a c b + +@[simp] +lemma takeLast_zero (v : V) : takeLast v 0 = 0 := + by + induction v using adjoin_ISigma1.sigma1_succ_induction + · definability + case nil => simp + case adjoin x v ih => simp [takeLast_adjoin, ih] + +lemma takeLast_succ_of_lt {i v : V} (h : i < len v) : + takeLast v (i + 1) = v.[len v - (i + 1)] ∷ takeLast v i := + by + induction v using adjoin_ISigma1.sigma1_succ_induction generalizing i + · definability + case nil => simp at h + case adjoin x v + ih => + rcases + show i = len v ∨ i < len v from eq_or_lt_of_le (by simpa [lt_succ_iff_le] using h) with + (rfl | hi) + · simp [takeLast_adjoin] + · have : len v - i = len v - (i + 1) + 1 := by + rw [← Arithmetic.sub_sub, + sub_add_self_of_le (le_tsub_of_add_le_left (lt_iff_succ_le.mp hi))] + simpa [takeLast_adjoin, lt_succ_iff_le, not_le_of_gt hi, this, not_lt_of_gt hi] using + ih hi + +end takeLast + +/-! +### Concatation + +-/ + +namespace Concat + +/-- The blueprint construction in `FFL.FirstOrder.Arithmetic.Concat`. -/ +def blueprint : VecRec.Blueprint 1 + where + nil := .mkSigma (“y z. !adjoinDef y z 0”) + adjoin := .mkSigma (“y x xs ih z. !adjoinDef y x ih”) + +/-- The adjointruction construction in `FFL.FirstOrder.Arithmetic.Concat`. -/ +noncomputable def adjointruction : VecRec.Construction V blueprint + where + nil param := ?[param 0] + adjoin (_ x _ ih) := x ∷ ih + nil_defined := .mk fun v ↦ by simp [blueprint] + adjoin_defined := .mk fun v ↦ by simp [blueprint, Fin.isValue] + +end Concat + +section concat + +open Concat + +/-- The concat construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def concat (v z : V) : V := + adjointruction.result ![z] v + +@[simp] +lemma concat_nil (z : V) : concat 0 z = ?[z] := by simp [concat, adjointruction] + +@[simp] +lemma concat_adjoin (x v z : V) : concat (x ∷ v) z = x ∷ concat v z := by + simp [concat, adjointruction] + +section + +/-- The concat Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.concatDef : Σ₁.Semisentence 3 := + blueprint.resultDef + +instance concat_defined : Σ₁-Function₂ (concat : V → V → V) via concatDef := + adjointruction.result_defined + +instance concat_definable : Σ₁-Function₂ (concat : V → V → V) := + concat_defined.to_definable + +instance concat_definable' (Γ m) : Γ-[m + 1]-Function₂ (concat : V → V → V) := + concat_definable.of_sigmaOne + +end + +@[simp] +lemma len_concat (v z : V) : len (concat v z) = len v + 1 := + by + induction v using adjoin_ISigma1.sigma1_succ_induction + · definability + case nil => simp + case adjoin x v ih => simp [ih] + +lemma concat_nth_lt (v z : V) {i} (hi : i < len v) : (concat v z).[i] = v.[i] := + by + induction v using adjoin_ISigma1.sigma1_succ_induction generalizing i + · definability + case nil => simp at hi + case adjoin x v ih => + rcases zero_or_succ i with (rfl | ⟨i, rfl⟩) + · simp + · simp [ih (by simpa using hi)] + +@[simp] +lemma concat_nth_len (v z : V) : (concat v z).[len v] = z := + by + induction v using adjoin_ISigma1.sigma1_succ_induction + · definability + case nil => simp + case adjoin x v ih => simp [ih] + +lemma concat_nth_len' (v z : V) {i} (hi : len v = i) : (concat v z).[i] = z := by + rcases hi; + simp + +end concat + +/-! +### Membership + +-/ + +section vec_membership + +/-- The Mem Vec construction in `FFL.FirstOrder.Arithmetic`. -/ +def MemVec (x v : V) : Prop := + ∃ i < len v, x = v.[i] + +/-- The «term ∈ᵥ » construction in `FFL.FirstOrder.Arithmetic`. -/ +scoped infix:40 " ∈ᵥ " => MemVec + +@[simp] +lemma not_memVec_empty (x : V) : ¬x ∈ᵥ 0 := by rintro ⟨i, h, _⟩; simp at h + +lemma nth_mem_memVec {i v : V} (h : i < len v) : v.[i] ∈ᵥ v := + ⟨i, by simp [h]⟩ + +@[simp] +lemma memVec_insert_fst {x v : V} : x ∈ᵥ x ∷ v := + ⟨0, by simp⟩ + +@[simp] +lemma memVec_adjoin_iff {x y v : V} : x ∈ᵥ y ∷ v ↔ x = y ∨ x ∈ᵥ v := + by + constructor + · rintro ⟨i, h, rfl⟩ + rcases zero_or_succ i with (rfl | ⟨i, rfl⟩) + · simp + · right; simpa using nth_mem_memVec (by simpa using h) + · rintro (rfl | hx) + · simp + · rcases hx with ⟨i, hi, rfl⟩ + exact ⟨i + 1, by simp [hi]⟩ + +lemma le_of_memVec {x v : V} (h : x ∈ᵥ v) : x ≤ v := by rcases h with ⟨i, _, rfl⟩; simp + +section + +/-- The mem Vec Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.memVecDef : ∆₁.Semisentence 2 := + .mkDelta (.mkSigma (“x v. ∃ l, !lenDef l v ∧ ∃ i < l, !nthDef x v i”)) + (.mkPi (“x v. ∀ l, !lenDef l v → ∃ i < l, ∀ vi, !nthDef vi v i → x = vi”)) + +instance memVec_defined : ∆₁-Relation (MemVec : V → V → Prop) via memVecDef := + ⟨by intro v; simp [memVecDef], by intro v; simp [memVecDef, MemVec]⟩ + +instance memVec_definable : ∆₁-Relation (MemVec : V → V → Prop) := + memVec_defined.to_definable + +instance memVec_definable' (Γ m) : Γ-[m + 1]-Relation (MemVec : V → V → Prop) := + memVec_definable.of_deltaOne + +end + +end vec_membership + +/-! +### Subset + +-/ + +section vec_subset + +/-- The Subset Vec construction in `FFL.FirstOrder.Arithmetic`. -/ +def SubsetVec (v w : V) : Prop := + ∀ x, x ∈ᵥ v → x ∈ᵥ w + +/-- The «term ⊆ᵥ » construction in `FFL.FirstOrder.Arithmetic`. -/ +scoped infix:30 " ⊆ᵥ " => SubsetVec + +@[simp, refl] +lemma SubsetVec.refl (v : V) : v ⊆ᵥ v := fun _ hx ↦ hx + +@[simp] +lemma subsetVec_insert_tail (x v : V) : v ⊆ᵥ x ∷ v := by intro y hy; simp [hy] + +section + +/-- The subset Vec Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.subsetVecDef : ∆₁.Semisentence 2 := + .mkDelta (.mkSigma (“v w. ∀ x <⁺ v, !memVecDef.pi x v → !memVecDef.sigma x w”)) + (.mkPi (“v w. ∀ x <⁺ v, !memVecDef.sigma x v → !memVecDef.pi x w”)) + +instance subsetVec_defined : ∆₁-Relation (SubsetVec : V → V → Prop) via subsetVecDef := + by + refine ⟨?_, ?_⟩ + · intro v + simp [subsetVecDef, HierarchySymbol.Semiformula.val_sigma, memVec_defined.proper.iff'] + · intro v + simp only [subsetVecDef, Fin.isValue, Nat.reduceAdd, Nat.succ_eq_add_one, + HierarchySymbol.Semiformula.val_sigma, HierarchySymbol.Semiformula.val_mkDelta, + HierarchySymbol.Semiformula.val_mkSigma, eval_ballLTSucc', Semiterm.val_bvar, + LogicalConnective.HomClass.map_imply, Semiformula.eval_substs, Matrix.comp₂, + Matrix.cons_val_zero, Matrix.cons_val_one, memVec_defined.proper.iff', + HierarchySymbol.Defined.iff, Matrix.cons_val_fin_one, Matrix.cons_app_two, + LogicalConnective.Prop.arrow_eq] + constructor + · intro h x hx + exact h x (le_of_memVec hx) hx + · intro h x _ + exact h x + +instance subsetVec_definable : ∆₁-Relation (SubsetVec : V → V → Prop) := + subsetVec_defined.to_definable + +instance subsetVec_definable' (Γ m) : Γ-[m + 1]-Relation (SubsetVec : V → V → Prop) := + subsetVec_definable.of_deltaOne + +end + +end vec_subset + +/-! +### Repeat + +-/ + +section repaetVec + +/-- The blueprint construction in `FFL.FirstOrder.Arithmetic.repeatVec`. -/ +def repeatVec.blueprint : PR.Blueprint 1 + where + zero := .mkSigma (“y x. y = 0”) + succ := .mkSigma (“y ih n x. !adjoinDef y x ih”) + +/-- The adjointruction construction in `FFL.FirstOrder.Arithmetic.repeatVec`. -/ +noncomputable def repeatVec.adjointruction : PR.Construction V repeatVec.blueprint + where + zero := fun _ ↦ 0 + succ := fun x _ ih ↦ x 0 ∷ ih + zero_defined := .mk fun v ↦ by simp [blueprint] + succ_defined := .mk fun v ↦ by simp [blueprint] + +/-- `repeatVec x k = x ∷ x ∷ x ∷ ... k times ... ∷ 0` -/ +noncomputable def repeatVec (x k : V) : V := + repeatVec.adjointruction.result ![x] k + +@[simp] +lemma repeatVec_zero (x : V) : repeatVec x 0 = 0 := by + simp [repeatVec, repeatVec.adjointruction] + +@[simp] +lemma repeatVec_succ (x k : V) : repeatVec x (k + 1) = x ∷ repeatVec x k := by + simp [repeatVec, repeatVec.adjointruction] + +section + +/-- The repeat Vec Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.repeatVecDef : Σ₁.Semisentence 3 := + repeatVec.blueprint.resultDef |>.rew (Rew.subst ![#0, #2, #1]) + +instance repeatVec_defined : Σ₁-Function₂ (repeatVec : V → V → V) via repeatVecDef := + .mk fun v ↦ by simp [repeatVec.adjointruction.result_defined_iff, repeatVecDef]; rfl + +instance repeatVec_definable : Σ₁-Function₂ (repeatVec : V → V → V) := + repeatVec_defined.to_definable + +instance repeatVec_definable' (Γ) : Γ-[m + 1]-Function₂ (repeatVec : V → V → V) := + repeatVec_definable.of_sigmaOne + +end + +@[simp] +lemma len_repeatVec (x k : V) : len (repeatVec x k) = k := + by + induction k using ISigma1.sigma1_succ_induction + · definability + case zero => simp + case succ k ih => simp [ih] + +@[simp] +lemma le_repaetVec (x k : V) : k ≤ repeatVec x k := by simpa using len_le (repeatVec x k) + +lemma nth_repeatVec (x k : V) {i} (h : i < k) : (repeatVec x k).[i] = x := + by + induction k using ISigma1.sigma1_succ_induction generalizing i + · definability + case zero => simp at h + case succ k ih => + rcases zero_or_succ i with (rfl | ⟨i, rfl⟩) + · simp + · simpa using ih (by simpa using h) + +lemma len_repeatVec_of_nth_le {v m : V} (H : ∀ i < len v, v.[i] ≤ m) : + v ≤ repeatVec m (len v) := + le_of_nth_le_nth (by simp) (fun i hi ↦ by simp [nth_repeatVec m (len v) hi, H i hi]) + +end repaetVec + +/-! +### Convert to Set + +-/ + +namespace VecToSet + +/-- The blueprint construction in `FFL.FirstOrder.Arithmetic.VecToSet`. -/ +def blueprint : VecRec.Blueprint 0 + where + nil := .mkSigma (“y. y = 0”) + adjoin := .mkSigma (“y x xs ih. !insertDef y x ih”) + +/-- The adjointruction construction in `FFL.FirstOrder.Arithmetic.VecToSet`. -/ +noncomputable def adjointruction : VecRec.Construction V blueprint + where + nil _ := ∅ + adjoin (_ x _ ih) := insert x ih + nil_defined := .mk fun v ↦ by simp [blueprint, emptyset_def] + adjoin_defined := .mk fun v ↦ by simp [blueprint] + +end VecToSet + +section vecToSet + +open VecToSet + +/-- The vec To Set construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def vecToSet (v : V) : V := + adjointruction.result ![] v + +@[simp] +lemma vecToSet_nil : vecToSet (0 : V) = ∅ := by simp [vecToSet, adjointruction] + +@[simp] +lemma vecToSet_adjoin (x v : V) : vecToSet (x ∷ v) = insert x (vecToSet v) := by + simp [vecToSet, adjointruction] + +section + +/-- The vec To Set Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.vecToSetDef : Σ₁.Semisentence 2 := + blueprint.resultDef + +instance vecToSet_defined : Σ₁-Function₁ (vecToSet : V → V) via vecToSetDef := + adjointruction.result_defined + +instance vecToSet_definable : Σ₁-Function₁ (vecToSet : V → V) := + vecToSet_defined.to_definable + +instance vecToSet_definable' (Γ) : Γ-[m + 1]-Function₁ (vecToSet : V → V) := + vecToSet_definable.of_sigmaOne + +end + +lemma mem_vecToSet_iff {v x : V} : x ∈ vecToSet v ↔ ∃ i < len v, x = v.[i] := + by + induction v using adjoin_ISigma1.sigma1_succ_induction + · definability + case nil => simp + case adjoin y v + ih => + simp only [vecToSet_adjoin, mem_bitInsert_iff, ih, len_adjoin] + constructor + · rintro (rfl | ⟨i, hi, rfl⟩) + · exact ⟨0, by simp⟩ + · exact ⟨i + 1, by simp [hi]⟩ + · rintro ⟨i, hi, rfl⟩ + rcases zero_or_succ i with (rfl | ⟨i, rfl⟩) + · simp + · right; exact ⟨i, by simpa using hi, by simp⟩ + +@[simp] +lemma nth_mem_vecToSet {v i : V} (h : i < len v) : v.[i] ∈ vecToSet v := + mem_vecToSet_iff.mpr ⟨i, h, rfl⟩ + +end vecToSet + +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/IOpen/Basic.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/IOpen/Basic.lean new file mode 100644 index 000000000..d02cb261f --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/IOpen/Basic.lean @@ -0,0 +1,1089 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Schemata + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +/-! +# Basic properties of theory $\mathsf{IOpen}$ + +-/ + +namespace FFL +namespace FirstOrder +namespace Arithmetic + +variable {V : Type*} [ORingStructure V] + +section IOpen + +variable [V↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + +instance : V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := + have : V↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧 := inferInstance + models_of_subtheory this + +instance : V↓[ℒₒᵣ] ⊧* InductionScheme ℒₒᵣ Semiformula.Open := + have : V↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧 := inferInstance + models_of_subtheory this + +@[elab_as_elim] +lemma succ_induction {P : V → Prop} + (hP : ∃ φ : ArithmeticSemiformula V 1, φ.Open ∧ ∀ x, P x ↔ φ.Eval ![x] id) (zero : P 0) + (succ : ∀ x, P x → P (x + 1)) : ∀ x, P x := + InductionScheme.succ_induction (C := Semiformula.Open) + (by + rcases hP with ⟨φ, hp, hhp⟩ + have : Inhabited V := Classical.inhabited_of_nonempty' + refine ⟨φ.enumerateFVar, Rew.rewriteMap φ.idxOfFVar ▹ φ, by simp [hp], ?_⟩ + intro x + simp only [hhp, Nat.succ_eq_add_one, Nat.reduceAdd, Semiformula.eval_rewriteMap] + exact + Semiformula.eval_iff_of_funEqOn φ + (by + intro z hz + simp [Semiformula.enumerateFVar_idxOfFVar + (Semiformula.mem_fvarList_iff_hasFreeVariable.mpr hz)])) + zero succ + +lemma least_number {P : V → Prop} + (hP : ∃ φ : ArithmeticSemiformula V 1, φ.Open ∧ ∀ x, P x ↔ φ.Eval ![x] id) (zero : P 0) {a} + (counterex : ¬P a) : ∃ x, P x ∧ ¬P (x + 1) := + by + by_contra A + have : ∀ x, P x := by + intro x; induction x using succ_induction + · exact hP + case zero => exact zero + case succ n ih => + have : ∀ (x : V), P x → P (x + 1) := by simpa using A + exact this n ih + have : P a := this a + contradiction + +/-! +### Division -/ + +section div + +lemma div_exists_unique_pos (a : V) {b} (pos : 0 < b) : ∃! u, b * u ≤ a ∧ a < b * (u + 1) := + by + have : ∃ u, b * u ≤ a ∧ a < b * (u + 1) := + by + have : a < b * (a + 1) → ∃ u, b * u ≤ a ∧ a < b * (u + 1) := by + simpa using + least_number (P := fun u ↦ b * u ≤ a) ⟨“x. &b * x ≤ &a”, by simp, by intro x; simp⟩ + have hx : a < b * (a + 1) := + by + have : a + 0 < b * a + b := add_lt_add_of_le_of_lt (le_mul_self_of_pos_left pos) pos + simpa [mul_add] using this + exact this hx + rcases this with ⟨u, hu⟩ + exact + ExistsUnique.intro u hu + (by + intro u' hu' + by_contra ne + wlog lt : u < u' + · exact this a pos u' hu' u hu (Ne.symm ne) (Ne.lt_of_le ne <| by simpa using lt) + have : a < a := by + calc + a < b * (u + 1) := hu.2 + _ ≤ b * u' := ((mul_le_mul_iff_right₀ pos).mpr (lt_iff_succ_le.mp lt)) + _ ≤ a := hu'.1 + exact LT.lt.false this) + +lemma div_exists_unique (a b : V) : + ∃! u, (0 < b → b * u ≤ a ∧ a < b * (u + 1)) ∧ (b = 0 → u = 0) := + by + have : 0 ≤ b := by exact Arithmetic.zero_le b + rcases this with (rfl | pos) <;> simp [*] + · simpa [pos_iff_ne_zero.mp pos] using div_exists_unique_pos a pos + +/-- The inst Div lean Pool construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable scoped instance instDivModel : Div V := + ⟨fun a b ↦ Classical.chooseUnique (div_exists_unique a b)⟩ + +lemma mul_div_le_pos (a : V) (h : 0 < b) : b * (a / b) ≤ a := + ((Classical.chooseUnique_spec (div_exists_unique a b)).1 h).1 + +lemma lt_mul_div_succ (a : V) (h : 0 < b) : a < b * (a / b + 1) := + ((Classical.chooseUnique_spec (div_exists_unique a b)).1 h).2 + +lemma eq_mul_div_add_of_pos (a : V) {b} (hb : 0 < b) : ∃ r < b, a = b * (a / b) + r := + by + let r := a - b * (a / b) + have e : a = b * (a / b) + r := by simp [r, add_tsub_self_of_le (mul_div_le_pos a hb)] + exact + ⟨r, by + by_contra A + have hyv : b ≤ r := by simpa using A + have : a < a := by + calc + a < b * (a / b + 1) := lt_mul_div_succ a hb + _ ≤ b * (a / b) + r := by simpa [mul_add] using hyv + _ = a := e.symm + simp at this, e⟩ + +@[simp] +lemma div_spec_zero (a : V) : a / 0 = 0 := + (Classical.chooseUnique_spec (div_exists_unique a 0)).2 (by simp) + +lemma div_graph {a b c : V} : + c = a / b ↔ ((0 < b → b * c ≤ a ∧ a < b * (c + 1)) ∧ (b = 0 → c = 0)) := + Classical.chooseUnique_eq_iff_right _ + +/-- The div Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.divDef : Σ₀.Semisentence 3 := + .mkSigma (“c a b. (0 < b → b * c ≤ a ∧ a < b * (c + 1)) ∧ (b = 0 → c = 0)”) + +instance div_defined : Σ₀-Function₂[V] HDiv.hDiv via divDef := + .mk fun v ↦ by simp [div_graph, divDef] + +lemma div_spec_of_pos' (a : V) (h : 0 < b) : ∃ v < b, a = (a / b) * b + v := by + simpa [mul_comm] using eq_mul_div_add_of_pos a h + +lemma div_eq_of {b : V} (hb : b * c ≤ a) (ha : a < b * (c + 1)) : a / b = c := + by + have pos : 0 < b := pos_of_mul_pos_left (pos_of_gt ha) (by simp) + exact + (div_exists_unique_pos a pos).unique ⟨mul_div_le_pos a pos, lt_mul_div_succ a pos⟩ ⟨hb, ha⟩ + +lemma div_mul_add (a b : V) {r} (hr : r < b) : (a * b + r) / b = a := + div_eq_of (by simp [mul_comm]) (by simp [mul_comm b a, mul_add, hr]) + +lemma div_mul_add' (a b : V) {r} (hr : r < b) : (b * a + r) / b = a := by + simpa [mul_comm] using div_mul_add a b hr + +@[simp] +lemma zero_div (a : V) : 0 / a = 0 := + by + rcases Arithmetic.zero_le a with (rfl | pos) + · simp + · exact div_eq_of (by simp) (by simpa) + +lemma div_mul (a b c : V) : a / (b * c) = a / b / c := + by + rcases Arithmetic.zero_le b with (rfl | hb) + · simp + rcases Arithmetic.zero_le c with (rfl | hc) + · simp + exact + div_eq_of + (by + calc + b * c * (a / b / c) ≤ b * (a / b) := by + simpa [mul_assoc] using mul_le_mul_left (mul_div_le_pos (a / b) hc) + _ ≤ a := mul_div_le_pos a hb) + (by + calc + a < b * (a / b + 1) := lt_mul_div_succ a hb + _ ≤ b * c * (a / b / c + 1) := by + simpa [mul_assoc] using + mul_le_mul_left (lt_iff_succ_le.mp <| lt_mul_div_succ (a / b) hc)) + +@[simp] +lemma mul_div_le (a b : V) : b * (a / b) ≤ a := + by + have : 0 ≤ b := by exact Arithmetic.zero_le b + rcases this with (rfl | pos) + · simp + · rcases eq_mul_div_add_of_pos a pos with ⟨v, _, e⟩ + simpa [← e] using show b * (a / b) ≤ b * (a / b) + v from le_self_add + +@[simp] +lemma div_le (a b : V) : a / b ≤ a := + by + have : 0 ≤ b := Arithmetic.zero_le b + rcases this with (rfl | pos) + · simp + · have : 1 * (a / b) ≤ b * (a / b) := + mul_le_mul_of_nonneg_right (le_iff_lt_succ.mpr (by simp [pos])) (by simp) + simpa using le_trans this (mul_div_le a b) + +instance div_polybounded : Bounded₂ ((· / ·) : V → V → V) := + ⟨#0, fun _ ↦ by simp⟩ + +instance div_definable : Σ₀-Function₂ ((· / ·) : V → V → V) := + div_defined.to_definable _ + +@[simp] +lemma div_mul_le (a b : V) : a / b * b ≤ a := by rw [mul_comm]; exact mul_div_le _ _ + +lemma lt_mul_div (a : V) {b} (pos : 0 < b) : a < b * (a / b + 1) := + by + rcases eq_mul_div_add_of_pos a pos with ⟨v, hv, e⟩ + calc + a = b * (a / b) + v := e + _ < b * (a / b + 1) := by simp [mul_add, hv] + +@[simp] +lemma div_one (a : V) : a / 1 = a := + le_antisymm (by simp) (le_iff_lt_succ.mpr <| by simpa using lt_mul_div a one_pos) + +lemma div_add_mul_self (a c : V) {b} (pos : 0 < b) : (a + c * b) / b = a / b + c := + by + rcases div_spec_of_pos' a pos with ⟨r, hr, ex⟩ + simpa [add_mul, add_right_comm, ← ex] using div_mul_add (a / b + c) _ hr + +lemma div_add_mul_self' (a c : V) {b} (pos : 0 < b) : (a + b * c) / b = a / b + c := by + simpa [mul_comm] using div_add_mul_self a c pos + +lemma div_mul_add_self (a c : V) {b} (pos : 0 < b) : (a * b + c) / b = a + c / b := by + simp [div_add_mul_self, pos, add_comm] + +lemma div_mul_add_self' (a c : V) {b} (pos : 0 < b) : (b * a + c) / b = a + c / b := by + simp [mul_comm b a, div_mul_add_self, pos] + +@[simp] +lemma div_mul_left (a : V) {b} (pos : 0 < b) : (a * b) / b = a := by + simpa using div_mul_add a _ pos + +@[simp] +lemma div_mul_right (a : V) {b} (pos : 0 < b) : (b * a) / b = a := by + simpa [mul_comm] using div_mul_add a _ pos + +@[simp] +lemma div_eq_zero_of_lt (b : V) {a} (h : a < b) : a / b = 0 := by simpa using div_mul_add 0 b h + +@[simp] +lemma div_sq (a : V) : a ^ 2 / a = a := + by + rcases Arithmetic.zero_le a with (rfl | pos) + · simp + · simp [sq, pos] + +@[simp] +lemma div_self {a : V} (hx : 0 < a) : a / a = 1 := by simpa using div_mul_left 1 hx + +lemma div_mul' (a : V) {b} (pos : 0 < b) : (b * a) / b = a := by simp [mul_comm, pos] + +@[simp] +lemma div_add_self_left {a} (pos : 0 < a) (b : V) : (a + b) / a = 1 + b / a := by + simpa using div_mul_add_self 1 b pos + +@[simp] +lemma div_add_self_right (a : V) {b} (pos : 0 < b) : (a + b) / b = a / b + 1 := by + simpa using div_add_mul_self a 1 pos + +lemma mul_div_self_of_dvd {a b : V} : a * (b / a) = b ↔ a ∣ b := + by + rcases Arithmetic.zero_le a with (rfl | pos) + · simp [eq_comm] + · constructor + · intro e; rw [← e]; simp + · rintro ⟨r, rfl⟩; simp [pos] + +lemma div_lt_of_pos_of_one_lt {a b : V} (ha : 0 < a) (hb : 1 < b) : a / b < a := + by + rcases Arithmetic.zero_le (a / b) with (e | lt) + · simp [← e, ha] + · exact lt_of_lt_of_le (lt_mul_of_one_lt_left lt hb) (mul_div_le a b) + +lemma le_two_mul_div_two_add_one (a : V) : a ≤ 2 * (a / 2) + 1 := + by + have : a < 2 * (a / 2 + 1) := lt_mul_div_succ a (show 0 < 2 from by simp) + exact le_iff_lt_succ.mpr (by simpa [add_assoc, one_add_one_eq_two, mul_add] using this) + +lemma div_monotone {a b : V} (h : a ≤ b) (c : V) : a / c ≤ b / c := + by + rcases Arithmetic.zero_le c with (rfl | pos) + · simp + by_contra A + have : b / c + 1 ≤ a / c := succ_le_iff_lt.mpr (by simpa using A) + have : a < a := + calc + a ≤ b := h + _ < c * (b / c + 1) := (lt_mul_div b pos) + _ ≤ c * (a / c) := (mul_le_mul_left this) + _ ≤ a := mul_div_le a c + simp_all + +lemma div_lt_of_lt_mul {a b c : V} (h : a < b * c) : a / c < b := + by + by_contra hb + have : a < a := + calc + a < b * c := h + _ ≤ a / c * c := (mul_le_mul_right (by simpa using hb)) + _ ≤ a := by simp + simp_all + +lemma div_cancel_left {c} (pos : 0 < c) (a b : V) : (c * a) / (c * b) = a / b := by + simp [div_mul, pos] + +lemma div_cancel_right {c} (pos : 0 < c) (a b : V) : (a * c) / (b * c) = a / b := by + simp [mul_comm _ c, div_cancel_left pos] + +@[simp] +lemma two_mul_add_one_div_two (a : V) : (2 * a + 1) / 2 = a := by simp [div_mul_add_self'] + +end div + +/-! +### Remainder -/ + +section mod + +/-- The rem construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def rem (a b : V) : V := + a - b * (a / b) + +/-- The inst Mod lean Pool construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable scoped instance instModModel : Mod V := + ⟨rem⟩ + +lemma mod_def (a b : V) : a % b = a - b * (a / b) := + rfl + +/-- The rem Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.remDef : Σ₀.Semisentence 3 := + .mkSigma (“c a b. ∃ d <⁺ a, !divDef.val d a b ∧ !subDef.val c a(b * d)”) + +lemma rem_graph (a b c : V) : a = b % c ↔ ∃ x ≤ b, (x = b / c ∧ a = b - c * x) := by + simp [mod_def] + +instance rem_defined : Σ₀-Function₂[V] HMod.hMod via remDef := + .mk fun v ↦ by simp [remDef, rem_graph, Semiformula.eval_substs, le_iff_lt_succ] + +instance rem_definable : Σ₀-Function₂[V] HMod.hMod := + rem_defined.to_definable _ + +lemma div_add_mod (a b : V) : b * (a / b) + (a % b) = a := + add_tsub_self_of_le (mul_div_le a b) + +@[simp] +lemma mod_zero (a : V) : a % 0 = a := by simp [mod_def] + +@[simp] +lemma zero_mod (a : V) : 0 % a = 0 := by simp [mod_def] + +@[simp] +lemma mod_self (a : V) : a % a = 0 := + by + rcases Arithmetic.zero_le a with (rfl | h) + · simp + · simp [mod_def, h] + +lemma mod_mul_add_of_lt (a b : V) {r} (hr : r < b) : (a * b + r) % b = r := by + simp [mod_def, div_mul_add a b hr, mul_comm] + +@[simp] +lemma mod_mul_add (a c : V) (pos : 0 < b) : (a * b + c) % b = c % b := by + simp [mod_def, div_mul_add_self, pos, mul_add, ← Arithmetic.sub_sub, + show b * a = a * b from mul_comm _ _] + +@[simp] +lemma mod_add_mul (a b : V) (pos : 0 < c) : (a + b * c) % c = a % c := by + simp [add_comm a (b * c), pos] + +@[simp] +lemma mod_add_mul' (a b : V) (pos : 0 < c) : (a + c * b) % c = a % c := by + simp [mul_comm c b, pos] + +@[simp] +lemma mod_mul_add' (a c : V) (pos : 0 < b) : (b * a + c) % b = c % b := by + simp [mul_comm b a, pos] + +@[simp] +lemma mod_mul_self_left (a b : V) : (a * b) % b = 0 := + by + rcases Arithmetic.zero_le b with (rfl | h) + · simp + · simpa using mod_mul_add_of_lt a b h + +@[simp] +lemma mod_mul_self_right (a b : V) : (b * a) % b = 0 := by simp [mul_comm] + +@[simp] +lemma mod_eq_self_of_lt {a b : V} (h : a < b) : a % b = a := by + simpa using mod_mul_add_of_lt 0 b h + +@[simp] +lemma mod_lt (a : V) {b} (pos : 0 < b) : a % b < b := + by + rcases div_spec_of_pos' a pos with ⟨r, hr, ha⟩ + have : ((a / b) * b + r) % b = r := mod_mul_add_of_lt _ _ hr + have : a % b = r := by simpa [← ha] using this + simp [this, hr] + +@[simp] +lemma mod_le (a b : V) : a % b ≤ a := by simp [mod_def] + +instance mod_polybounded : Bounded₂ ((· % ·) : V → V → V) := + ⟨#0, by intro v; simp⟩ + +lemma mod_eq_zero_iff_dvd {a b : V} : b % a = 0 ↔ a ∣ b := + by + simp only [mod_def, sub_eq_zero_iff_le] + constructor + · intro H; exact mul_div_self_of_dvd.mp (le_antisymm (mul_div_le b a) H) + · intro H; simp [mul_div_self_of_dvd.mpr H] + +@[simp] +lemma mod_add_remove_right {a b : V} (pos : 0 < b) : (a + b) % b = a % b := by + simpa using mod_add_mul a 1 pos + +lemma mod_add_remove_right_of_dvd {a b m : V} (h : m ∣ b) (pos : 0 < m) : (a + b) % m = a % m := + by rcases h with ⟨b, rfl⟩; simp [pos] + +@[simp] +lemma mod_add_remove_left {a b : V} (pos : 0 < a) : (a + b) % a = b % a := by + simpa using mod_mul_add 1 b pos + +lemma mod_add_remove_left_of_dvd {a b m : V} (h : m ∣ a) (pos : 0 < m) : (a + b) % m = b % m := + by rcases h with ⟨b, rfl⟩; simp [pos] + +lemma mod_add {a b m : V} (pos : 0 < m) : (a + b) % m = (a % m + b % m) % m := + calc + (a + b) % m = ((m * (a / m) + a % m) + (m * (b / m) + b % m)) % m := by simp [div_add_mod] + _ = (m * (a / m) + m * (b / m) + (a % m) + (b % m)) % m := by + simp [← add_assoc, add_right_comm] + _ = (a % m + b % m) % m := by simp [add_assoc, pos] + +lemma mod_mul {a b m : V} (pos : 0 < m) : (a * b) % m = ((a % m) * (b % m)) % m := + calc + (a * b) % m = ((m * (a / m) + (a % m)) * (m * (b / m) + b % m)) % m := by simp [div_add_mod] + _ = ((a % m) * (b % m)) % m := by + simp [add_mul, mul_add, pos, mul_left_comm _ m, add_assoc, mul_assoc] + +@[simp] +lemma mod_div (a b : V) : a % b / b = 0 := + by + rcases Arithmetic.zero_le b with (rfl | pos) + · simp + · exact div_eq_zero_of_lt b (by simp [pos]) + +@[simp] +lemma mod_one (a : V) : a % 1 = 0 := + lt_one_iff_eq_zero.mp <| mod_lt a (by simp) + +lemma mod_two (a : V) : a % 2 = 0 ∨ a % 2 = 1 := + le_one_iff_eq_zero_or_one.mp <| lt_two_iff_le_one.mp <| mod_lt a (b := 2) (by simp) + +@[simp] +lemma mod_two_not_zero_iff {a : V} : ¬a % 2 = 0 ↔ a % 2 = 1 := by + rcases mod_two a with (h | h) <;> simp [*] + +@[simp] +lemma mod_two_not_one_iff {a : V} : ¬a % 2 = 1 ↔ a % 2 = 0 := by + rcases mod_two a with (h | h) <;> simp [*] + +end mod + +lemma two_dvd_mul {a b : V} : 2 ∣ a * b → 2 ∣ a ∨ 2 ∣ b := + by + intro H; by_contra A + have A : ¬2 ∣ a ∧ ¬2 ∣ b := by simpa using A + have ha : a % 2 = 1 := by + have : a % 2 = 0 ∨ a % 2 = 1 := mod_two a + simpa [show a % 2 ≠ 0 from by simpa [← mod_eq_zero_iff_dvd] using A.1] using this + have hb : b % 2 = 1 := + by + have : b % 2 = 0 ∨ b % 2 = 1 := + le_one_iff_eq_zero_or_one.mp <| lt_two_iff_le_one.mp <| mod_lt b (b := 2) (by simp) + simpa [show b % 2 ≠ 0 from by simpa [← mod_eq_zero_iff_dvd] using A.2] using this + have : a * b % 2 = 1 := by simp [mod_mul, ha, hb] + have : ¬2 ∣ a * b := by simp [← mod_eq_zero_iff_dvd, this] + contradiction + +lemma even_or_odd (a : V) : ∃ x, a = 2 * x ∨ a = 2 * x + 1 := + ⟨a / 2, by + have : 2 * (a / 2) + (a % 2) = a := div_add_mod a 2 + rcases mod_two a with (e | e) <;> + { simp [e] at this; simp [this] + }⟩ + +lemma even_or_odd' (a : V) : a = 2 * (a / 2) ∨ a = 2 * (a / 2) + 1 := + by + have : 2 * (a / 2) + (a % 2) = a := div_add_mod a 2 + rcases mod_two a with (e | e) <;> simp [e] at this <;> simp [*] + +lemma two_prime : Prime (2 : V) := + ⟨by simp, by simp, by intro a b h; exact two_dvd_mul h⟩ + +/-! +### Square root -/ + +section sqrt + +lemma sqrt_exists_unique (a : V) : ∃! x, x * x ≤ a ∧ a < (x + 1) * (x + 1) := + by + have : ∃ x, x * x ≤ a ∧ a < (x + 1) * (x + 1) := + by + have : a < (a + 1) * (a + 1) → ∃ x, x * x ≤ a ∧ a < (x + 1) * (x + 1) := by + simpa using least_number (P := fun x ↦ x * x ≤ a) ⟨“x. x * x ≤ &a”, by simp, by simp⟩ + have hn : a < (a + 1) * (a + 1) := + calc + a ≤ a * a := le_mul_self a + _ < a * a + 1 := (lt_add_one (a * a)) + _ ≤ (a + 1) * (a + 1) := by simp [add_mul_self_eq] + exact this hn + rcases this with ⟨x, hx⟩ + exact + ExistsUnique.intro x hx + (by + intro y hy + by_contra ne + wlog lt : x < y + · exact this a y hy x hx (Ne.symm ne) (Ne.lt_of_le ne <| by simpa using lt) + have : a < a := + calc + a < (x + 1) * (x + 1) := hx.2 + _ ≤ y * y := (mul_self_le_mul_self (by simp) (lt_iff_succ_le.mp lt)) + _ ≤ a := hy.1 + simp at this) + +/-- The sqrt construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def sqrt (a : V) : V := + Classical.chooseUnique (sqrt_exists_unique a) + +/-- The «term√ » construction in `FFL.FirstOrder.Arithmetic`. -/ +prefix:75 "√" => sqrt + +@[simp] +lemma sqrt_spec_le (a : V) : √a * √a ≤ a := + (Classical.chooseUnique_spec (sqrt_exists_unique a)).1 + +@[simp] +lemma sqrt_spec_lt (a : V) : a < (√a + 1) * (√a + 1) := + (Classical.chooseUnique_spec (sqrt_exists_unique a)).2 + +lemma sqrt_graph {a b : V} : b = √a ↔ b * b ≤ a ∧ a < (b + 1) * (b + 1) := + Classical.chooseUnique_eq_iff_right _ + +/-- The sqrt Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.sqrtDef : Σ₀.Semisentence 2 := + .mkSigma (“b a. b * b ≤ a ∧ a < (b + 1) * (b + 1)”) + +instance sqrt_defined : Σ₀-Function₁[V] sqrt via sqrtDef := + .mk fun v ↦ by simp [sqrt_graph, sqrtDef] + +instance sqrt_definable : Σ₀-Function₁[V] sqrt := + sqrt_defined.to_definable + +lemma eq_sqrt (x a : V) : x * x ≤ a ∧ a < (x + 1) * (x + 1) → x = √a := + Classical.choose_uniq (sqrt_exists_unique a) + +lemma sqrt_eq_of_le_of_lt {x a : V} (le : x * x ≤ a) (lt : a < (x + 1) * (x + 1)) : √a = x := + Eq.symm <| eq_sqrt x a ⟨le, lt⟩ + +lemma sqrt_eq_of_le_of_le {x a : V} (le : x * x ≤ a) (h : a ≤ x * x + 2 * x) : √a = x := + sqrt_eq_of_le_of_lt le <| by simpa [add_mul_self_eq] using le_iff_lt_succ.mp h + +@[simp] +lemma sq_sqrt_le (a : V) : (√a) ^ 2 ≤ a := by simp [sq] + +@[simp] +lemma sqrt_lt_sq (a : V) : a < (√a + 1) ^ 2 := by simp [sq] + +@[simp] +lemma sqrt_mul_self (a : V) : √(a * a) = a := + Eq.symm <| eq_sqrt a (a * a) <| by simpa using mul_self_lt_mul_self (by simp) (by simp) + +@[simp] +lemma sqrt_sq (a : V) : √(a ^ 2) = a := by simp [sq] + +@[simp] +lemma sqrt_zero : √(0 : V) = 0 := by simpa using sqrt_mul_self (0 : V) + +@[simp] +lemma sqrt_one : √(1 : V) = 1 := by simpa using sqrt_mul_self (1 : V) + +lemma sqrt_two : √(2 : V) = 1 := + Eq.symm <| eq_sqrt 1 2 (by simp [one_add_one_eq_two]) + +lemma sqrt_three : √(3 : V) = 1 := + Eq.symm <| + eq_sqrt 1 3 <| by simp [one_add_one_eq_two, two_mul_two_eq_four, ← three_add_one_eq_four] + +@[simp] +lemma sqrt_four : √(4 : V) = 2 := by simp [← two_mul_two_eq_four] + +@[simp] +lemma two_ne_square (a : V) : 2 ≠ a ^ 2 := by + intro h + rcases show a = √2 from by rw [h]; simp with rfl + simp [sqrt_two] at h + +@[simp] +lemma sqrt_le_add (a : V) : a ≤ √a * √a + 2 * √a := + le_iff_lt_succ.mpr (by have := sqrt_spec_lt a; rw [add_mul_self_eq] at this; simpa using this) + +@[simp] +lemma sqrt_le_self (a : V) : √a ≤ a := by + by_contra A + have : a < a := + calc + a ≤ a ^ 2 := le_sq a + _ < (√a) ^ 2 := by simpa [sq] using mul_self_lt_mul_self (by simp) (by simpa using A) + _ ≤ a := sq_sqrt_le a + simp_all + +instance : Bounded₁ ((√·) : V → V) := + ⟨#0, by intro v; simp⟩ + +lemma sqrt_lt_self_of_one_lt {a : V} (h : 1 < a) : √a < a := + by + by_contra A + have : a * a ≤ √a * √a := mul_self_le_mul_self (by simp) (by simpa using A) + have : a * a ≤ a := le_trans this (sqrt_spec_le a) + exact not_lt.mpr this (lt_mul_self h) + +lemma sqrt_le_of_le_sq {a b : V} : a ≤ b ^ 2 → √a ≤ b := + by + intro h; by_contra A + have : a < a := + calc + a ≤ b ^ 2 := h + _ < (√a) ^ 2 := (sq_lt_sq.mpr (by simpa using A)) + _ ≤ a := by simp + simp_all + +lemma sq_lt_of_lt_sqrt {a b : V} : a < √b → a ^ 2 < b := + by + intro h; by_contra A + exact not_le.mpr h (sqrt_le_of_le_sq <| show b ≤ a ^ 2 from by simpa using A) + +end sqrt + +/-! +### Pairing -/ + +section pair + + + +/-- The pair construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def pair (a b : V) : V := + if a < b then b * b + a else a * a + a + b + +/-- `!⟪x, y, z, ...⟫` notation for `Seq` -/ +syntax "⟪" term,* "⟫" : term + +macro_rules + | `(⟪$term:term, $terms:term,*⟫) => `(pair $term ⟪$terms,*⟫) + | `(⟪$term:term⟫) => `($term) + +/-- The pair Unexpander construction in `FFL.FirstOrder.Arithmetic`. -/ +@[app_unexpander pair] +meta def pairUnexpander : Lean.PrettyPrinter.Unexpander + | `($_ $term $term2) => `(⟪$term, $term2⟫) + | _ => throw () + + + +lemma pair_graph {a b c : V} : + c = ⟪a, b⟫ ↔ (a < b ∧ c = b * b + a) ∨ (b ≤ a ∧ c = a * a + a + b) := + by + simp [pair] + by_cases h : a < b + · simp [h, show ¬b ≤ a from by simpa using h] + · simp [h, show b ≤ a from by simpa using h] + +/-- The pair Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.pairDef : Σ₀.Semisentence 3 := + .mkSigma (“c a b. (a < b ∧ c = b * b + a) ∨ (b ≤ a ∧ c = a * a + a + b)”) + +instance pair_defined : Σ₀-Function₂[V] pair via pairDef := + .mk fun v ↦ by simp [pair_graph, pairDef] + +instance pair_definable : Σ₀-Function₂[V] pair := + pair_defined.to_definable + +instance : Bounded₂ (pair : V → V → V) := + ⟨‘x y. (y * y + x) + (x * x + x + y)’, by intro v; simp [pair]; split_ifs <;> try simp [*]⟩ + +/-- The unpair construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def unpair (a : V) : V × V := + if a - √a * √a < √a then (a - √a * √a, √a) else (√a, a - √a * √a - √a) + +/-- The pi₁ construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable abbrev pi₁ (a : V) : V := + (unpair a).1 + +/-- The pi₂ construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable abbrev pi₂ (a : V) : V := + (unpair a).2 + +/-- The termπ₁ construction in `FFL.FirstOrder.Arithmetic`. -/ +prefix:80 "π₁" => pi₁ + +/-- The termπ₂ construction in `FFL.FirstOrder.Arithmetic`. -/ +prefix:80 "π₂" => pi₂ + +@[simp, grind =] +lemma pair_unpair (a : V) : ⟪π₁ a, π₂ a⟫ = a := + by + simp only [pi₁, unpair, pi₂] + split_ifs with h + · simp [pair, h] + · suffices √a * √a + √a + (a - √a * √a - √a) = a by + simpa [pair, + not_lt.mpr (show a - √a * √a - √a ≤ √a by simp [add_comm (2 * √a), ← two_mul])] + have : √a ≤ a - √a * √a := by simpa using h + calc + √a * √a + √a + (a - √a * √a - √a) = √a * √a + (√a + (a - √a * √a - √a)) := by + simp [add_assoc] + _ = √a * √a + (a - √a * √a) := by simp [add_tsub_self_of_le this] + _ = a := add_tsub_self_of_le (by simp) + +@[simp, grind =] +lemma unpair_pair (a b : V) : unpair ⟪a, b⟫ = (a, b) := + by + simp only [pair]; split_ifs with h + · have : √(b * b + a) = b := + sqrt_eq_of_le_of_le (by simp) (by simpa using le_trans (le_of_lt h) (by simp)) + simp [unpair, this, show ¬b ≤ a from by simpa using h] + · have : √(a * a + (a + b)) = a := + sqrt_eq_of_le_of_le (by simp) (by simp [two_mul, show b ≤ a from by simpa using h]) + simp [unpair, this, add_assoc] + +@[simp, grind =] +lemma pi₁_pair (a b : V) : π₁⟪a, b⟫ = a := by simp [pi₁] + +@[simp, grind =] +lemma pi₂_pair (a b : V) : π₂⟪a, b⟫ = b := by simp [pi₂] + +/-- The pair Equiv construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def pairEquiv : V × V ≃ V := + ⟨Function.uncurry pair, unpair, fun ⟨a, b⟩ => unpair_pair a b, pair_unpair⟩ + +@[simp] +lemma pi₁_le_self (a : V) : π₁ a ≤ a := by simp [pi₁, unpair]; split_ifs <;> simp + +@[simp] +lemma pi₂_le_self (a : V) : π₂ a ≤ a := by simp [pi₂, unpair]; split_ifs <;> simp [add_assoc] + +@[simp] +lemma le_pair_left (a b : V) : a ≤ ⟪a, b⟫ := by simpa using pi₁_le_self ⟪a, b⟫ + +@[simp] +lemma le_pair_right (a b : V) : b ≤ ⟪a, b⟫ := by simpa using pi₂_le_self ⟪a, b⟫ + +@[simp] +lemma lt_pair_left_of_pos {a} (pos : 0 < a) (b : V) : a < ⟪a, b⟫ := + by + simp only [pair]; split_ifs + · simpa using pos_iff_ne_zero.mp <| pos_of_gt (by assumption) + · calc + a < a * a + a := lt_add_of_pos_left a (by simpa using (pos_iff_ne_zero.mp pos)) + _ ≤ a * a + a + b := by simp + +instance : Bounded₁ (pi₁ : V → V) := + ⟨#0, by intro v; simp⟩ + +instance : Bounded₁ (pi₂ : V → V) := + ⟨#0, by intro v; simp⟩ + +/-- The pi₁Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.pi₁Def : Σ₀.Semisentence 2 := + .mkSigma (“x p. ∃ y <⁺ p, !pairDef p x y”) + +/-- The pi₂Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.pi₂Def : Σ₀.Semisentence 2 := + .mkSigma (“y p. ∃ x <⁺ p, !pairDef p x y”) + +instance pi₁_defined : Σ₀-Function₁[V] pi₁ via pi₁Def := + .mk fun v ↦ by + simp only [Nat.reduceAdd, pi₁Def, Fin.isValue, Nat.succ_eq_add_one, + HierarchySymbol.Semiformula.val_mkSigma, eval_bexsLTSucc', Semiterm.val_bvar, + Semiformula.eval_substs, Matrix.comp₃, Matrix.cons_app_two, Matrix.cons_val_one, + Matrix.cons_val_zero, HierarchySymbol.Defined.iff, Fin.succ_zero_eq_one, + Fin.succ_one_eq_two, Matrix.cons_val_fin_one] + constructor + · rintro ⟨a, _, e⟩; simp [show v 1 = ⟪v 0, a⟫ from e] + · intro h; exact ⟨π₂ v 1, by simp, by simp [h]⟩ + +instance pi₁_definable : Σ₀-Function₁[V] pi₁ := + pi₁_defined.to_definable₀ + +instance pi₂_defined : Σ₀-Function₁ (pi₂ : V → V) via pi₂Def := + .mk fun v ↦ by + simp only [Nat.reduceAdd, pi₂Def, Fin.isValue, Nat.succ_eq_add_one, + HierarchySymbol.Semiformula.val_mkSigma, eval_bexsLTSucc', Semiterm.val_bvar, + Semiformula.eval_substs, Matrix.comp₃, Matrix.cons_app_two, Matrix.cons_val_zero, + Matrix.cons_val_one, HierarchySymbol.Defined.iff, Fin.succ_zero_eq_one, Fin.succ_one_eq_two, + Matrix.cons_val_fin_one] + constructor + · rintro ⟨a, _, e⟩; simp [show v 1 = ⟪a, v 0⟫ from e] + · intro h; exact ⟨π₁ v 1, by simp, by simp [h]⟩ + +instance pi₂_definable : Σ₀-Function₁ (pi₂ : V → V) := + pi₂_defined.to_definable₀ + +lemma pair_lt_pair_left {a₁ a₂ : V} (h : a₁ < a₂) (b) : ⟪a₁, b⟫ < ⟪a₂, b⟫ := + by + by_cases h₁ : a₁ < b + · simp only [pair, h₁, ↓reduceIte] + by_cases h₂ : a₂ < b + · simp [h₂, h] + · suffices b * b + a₁ < a₂ * a₂ + a₂ + b by simpa [pair, h₂, h] + calc + b * b + a₁ < b * b + b := by simpa using h₁ + _ ≤ a₂ * a₂ + a₂ := + (add_le_add (mul_le_mul (by simpa using h₂) (by simpa using h₂) (by simp) (by simp)) + (by simpa using h₂)) + _ ≤ a₂ * a₂ + a₂ + b := by simp + · simp [pair, h₁] + simpa [show ¬a₂ < b by simpa using le_trans (by simpa using h₁) (le_of_lt h)] using + _root_.add_lt_add (by simpa [← sq] using h) h + +lemma pair_le_pair_left {a₁ a₂ : V} (h : a₁ ≤ a₂) (b) : ⟪a₁, b⟫ ≤ ⟪a₂, b⟫ := + by + rcases h with (rfl | lt) + · simp + · exact le_of_lt (pair_lt_pair_left lt b) + +lemma pair_lt_pair_right (a : V) {b₁ b₂} (h : b₁ < b₂) : ⟪a, b₁⟫ < ⟪a, b₂⟫ := + by + by_cases h₁ : a < b₁ + · simpa [pair, h₁, lt_trans h₁ h, ← sq] using h + · by_cases h₂ : a < b₂ + · suffices a * a + a + b₁ < b₂ * b₂ + a by simpa [pair, h₁, h₂, h] + calc + a * a + a + b₁ < (a + 1) * (a + 1) + b₁ := by + simpa [add_mul_self_eq] using lt_succ_iff_le.mpr (by simp) + _ ≤ b₂ * b₂ + b₁ := by simpa [← sq, succ_le_iff_lt] using h₂ + _ ≤ b₂ * b₂ + a := by simpa using h₁ + · simp [pair, h₁, h₂, h] + +lemma pair_le_pair_right (a : V) {b₁ b₂} (h : b₁ ≤ b₂) : ⟪a, b₁⟫ ≤ ⟪a, b₂⟫ := + by + rcases h with (rfl | lt) + · simp + · exact le_of_lt (pair_lt_pair_right a lt) + +lemma pair_le_pair {a₁ a₂ b₁ b₂ : V} (ha : a₁ ≤ a₂) (hb : b₁ ≤ b₂) : ⟪a₁, b₁⟫ ≤ ⟪a₂, b₂⟫ := + calc + ⟪a₁, b₁⟫ ≤ ⟪a₂, b₁⟫ := pair_le_pair_left ha b₁ + _ ≤ ⟪a₂, b₂⟫ := pair_le_pair_right a₂ hb + +lemma pair_lt_pair {a₁ a₂ b₁ b₂ : V} (ha : a₁ < a₂) (hb : b₁ < b₂) : ⟪a₁, b₁⟫ < ⟪a₂, b₂⟫ := + calc + ⟪a₁, b₁⟫ < ⟪a₂, b₁⟫ := pair_lt_pair_left ha b₁ + _ < ⟪a₂, b₂⟫ := pair_lt_pair_right a₂ hb + +@[simp] +lemma pair_polybound (a b : V) : ⟪a, b⟫ ≤ (a + b + 1) ^ 2 := + by + by_cases h : a < b <;> simp [pair, h, sq, add_mul_self_eq, two_mul] + · simp [← add_assoc, add_right_comm _ a]; simp [add_right_comm _ (b * b)] + · simp [← add_assoc, add_right_comm _ b]; simp [add_right_comm _ a]; simp [add_assoc] + +@[simp, grind =>] +lemma pair_ext_iff {a₁ a₂ b₁ b₂ : V} : ⟪a₁, b₁⟫ = ⟪a₂, b₂⟫ ↔ a₁ = a₂ ∧ b₁ = b₂ := + ⟨fun e ↦ ⟨by simpa using congr_arg (π₁·) e, by simpa using congr_arg (π₂·) e⟩, by + rintro ⟨rfl, rfl⟩; simp⟩ + +section + +/-- The pair₃Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.pair₃Def : Σ₀.Semisentence 4 := + .mkSigma (“p a b c. ∃ bc <⁺ p, !pairDef p a bc ∧ !pairDef bc b c”) + +/-- The pair₄Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.pair₄Def : Σ₀.Semisentence 5 := + .mkSigma + (“p a b c d. + ∃ bcd <⁺ p, ∃ cd <⁺ bcd, !pairDef p a bcd ∧ !pairDef bcd b cd ∧ !pairDef cd c d”) + +/-- The pair₅Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.pair₅Def : Σ₀.Semisentence 6 := + .mkSigma + (“p a b c d e. + ∃ bcde <⁺ p, + ∃ cde <⁺ bcde, + ∃ de <⁺ cde, + !pairDef p a bcde ∧ !pairDef bcde b cde ∧ !pairDef cde c de ∧ !pairDef de d e”) + +/-- The pair₆Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.pair₆Def : Σ₀.Semisentence 7 := + .mkSigma (“p a b c d e f. ∃ bcdef <⁺ p, !pair₅Def bcdef b c d e f ∧ !pairDef p a bcdef”) + +theorem fegergreg (v : Fin 4 → ℕ) : v (0 : Fin (Nat.succ 1)).succ.succ = v 2 := by { + simp only [Nat.succ_eq_add_one, Nat.reduceAdd, Fin.isValue, Fin.succ_zero_eq_one, + Fin.succ_one_eq_two] +} + +theorem fin4 {n} : (2 : Fin (n + 3)).succ = 3 := + rfl + +@[simp] +theorem Fin.succ_zero_eq_one'' {n} : (0 : Fin (n + 1)).succ = 1 := + rfl + +@[simp] +theorem Fin.succ_two_eq_three {n} : (2 : Fin (n + 3)).succ = 3 := + rfl + +theorem ss (v : Fin 4 → ℕ) : v (Fin.succ (0 : Fin (Nat.succ 1))).succ = v 2 := by { + simp [Nat.succ_eq_add_one, Nat.reduceAdd, Fin.isValue, Fin.succ_zero_eq_one, + Fin.succ_one_eq_two] +} + +instance pair₃_defined : Σ₀-Function₃[V] (⟪·, ·, ·⟫) via pair₃Def := + .mk fun v ↦ by simp only [Nat.reduceAdd, pair₃Def, Fin.isValue, Nat.succ_eq_add_one, + HierarchySymbol.Semiformula.val_mkSigma, eval_bexsLTSucc', Semiterm.val_bvar, + LogicalConnective.HomClass.map_and, Semiformula.eval_substs, Matrix.comp₃, + Matrix.cons_val_one, Matrix.cons_app_two, Matrix.cons_val_zero, HierarchySymbol.Defined.iff, + Fin.succ_zero_eq_one, Fin.succ_one_eq_two, Matrix.cons_val_fin_one, Matrix.cons_app_three, + Matrix.cons_app_four, LogicalConnective.Prop.and_eq, exists_eq_right_right, + Fin.succ_two_eq_three, and_iff_right_iff_imp]; intro h; simp [h] + +instance pair₄_defined : Σ₀-Function₄[V] (⟪·, ·, ·, ·⟫) via pair₄Def := + .mk fun v ↦ by simp only [Nat.reduceAdd, pair₄Def, Fin.isValue, Nat.succ_eq_add_one, + HierarchySymbol.Semiformula.val_mkSigma, eval_bexsLTSucc', Semiterm.val_bvar, + Matrix.cons_val_zero, LogicalConnective.HomClass.map_and, Semiformula.eval_substs, + Matrix.comp₃, Matrix.cons_app_two, Matrix.cons_val_one, Matrix.cons_app_three, + HierarchySymbol.Defined.iff, Fin.succ_zero_eq_one, Fin.succ_one_eq_two, + Matrix.cons_val_fin_one, Matrix.cons_app_four, Matrix.cons_app_five, Matrix.cons_app_six, + LogicalConnective.Prop.and_eq, ↓existsAndEq, and_true, le_pair_right, true_and, + Fin.succ_two_eq_three, Fin.reduceSucc, and_iff_right_iff_imp]; intro e; simp [e] + +instance pair₅_defined : + Σ₀.DefinedFunction (fun v : Fin 5 → V ↦ (⟪v 0, v 1, v 2, v 3, v 4⟫)) pair₅Def := + .mk fun v ↦ by simp only [Nat.reduceAdd, pair₅Def, Fin.isValue, Nat.succ_eq_add_one, + HierarchySymbol.Semiformula.val_mkSigma, eval_bexsLTSucc', Semiterm.val_bvar, + Matrix.cons_val_zero, LogicalConnective.HomClass.map_and, Semiformula.eval_substs, + Matrix.comp₃, Matrix.cons_app_three, Matrix.cons_app_two, Matrix.cons_val_one, + Matrix.cons_app_four, HierarchySymbol.Defined.iff, Fin.succ_zero_eq_one, Fin.succ_one_eq_two, + Matrix.cons_val_fin_one, Matrix.cons_app_five, Matrix.cons_app_six, Matrix.cons_app_seven, + Matrix.cons_app_eight, LogicalConnective.Prop.and_eq, ↓existsAndEq, and_true, le_pair_right, + true_and, Fin.succ_two_eq_three, Fin.reduceSucc, and_iff_right_iff_imp]; intro e; simp [e] + +instance pair₆_defined : + Σ₀.DefinedFunction (fun v : Fin 6 → V ↦ (⟪v 0, v 1, v 2, v 3, v 4, v 5⟫)) pair₆Def := + .mk fun v ↦ by simp only [Nat.reduceAdd, pair₆Def, Fin.isValue, Nat.succ_eq_add_one, + HierarchySymbol.Semiformula.val_mkSigma, eval_bexsLTSucc', Semiterm.val_bvar, + LogicalConnective.HomClass.map_and, Semiformula.eval_substs, HierarchySymbol.Defined.iff, + Function.comp_apply, Matrix.cons_val_zero, Fin.succ_zero_eq_one, Matrix.cons_val_one, + Matrix.cons_app_three, Fin.succ_one_eq_two, Matrix.cons_app_two, Matrix.cons_app_four, + Fin.succ_two_eq_three, Matrix.cons_app_five, Fin.reduceSucc, Matrix.cons_app_six, + Matrix.cons_val_fin_one, Matrix.cons_app_seven, Matrix.comp₃, LogicalConnective.Prop.and_eq, + ↓existsAndEq, true_and, and_iff_right_iff_imp]; intro e; simp [e] + +end + +/-- The npair construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def npair : {n : ℕ} → (v : Fin n → V) → V + | 0, _ => 0 + | _ + 1, v => ⟪v 0, npair (v ·.succ)⟫ + +@[simp] +lemma npair_zero (v : Fin 0 → V) : npair v = 0 := by simp [npair] + +lemma npair_succ (x) (v : Fin n → V) : npair (x :> v) = ⟪x, npair v⟫ := by simp [npair] + +/-- The un Npair construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def unNpair : {n : ℕ} → Fin n → V → V + | 0, i, _ => i.elim0 + | _ + 1, i, x => Fin.cases (π₁ x) (fun i ↦ unNpair i (π₂ x)) i + +@[simp] +lemma unNpair_npair {n} (i : Fin n) (v : Fin n → V) : unNpair i (npair v) = v i := by + induction n with + | zero => simpa [npair, unNpair] using i.elim0 + | succ n ih => cases i using Fin.cases <;> simp [npair, unNpair, *] + +section + +/-- The un Npair Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.unNpairDef : + {n : ℕ} → (i : Fin n) → Σ₀.Semisentence 2 + | 0, i => i.elim0 + | n + 1, i => + Fin.cases pi₁Def (fun i ↦ .mkSigma (“z v. ∃ r <⁺ v, !pi₂Def r v ∧ !(unNpairDef i)z r”)) i + +instance unNpair_defined {n} (i : Fin n) : Σ₀-Function₁[V] unNpair i via unNpairDef i := by + induction n with + | zero => exact i.elim0 + | succ n ih => + refine ⟨?_⟩ + intro v + refine Fin.cases ?_ (fun i => ?_) i + · simp [unNpairDef, unNpair] + · simp [unNpairDef, unNpair, (ih i).iff] + +@[definability] +instance unNpair_definable {n} (i : Fin n) (Γ) : Γ-Function₁ (unNpair i : V → V) := + (unNpair_defined i).to_definable₀ + +end + +@[simp] +lemma nat_cast_pair (n m : ℕ) : (⟪n, m⟫ : ℕ) = ⟪(↑n : V), (↑m : V)⟫ := by simp [pair] + +lemma nat_pair_eq (m n : ℕ) : ⟪n, m⟫ = Nat.pair n m := by simp [pair, Nat.pair] + +lemma coe_pair_eq_pair_coe (n m : ℕ) : (Nat.pair n m : V) = ⟪(↑n : V), (↑m : V)⟫ := by + simp [← nat_pair_eq, nat_cast_pair] + +end pair + +end IOpen + +/-! +### Polynomial induction -/ + +@[elab_as_elim] +lemma polynomial_induction [V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] (Γ m) [V↓[ℒₒᵣ] ⊧* 𝐈𝐍𝐃 Γ m] {P : V → Prop} + (hP : Γ-[m]-Predicate P) (zero : P 0) (even : ∀ x > 0, P x → P (2 * x)) + (odd : ∀ x, P x → P (2 * x + 1)) : ∀ x, P x := + by + have : V↓[ℒₒᵣ] ⊧* 𝐈𝐍𝐃 Γ m := inferInstance + have : V↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧 := models_of_subtheory this + intro x; induction x using InductionOnHierarchy.order_induction + · exact Γ + · exact m + · exact hP + case inst => exact inferInstance + case ind x IH => + rcases Arithmetic.zero_le x with (rfl | pos) + · exact zero + · have : x / 2 < x := div_lt_of_pos_of_one_lt pos one_lt_two + rcases even_or_odd' x with (hx | hx) + · simpa [← hx] using + even (x / 2) + (by by_contra A; simp at A; simp [show x = 0 from by simpa [A] using hx] at pos) + (IH (x / 2) this) + · simpa [← hx] using odd (x / 2) (IH (x / 2) this) + +@[elab_as_elim] +lemma sigma0_polynomial_induction [V↓[ℒₒᵣ] ⊧* 𝐈Σ₀] {P : V → Prop} (hP : Σ₀-Predicate P) + (zero : P 0) (even : ∀ x > 0, P x → P (2 * x)) (odd : ∀ x, P x → P (2 * x + 1)) : + ∀ x, P x := + polynomial_induction Σ 0 (P := P) hP zero even odd + +@[elab_as_elim] +lemma sigma1_polynomial_induction [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] {P : V → Prop} (hP : Σ₁-Predicate P) + (zero : P 0) (even : ∀ x > 0, P x → P (2 * x)) (odd : ∀ x, P x → P (2 * x + 1)) : + ∀ x, P x := + polynomial_induction Σ 1 (P := P) hP zero even odd + +@[elab_as_elim] +lemma pi1_polynomial_induction [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] {P : V → Prop} (hP : Π₁-Predicate P) + (zero : P 0) (even : ∀ x > 0, P x → P (2 * x)) (odd : ∀ x, P x → P (2 * x + 1)) : + ∀ x, P x := + polynomial_induction Π 1 (P := P) hP zero even odd + +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/ISigma1/Prenex.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/ISigma1/Prenex.lean new file mode 100644 index 000000000..f3788e723 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/ISigma1/Prenex.lean @@ -0,0 +1,62 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Prenex + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# Prenex normal form theorem over $\mathsf{I\Sigma_1}$ + +Every `Hierarchy Σ 1` formula is `𝐈Σ₁`-provably equivalent to a formula of the form `∃¹ θ` +with `θ` in `Hierarchy Σ 0`, and dually for `Hierarchy Π 1` and `∀¹ θ`. +-/ + +@[expose] public section + +open FFL + +open FFL.FirstOrder + +namespace FFL +namespace FirstOrder +namespace Arithmetic +namespace ISigma1 + +variable {n : ℕ} {φ : ArithmeticSemisentence n} {σ : ArithmeticSentence} + +lemma hasPrenex (h : Hierarchy Σ 1 φ) : ∃ φ' : Prenex Σ 1 Empty n, 𝐈Σ₁ ⊢ ∀¹* (φ ⇔ₗ φ'.val) := + exists_prenex_of_hierarchy 𝐈Σ₁ h + +lemma exists_matrix_provable (h : Hierarchy Σ 1 φ) : + ∃ θ : Σ₀.Semisentence (n + 1), 𝐈Σ₁ ⊢ ∀¹* (φ ⇔ₗ ∃¹ θ.val) := by + obtain ⟨φ', hφ'⟩ := hasPrenex h; exact ⟨φ'.sigmaInv.matrix, Prenex.provable_iff_sigmaInv hφ'⟩ + +lemma exists_matrix_provable_pi (h : Hierarchy Π 1 φ) : + ∃ θ : Σ₀.Semisentence (n + 1), 𝐈Σ₁ ⊢ ∀¹* (φ ⇔ₗ ∀¹ θ.val) := + by + obtain ⟨φ', hφ'⟩ := exists_prenex_of_hierarchy 𝐈Σ₁ h + exact ⟨φ'.piInv.matrix, Prenex.provable_iff_piInv hφ'⟩ + +lemma exists_matrix_provable_of_sentence (h : Hierarchy Σ 1 σ) : + ∃ θ : Σ₀.Semisentence 1, 𝐈Σ₁ ⊢ σ ⇔ₗ ∃¹ θ.val := + exists_matrix_provable h + +end ISigma1 +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Induction.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Induction.lean new file mode 100644 index 000000000..f761dbe6e --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Induction.lean @@ -0,0 +1,326 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.HFS + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +/-! +# Various induction-related principles in $\mathsf{I}\Sigma_n$ +-/ + +namespace FFL +namespace FirstOrder +namespace Arithmetic + +variable {V : Type*} [ORingStructure V] + +section ISigma1 + +variable [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +@[elab_as_elim] +lemma sigma1_pos_succ_induction {P : V → Prop} (hP : Σ₁-Predicate P) (zero : P 0) (one : P 1) + (succ : ∀ x, P (x + 1) → P (x + 2)) : ∀ x, P x := + by + have : ∀ x, P (x + 1) := by + intro x + induction x using ISigma1.sigma1_succ_induction + · definability + case zero => simpa + case succ x ih => simpa [add_assoc, one_add_one_eq_two] using succ x ih + intro x + rcases zero_or_succ x with (rfl | ⟨x, rfl⟩) + · exact zero + · exact this x + +open HierarchySymbol + +theorem bounded_all_sigma1_order_induction {f : V → V → V} (hf : Σ₁-Function₂ f) + {P : V → V → Prop} (hP : Σ₁-Relation P) + (ind : ∀ x y, (∀ x' < x, ∀ y' ≤ f x y, P x' y') → P x y) : ∀ x y, P x y := + by + have maxf : ∀ x y, ∃ m, ∀ x' ≤ x, ∀ y' ≤ y, f x' y' ≤ m := + by + intro x y; + rcases sigma₁_replacement₂ hf (under (x + 1)) (under (y + 1)) |>.exists with ⟨m, hm⟩ + exact + ⟨m, fun x' hx' y' hy' ↦ + le_of_lt <| + lt_of_mem <| + hm (f x' y') |>.mpr + ⟨x', by simpa [lt_succ_iff_le] using! hx', y', by + simpa [lt_succ_iff_le] using! hy', rfl⟩⟩ + intro x y + have : + ∀ k ≤ x, + ∃ W, + Seq W ∧ + k + 1 = lh W ∧ + ⟪0, y⟫ ∈ W ∧ + ∀ l < k, + ∀ m < W, + ∀ m' < W, + ⟪l, m⟫ ∈ W → ⟪l + 1, m'⟫ ∈ W → ∀ x' ≤ x - l, ∀ y' ≤ m, f x' y' ≤ m' := + by + intro k hk + induction k using ISigma1.sigma1_succ_induction + · apply Definable.imp (Definable.comp₂ (by definability) (by definability)) + apply Definable.exs + apply Definable.and (Definable.comp₁ (by definability)) + apply + Definable.and + (Definable.comp₂ (DefinableFunction₂.comp (.var _) (.const _)) + (DefinableFunction₁.comp (.var _))) + apply Definable.and (Definable.comp₂ (.var 0) (by definability)) + apply Definable.ball_lt (.var _) + apply Definable.ball_lt (.var _) + apply Definable.ball_lt (.var _) + apply Definable.imp (Definable.comp₂ (.var _) (DefinableFunction₂.comp (.var _) (.var _))) + apply + Definable.imp + (Definable.comp₂ (.var _) + (DefinableFunction₂.comp (DefinableFunction₂.comp (.var _) (.const _)) (.var _))) + apply + Definable.ball_le + (Definable.comp₂ (.var _) (DefinableFunction₂.comp (.const _) (.var _))) + apply Definable.ball_le (.var _) + apply Definable.comp₂ (DefinableFunction₂.comp (.var _) (.var _)) (.var _) + case zero => exact ⟨!⟦y⟧, by simp⟩ + case succ k + ih => + rcases ih (le_trans le_self_add hk) with ⟨W, SW, hkW, hW₀, hWₛ⟩ + let m₀ := SW.nth (show k < lh W by simp [← hkW]) + have : ∃ m₁, ∀ x' ≤ x - k, ∀ y' ≤ m₀, f x' y' ≤ m₁ := maxf (x - k) m₀ + rcases this with ⟨m₁, hm₁⟩ + exact + ⟨W ⁀' m₁, SW.seqCons m₁, by simp [SW, hkW], Seq.subset_seqCons _ _ hW₀, + by + intro l hl m _ m' _ hm hm' x' hx' y' hy' + rcases show l ≤ k from lt_succ_iff_le.mp hl with (rfl | hl) + · have hmm₀ : m = m₀ := + SW.isMapping.uniq (by simpa [mem_seqCons_iff, ← hkW] using hm) (by simp [m₀]) + have hm'm₁ : m' = m₁ := by simpa [SW, hkW, mem_seqCons_iff] using hm' + simpa [hm'm₁] using hm₁ x' hx' y' (by simp [← hmm₀, hy']) + · have Hm : ⟪l, m⟫ ∈ W := Seq.mem_seqCons_iff_of_lt (by simpa [← hkW]) |>.mp hm + have Hm' : ⟪l + 1, m'⟫ ∈ W := Seq.mem_seqCons_iff_of_lt (by simpa [← hkW]) |>.mp hm' + exact hWₛ l hl m (lt_of_mem_rng Hm) m' (lt_of_mem_rng Hm') Hm Hm' x' hx' y' hy'⟩ + rcases this x (by rfl) with ⟨W, SW, hxW, hW₀, hWₛ⟩ + have : ∀ i ≤ x, ∀ m < W, ⟪x - i, m⟫ ∈ W → ∀ x' ≤ i, ∀ y' ≤ m, P x' y' := + by + intro i + induction i using ISigma1.sigma1_succ_induction + · apply Definable.imp (Definable.comp₂ (.var _) (.const _)) + apply Definable.ball_lt (.const _) + apply + Definable.imp + (Definable.comp₂ (.const _) + (DefinableFunction₂.comp (DefinableFunction₂.comp (.const _) (.var _)) (.var _))) + apply Definable.ball_le (.var _) + apply Definable.ball_le (.var _) + apply Definable.comp₂ (.var _) (.var _) + case zero => + intro _ _ _ _ _ h y' _ + rcases nonpos_iff_eq_zero.mp h + exact ind 0 y' (by simp) + case succ i ih' => + intro hi m _ hm x' hx' y' hy' + have ih : ∀ m < W, ⟪x - i, m⟫ ∈ W → ∀ x' ≤ i, ∀ y' ≤ m, P x' y' := + ih' (le_trans le_self_add hi) + refine ind x' y' ?_ + intro x'' hx'' y'' hy'' + let m₁ := SW.nth (show x - i < lh W by simp [← hxW, lt_succ_iff_le]) + have : f x' y' ≤ m₁ := + hWₛ (x - (i + 1)) (tsub_lt_iff_left hi |>.mpr (by simp)) m (lt_of_mem_rng hm) m₁ + (by simp [m₁]) hm + (by + rw [← Arithmetic.sub_sub, + sub_add_self_of_le (show 1 ≤ x - i from le_tsub_of_add_le_left hi)]; + simp [m₁]) + x' (by simp [tsub_tsub_cancel_of_le hi, hx']) y' hy' + exact + ih m₁ (by simp [m₁]) (by simp [m₁]) x'' (lt_succ_iff_le.mp (lt_of_lt_of_le hx'' hx')) + y'' (le_trans hy'' this) + exact this x (by rfl) y (lt_of_mem_rng hW₀) (by simpa using hW₀) x (by rfl) y (by rfl) + +lemma bounded_all_sigma1_order_induction' {f : V → V} (hf : Σ₁-Function₁ f) {P : V → V → Prop} + (hP : Σ₁-Relation P) (ind : ∀ x y, (∀ x' < x, ∀ y' ≤ f y, P x' y') → P x y) : + ∀ x y, P x y := + have : Σ₁-Function₂ (fun _ ↦ f) := DefinableFunction₁.comp (by simp) + bounded_all_sigma1_order_induction this hP ind + +lemma bounded_all_sigma1_order_induction₂ {fy fz : V → V → V → V} (hfy : Σ₁-Function₃ fy) + (hfz : Σ₁-Function₃ fz) {P : V → V → V → Prop} (hP : Σ₁-Relation₃ P) + (ind : ∀ x y z, (∀ x' < x, ∀ y' ≤ fy x y z, ∀ z' ≤ fz x y z, P x' y' z') → P x y z) : + ∀ x y z, P x y z := + by + let Q : V → V → Prop := fun x w ↦ P x (π₁ w) (π₂ w) + have hQ : Σ₁-Relation Q := by + apply + Definable.comp₃ (.var _) (DefinableFunction₁.comp (.var _)) + (DefinableFunction₁.comp (.var _)) + let f : V → V → V := fun x w ↦ ⟪fy x (π₁ w) (π₂ w), fz x (π₁ w) (π₂ w)⟫ + have hf : Σ₁-Function₂ f := by + simp only [f] + apply DefinableFunction₂.comp + · apply DefinableFunction₃.comp (.var _) + · apply DefinableFunction₁.comp (.var _) + · apply DefinableFunction₁.comp (.var _) + · apply DefinableFunction₃.comp (.var _) + · apply DefinableFunction₁.comp (.var _) + · apply DefinableFunction₁.comp (.var _) + intro x y z + simpa [Q] using + bounded_all_sigma1_order_induction hf hQ + (fun x w ih ↦ + ind x (π₁ w) (π₂ w) + (fun x' hx' y' hy' z' hz' ↦ by + simpa [Q] using ih x' hx' ⟪y', z'⟫ (pair_le_pair hy' hz'))) + x ⟪y, z⟫ + +lemma bounded_all_sigma1_order_induction₃ {fy fz fw : V → V → V → V → V} (hfy : Σ₁-Function₄ fy) + (hfz : Σ₁-Function₄ fz) (hfw : Σ₁-Function₄ fw) {P : V → V → V → V → Prop} + (hP : Σ₁-Relation₄ P) + (ind : + ∀ x y z w, + (∀ x' < x, ∀ y' ≤ fy x y z w, ∀ z' ≤ fz x y z w, ∀ w' ≤ fw x y z w, P x' y' z' w') → + P x y z w) : + ∀ x y z w, P x y z w := + by + let Q : V → V → Prop := fun x v ↦ P x (π₁ v) (π₁(π₂ v)) (π₂(π₂ v)) + have hQ : Σ₁-Relation Q := by + apply + Definable.comp₄ (.var _) (DefinableFunction₁.comp <| .var _) + (DefinableFunction₁.comp <| DefinableFunction₁.comp <| .var _) + (DefinableFunction₁.comp <| DefinableFunction₁.comp <| .var _) + let f : V → V → V := fun x v ↦ + ⟪fy x (π₁ v) (π₁(π₂ v)) (π₂(π₂ v)), fz x (π₁ v) (π₁(π₂ v)) (π₂(π₂ v)), + fw x (π₁ v) (π₁(π₂ v)) (π₂(π₂ v))⟫ + have hf : Σ₁-Function₂ f := by + simp only [f] + apply DefinableFunction₂.comp + · apply + DefinableFunction₄.comp (.var _) (DefinableFunction₁.comp <| .var _) + (DefinableFunction₁.comp <| DefinableFunction₁.comp <| .var _) + (DefinableFunction₁.comp <| DefinableFunction₁.comp <| .var _) + · apply DefinableFunction₂.comp + · apply + DefinableFunction₄.comp (.var _) (DefinableFunction₁.comp <| .var _) + (DefinableFunction₁.comp <| DefinableFunction₁.comp <| .var _) + (DefinableFunction₁.comp <| DefinableFunction₁.comp <| .var _) + · apply + DefinableFunction₄.comp (.var _) (DefinableFunction₁.comp <| .var _) + (DefinableFunction₁.comp <| DefinableFunction₁.comp <| .var _) + (DefinableFunction₁.comp <| DefinableFunction₁.comp <| .var _) + intro x y z w + have := + bounded_all_sigma1_order_induction hf hQ + (fun x v ih ↦ + ind x (π₁ v) (π₁(π₂ v)) (π₂(π₂ v)) + (fun x' hx' y' hy' z' hz' w' hw' ↦ by + simpa [Q] using ih x' hx' ⟪y', z', w'⟫ (pair_le_pair hy' <| pair_le_pair hz' hw'))) + x ⟪y, z, w⟫ + simpa [Q] using this + +lemma measured_bounded_sigma1_order_induction {m : V → V} {f : V → V} {P : V → Prop} + (hm : Σ₁-Function₁ m) (hf : Σ₁-Function₁ f) (hP : Σ₁-Predicate P) + (H : ∀ a, (∀ b ≤ f a, m b < m a → P b) → P a) : ∀ a, P a := + by + let Q : V → V → Prop := fun k x ↦ m x ≤ k → P x + have hQ : Σ₁-Relation Q := by unfold Q; definability + have : ∀ x y, Q x y := + bounded_all_sigma1_order_induction' hf hQ fun k a ih hm ↦ + H a fun b hb hba ↦ ih (m b) (lt_of_le_of_lt' hm hba) b hb (by rfl) + intro a + exact this (m a) a (by rfl) + +end ISigma1 + +section Induction + +variable (m : ℕ) [Fact (1 ≤ m)] [V↓[ℒₒᵣ] ⊧* 𝐈𝐍𝐃 Σ m] + +lemma sigma_or_pi_succ_induction {P Q : V → Prop} (hP : Σ-[m]-Predicate P) + (hQ : Π-[m]-Predicate Q) (zero : P 0 ∨ Q 0) + (succ : ∀ x, P x ∨ Q x → P (x + 1) ∨ Q (x + 1)) : ∀ x, P x ∨ Q x := + by + have : V↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := modISigmaOfLe (show 1 ≤ m from Fact.out) + intro a + have : ∃ p < Exp.exp (a + 1), ∀ x ≤ a, x ∈ p ↔ P x := by + simpa [lt_succ_iff_le] using finset_comprehension hP (a + 1) + rcases this with ⟨p, _, hp⟩ + have : ∃ q < Exp.exp (a + 1), ∀ x ≤ a, x ∈ q ↔ Q x := by + simpa [lt_succ_iff_le] using finset_comprehension hQ (a + 1) + rcases this with ⟨q, _, hq⟩ + have : ∀ x ≤ a, x ∈ p ∨ x ∈ q := by + intro x hx + induction x using ISigma1.sigma1_succ_induction + · clear hp hq zero succ + definability + case zero => simpa [hp, hq] using zero + case succ x ih => + have hx' : x ≤ a := le_trans le_self_add hx + have : P x ∨ Q x := by simpa [hp x hx', hq x hx'] using ih hx' + simpa [hp (x + 1) hx, hq (x + 1) hx] using succ x this + have := this a (by rfl) + simpa [hp, hq] using this + +lemma sigma_or_pi_order_induction {P Q : V → Prop} (hP : Σ-[m]-Predicate P) + (hQ : Π-[m]-Predicate Q) (ind : ∀ x, (∀ y < x, P y ∨ Q y) → P x ∨ Q x) : ∀ x, P x ∨ Q x := + by + have : V↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := modISigmaOfLe (show 1 ≤ m from Fact.out) + intro a + have : ∃ p < Exp.exp (a + 1), ∀ x ≤ a, x ∈ p ↔ P x := by + simpa [lt_succ_iff_le] using finset_comprehension hP (a + 1) + rcases this with ⟨p, _, hp⟩ + have : ∃ q < Exp.exp (a + 1), ∀ x ≤ a, x ∈ q ↔ Q x := by + simpa [lt_succ_iff_le] using finset_comprehension hQ (a + 1) + rcases this with ⟨q, _, hq⟩ + have : ∀ x ≤ a, x ∈ p ∨ x ∈ q := by + intro x hx + induction x using ISigma1.sigma1_order_induction + · clear hp hq ind + apply FFL.FirstOrder.Arithmetic.HierarchySymbol.Definable.imp + · simp_all only [SigmaPiDelta.alt_sigma, Fin.isValue] + apply FFL.FirstOrder.Arithmetic.HierarchySymbol.Definable.comp₂ + · simp [Fin.isValue, HierarchySymbol.DefinableFunction.var] + · simp [HierarchySymbol.DefinableFunction.const] + · apply FFL.FirstOrder.Arithmetic.HierarchySymbol.Definable.or + · apply FFL.FirstOrder.Arithmetic.HierarchySymbol.Definable.comp₂ + · simp + · simp + · apply FFL.FirstOrder.Arithmetic.HierarchySymbol.Definable.comp₂ + · simp + · simp + case ind z + ih => + have : P z ∨ Q z := + ind z + (fun y hy ↦ by + have hya : y ≤ a := le_trans (le_of_lt hy) hx + have : y ∈ p ∨ y ∈ q := ih y hy hya + simpa [hp, hq, hya] using this) + simpa [hp, hq, hx] using this + simpa [hp, hq] using this a (by rfl) + +end Induction + +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/LE.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/LE.lean new file mode 100644 index 000000000..f74737d23 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/LE.lean @@ -0,0 +1,66 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.LK.Completeness + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace FFL + +namespace FirstOrder + +variable {L : Language.{u}} [Semiformula.Operator.Eq L] [Semiformula.Operator.LT L] + +open Semiformula + +/-- The le construction in `FFL.FirstOrder.LT`. -/ +def LT.le : Operator L 2 := + Semiformula.Operator.Eq.eq.or Semiformula.Operator.LT.lt + +lemma le_eq (t₁ t₂ : Semiterm L μ n) : + LT.le.operator ![t₁, t₂] = (“!!t₁ = !!t₂ ∨ !!t₁ < !!t₂”) := by + simp [Operator.operator, Operator.or, LT.le, ← TransitiveRewriting.comp_app] + +namespace Order + +open _root_.Order + +variable {T : Theory L} [𝐄𝐐 L ≼ T] + +omit [𝐄𝐐 L ≼ T] in +theorem leIffEqOrLt : T ⊢ (“∀ x y, x ≤ y ↔ x = y ∨ x < y”) := + Theory.Proof.small_complete <| + consequence_iff.mpr fun _ ↦ by simp [models_iff, Semiformula.Operator.LE.def_of_Eq_of_LT] + +lemma complete (φ : Sentence L) + (H : + ∀ (M : Type (max u w)) [Nonempty M] [LT M] [Tarski.Structure L M] + [Tarski.Structure.Eq L M] [Tarski.Structure.LT L M] [M↓[L] ⊧* T], M↓[L] ⊧ φ) : + T ⊢ φ := + Theory.Proof.complete <| + consequence_iff_eq.mpr fun M _ _ _ hT ↦ + letI : (Tarski.Structure.Model L M)↓[L] ⊧* T := + Tarski.Structure.ElementaryEquiv.modelsTheory.mp hT + Tarski.Structure.ElementaryEquiv.models.mpr (H (Tarski.Structure.Model L M)) + +end Order + +end FirstOrder + +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/PeanoMinus/Basic.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/PeanoMinus/Basic.lean new file mode 100644 index 000000000..2fa4bba12 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/PeanoMinus/Basic.lean @@ -0,0 +1,748 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Q.Basic + +/-! Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section +/-! +# Theory $\mathsf{PA^-}$ + +-/ + +namespace FFL +namespace FirstOrder +namespace Arithmetic + +namespace PeanoMinus +namespace Axiom + +/-- The add Zero construction in `FFL.FirstOrder.Arithmetic.PeanoMinus.Axiom`. -/ +abbrev addZero : ArithmeticSentence := + “∀ x, x + 0 = x” +/-- The add Assoc construction in `FFL.FirstOrder.Arithmetic.PeanoMinus.Axiom`. -/ +abbrev addAssoc : ArithmeticSentence := + “∀ x y z, (x + y) + z = x + (y + z)” +/-- The add Comm construction in `FFL.FirstOrder.Arithmetic.PeanoMinus.Axiom`. -/ +abbrev addComm : ArithmeticSentence := + “∀ x y, x + y = y + x” +/-- The add Eq Of Lt construction in `FFL.FirstOrder.Arithmetic.PeanoMinus.Axiom`. -/ +abbrev addEqOfLt : ArithmeticSentence := + “∀ x y, x < y → ∃ z, x + z = y” +/-- The zero Le construction in `FFL.FirstOrder.Arithmetic.PeanoMinus.Axiom`. -/ +abbrev zeroLe : ArithmeticSentence := + “∀ x, 0 ≤ x” +/-- The zero Lt One construction in `FFL.FirstOrder.Arithmetic.PeanoMinus.Axiom`. -/ +abbrev zeroLtOne : ArithmeticSentence := + “0 < 1” +/-- The one Le Of Zero Lt construction in `FFL.FirstOrder.Arithmetic.PeanoMinus.Axiom`. -/ +abbrev oneLeOfZeroLt : ArithmeticSentence := + “∀ x, 0 < x → 1 ≤ x” +/-- The add Lt Add construction in `FFL.FirstOrder.Arithmetic.PeanoMinus.Axiom`. -/ +abbrev addLtAdd : ArithmeticSentence := + “∀ x y z, x < y → x + z < y + z” +/-- The mul Zero construction in `FFL.FirstOrder.Arithmetic.PeanoMinus.Axiom`. -/ +abbrev mulZero : ArithmeticSentence := + “∀ x, x * 0 = 0” +/-- The mul One construction in `FFL.FirstOrder.Arithmetic.PeanoMinus.Axiom`. -/ +abbrev mulOne : ArithmeticSentence := + “∀ x, x * 1 = x” +/-- The mul Assoc construction in `FFL.FirstOrder.Arithmetic.PeanoMinus.Axiom`. -/ +abbrev mulAssoc : ArithmeticSentence := + “∀ x y z, (x * y) * z = x * (y * z)” +/-- The mul Comm construction in `FFL.FirstOrder.Arithmetic.PeanoMinus.Axiom`. -/ +abbrev mulComm : ArithmeticSentence := + “∀ x y, x * y = y * x” +/-- The mul Lt Mul construction in `FFL.FirstOrder.Arithmetic.PeanoMinus.Axiom`. -/ +abbrev mulLtMul : ArithmeticSentence := + “∀ x y z, x < y ∧ 0 < z → x * z < y * z” +/-- The distr construction in `FFL.FirstOrder.Arithmetic.PeanoMinus.Axiom`. -/ +abbrev distr : ArithmeticSentence := + “∀ x y z, x * (y + z) = x * y + x * z” +/-- The lt Irrefl construction in `FFL.FirstOrder.Arithmetic.PeanoMinus.Axiom`. -/ +abbrev ltIrrefl : ArithmeticSentence := + “∀ x, x ≮ x” +/-- The lt Trans construction in `FFL.FirstOrder.Arithmetic.PeanoMinus.Axiom`. -/ +abbrev ltTrans : ArithmeticSentence := + “∀ x y z, x < y ∧ y < z → x < z” +/-- The lt Tri construction in `FFL.FirstOrder.Arithmetic.PeanoMinus.Axiom`. -/ +abbrev ltTri : ArithmeticSentence := + “∀ x y, x < y ∨ x = y ∨ x > y” + +end Axiom +end PeanoMinus + +/-- Data and laws for 𝐏𝐀⁻ in `𝐏𝐀⁻`. -/ +inductive PeanoMinus : ArithmeticTheory + | equal : ∀ φ ∈ 𝐄𝐐 ℒₒᵣ, PeanoMinus φ + | addZero : PeanoMinus PeanoMinus.Axiom.addZero + | addAssoc : PeanoMinus PeanoMinus.Axiom.addAssoc + | addComm : PeanoMinus PeanoMinus.Axiom.addComm + | addEqOfLt : PeanoMinus PeanoMinus.Axiom.addEqOfLt + | zeroLe : PeanoMinus PeanoMinus.Axiom.zeroLe + | zeroLtOne : PeanoMinus PeanoMinus.Axiom.zeroLtOne + | oneLeOfZeroLt : PeanoMinus PeanoMinus.Axiom.oneLeOfZeroLt + | addLtAdd : PeanoMinus PeanoMinus.Axiom.addLtAdd + | mulZero : PeanoMinus PeanoMinus.Axiom.mulZero + | mulOne : PeanoMinus PeanoMinus.Axiom.mulOne + | mulAssoc : PeanoMinus PeanoMinus.Axiom.mulAssoc + | mulComm : PeanoMinus PeanoMinus.Axiom.mulComm + | mulLtMul : PeanoMinus PeanoMinus.Axiom.mulLtMul + | distr : PeanoMinus PeanoMinus.Axiom.distr + | ltIrrefl : PeanoMinus PeanoMinus.Axiom.ltIrrefl + | ltTrans : PeanoMinus PeanoMinus.Axiom.ltTrans + | ltTri : PeanoMinus PeanoMinus.Axiom.ltTri + +/-- The «term𝐏𝐀⁻» construction in `FFL.FirstOrder.Arithmetic`. -/ +notation "𝐏𝐀⁻" => PeanoMinus + +namespace PeanoMinus + +open FirstOrder Arithmetic Language + +@[simp] +lemma finite : Set.Finite 𝐏𝐀⁻ := + by + have : + 𝐏𝐀⁻ = + 𝐄𝐐 ℒₒᵣ ∪ + { Axiom.addZero, Axiom.addAssoc, Axiom.addComm, Axiom.addEqOfLt, Axiom.zeroLe, + Axiom.zeroLtOne, Axiom.oneLeOfZeroLt, Axiom.addLtAdd, Axiom.mulZero, Axiom.mulOne, + Axiom.mulAssoc, Axiom.mulComm, Axiom.mulLtMul, Axiom.distr, Axiom.ltIrrefl, + Axiom.ltTrans, Axiom.ltTri } := + by + ext φ; constructor + · rintro ⟨⟩ + case equal => left; assumption + case addZero => tauto + case addAssoc => tauto + case addComm => tauto + case addEqOfLt => tauto + case zeroLe => tauto + case zeroLtOne => tauto + case oneLeOfZeroLt => tauto + case addLtAdd => tauto + case mulZero => tauto + case mulOne => tauto + case mulAssoc => tauto + case mulComm => tauto + case mulLtMul => tauto + case distr => tauto + case ltIrrefl => tauto + case ltTrans => tauto + case ltTri => tauto + · rintro + (h | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | rfl | + rfl | rfl | rfl) + · exact equal _ h + · exact addZero + · exact addAssoc + · exact addComm + · exact addEqOfLt + · exact zeroLe + · exact zeroLtOne + · exact oneLeOfZeroLt + · exact addLtAdd + · exact mulZero + · exact mulOne + · exact mulAssoc + · exact mulComm + · exact mulLtMul + · exact distr + · exact ltIrrefl + · exact ltTrans + · exact ltTri + rw [this]; simp only [Set.finite_union, FirstOrder.Theory.EqAxiom.finite, true_and] + apply Set.Finite.insert + apply Set.Finite.insert + apply Set.Finite.insert + apply Set.Finite.insert + apply Set.Finite.insert + apply Set.Finite.insert + apply Set.Finite.insert + apply Set.Finite.insert + apply Set.Finite.insert + apply Set.Finite.insert + apply Set.Finite.insert + apply Set.Finite.insert + apply Set.Finite.insert + apply Set.Finite.insert + apply Set.Finite.insert + apply Set.Finite.insert + apply Set.finite_singleton + +lemma equiv_singleton_finiteConj : + 𝐏𝐀⁻ ≊ ({PointwiseComposition.Finset.conj finite.toFinset} : ArithmeticTheory) := + by + have hConj : 𝐏𝐀⁻ ⊢ (PointwiseComposition.Finset.conj finite.toFinset) := + Entailment.FConj_iff_forall_provable.mpr fun {σ} hσ ↦ Entailment.by_axm (by simp_all) + exact + Entailment.Equiv.antisymm_iff.mpr + ⟨Entailment.WeakerThan.ofAxmProof fun {σ} hσ ↦ + Entailment.mdp (Entailment.left_Fconj_intro (by simp_all)) (Entailment.by_axm rfl), + Entailment.WeakerThan.ofAxmProof fun {σ} hσ ↦ by rcases hσ with rfl; exact hConj⟩ + +@[simp] +instance : ℕ↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := + ⟨by + intro σ h + rcases h <;> simp only [models_iff, Semiformula.eval_all, Nat.succ_eq_add_one, Nat.reduceAdd, + Fin.isValue, Semiformula.eval_operator, Matrix.comp₂, Semiterm.val_operator, + Semiterm.val_bvar, Matrix.cons_val_fin_one, Matrix.comp₀, + Tarski.Structure.numeral_eq_numeral, ORingStructure.zero_eq_zero, Tarski.Structure.Add.add, + add_zero, Tarski.Structure.eq_iff_eq, Matrix.cons_val_zero, Matrix.cons_val_one, + implies_true, Matrix.cons_app_two, LogicalConnective.HomClass.map_imply, + Tarski.Structure.lt_iff_lt, Semiformula.eval_ex, LogicalConnective.Prop.arrow_eq, + Tarski.Structure.LE.le, zero_le, ORingStructure.one_eq_one, iff_le_one_eq_zero, + add_lt_add_iff_right, imp_self, Tarski.Structure.Mul.mul, mul_zero, mul_one, + LogicalConnective.HomClass.map_and, LogicalConnective.Prop.and_eq, and_imp, + LogicalConnective.HomClass.map_neg, lt_self_iff_false, LogicalConnective.Prop.neg_eq, + not_false_eq_true, LogicalConnective.HomClass.map_or, LogicalConnective.Prop.or_eq] + case addAssoc => intros; exact add_assoc _ _ _ + case addComm => intros; exact add_comm _ _ + case mulAssoc => intros; exact mul_assoc _ _ _ + case mulComm => intros; exact mul_comm _ _ + case addEqOfLt => intro a b h; exact ⟨b - a, Nat.add_sub_of_le (le_of_lt h)⟩ + case oneLeOfZeroLt => intro n hn; exact hn + case mulLtMul => intro a b c h hl; exact (mul_lt_mul_iff_left₀ hl).mpr h + case distr => intros; exact Nat.mul_add _ _ _ + case ltTrans => intro a b c; exact Nat.lt_trans + case ltTri => intros; exact Nat.lt_trichotomy _ _ + case equal h => + have : ℕ↓[ℒₒᵣ] ⊧* (𝐄𝐐 ℒₒᵣ : ArithmeticTheory) := inferInstance + exact models_theory_iff.mp this _ h⟩ + +instance : 𝐄𝐐 ℒₒᵣ ≼ 𝐏𝐀⁻ := + Entailment.WeakerThan.ofSubset fun φ hp ↦ PeanoMinus.equal φ hp + +end PeanoMinus + +variable {M : Type*} [ORingStructure M] + +/-- The inst LE lean Pool construction in `FFL.FirstOrder.Arithmetic`. -/ +scoped instance instLEModel : LE M := + ⟨fun x y => x = y ∨ x < y⟩ + +lemma le_def {x y : M} : x ≤ y ↔ x = y ∨ x < y := + iff_of_eq rfl + +variable [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] + +protected lemma add_zero' : ∀ x : M, x + 0 = x := by + simpa [models_iff] using Theory.models M _ PeanoMinus.addZero + +protected lemma add_assoc : ∀ x y z : M, (x + y) + z = x + (y + z) := by + simpa [models_iff] using Theory.models M _ PeanoMinus.addAssoc + +protected lemma add_comm : ∀ x y : M, x + y = y + x := by + simpa [models_iff] using Theory.models M _ PeanoMinus.addComm + +lemma add_eq_of_lt : ∀ x y : M, x < y → ∃ z, x + z = y := by + simpa [models_iff] using Theory.models M _ PeanoMinus.addEqOfLt + +@[simp] +protected lemma zero_le : ∀ x : M, 0 ≤ x := + by + have h := Theory.models M _ PeanoMinus.zeroLe + simp only [models_iff] at h + exact h + +lemma zero_lt_one : (0 : M) < 1 := by + simpa [models_iff] using Theory.models M _ PeanoMinus.zeroLtOne + +lemma one_le_of_zero_lt : ∀ x : M, 0 < x → 1 ≤ x := + by + have h := Theory.models M _ PeanoMinus.oneLeOfZeroLt + simp only [models_iff, Semiformula.eval_all, Nat.succ_eq_add_one, Nat.reduceAdd, + Fin.Fin1.eq_one, Fin.isValue, LogicalConnective.HomClass.map_imply, + Semiformula.eval_operator, Matrix.comp₂, Semiterm.val_operator, Matrix.comp₀, + Tarski.Structure.numeral_eq_numeral, ORingStructure.zero_eq_zero, Semiterm.val_bvar, + Matrix.cons_val_fin_one, Tarski.Structure.lt_iff_lt, Matrix.cons_val_zero, + Matrix.cons_val_one, ORingStructure.one_eq_one, LogicalConnective.Prop.arrow_eq] at h + exact h + +lemma add_lt_add : ∀ x y z : M, x < y → x + z < y + z := by + simpa [models_iff] using Theory.models M _ PeanoMinus.addLtAdd + +protected lemma mul_zero' : ∀ x : M, x * 0 = 0 := by + simpa [models_iff] using Theory.models M _ PeanoMinus.mulZero + +protected lemma mul_one : ∀ x : M, x * 1 = x := by + simpa [models_iff] using Theory.models M _ PeanoMinus.mulOne + +protected lemma mul_assoc : ∀ x y z : M, (x * y) * z = x * (y * z) := by + simpa [models_iff] using Theory.models M _ PeanoMinus.mulAssoc + +protected lemma mul_comm : ∀ x y : M, x * y = y * x := by + simpa [models_iff] using Theory.models M _ PeanoMinus.mulComm + +lemma mul_lt_mul : ∀ x y z : M, x < y → 0 < z → x * z < y * z := by + simpa [models_iff] using Theory.models M _ PeanoMinus.mulLtMul + +lemma mul_add_distr : ∀ x y z : M, x * (y + z) = x * y + x * z := by + simpa [models_iff] using Theory.models M _ PeanoMinus.distr + +lemma lt_irrefl : ∀ x : M, ¬x < x := by + simpa [models_iff] using Theory.models M _ PeanoMinus.ltIrrefl + +protected lemma lt_trans : ∀ x y z : M, x < y → y < z → x < z := by + simpa [models_iff] using Theory.models M _ PeanoMinus.ltTrans + +lemma lt_tri : ∀ x y : M, x < y ∨ x = y ∨ y < x := by + simpa [models_iff] using Theory.models M _ PeanoMinus.ltTri + +/-- The inst Add Comm Monoid lean Pool construction in `FFL.FirstOrder.Arithmetic`. -/ +scoped instance instAddCommMonoidModel : AddCommMonoid M + where + add_assoc := Arithmetic.add_assoc + zero_add := fun x ↦ Arithmetic.add_comm x 0 ▸ Arithmetic.add_zero' x + add_zero := Arithmetic.add_zero' + add_comm := Arithmetic.add_comm + nsmul := nsmulRec + +/-- The inst Comm Monoid lean Pool construction in `FFL.FirstOrder.Arithmetic`. -/ +scoped instance instCommMonoidModel : CommMonoid M + where + mul_assoc := Arithmetic.mul_assoc + one_mul := fun x ↦ Arithmetic.mul_comm x 1 ▸ Arithmetic.mul_one x + mul_one := Arithmetic.mul_one + mul_comm := Arithmetic.mul_comm + +/-- The inst Linear Order lean Pool construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable scoped instance instLinearOrderModel : LinearOrder M + where + le_refl := fun x ↦ Or.inl (by simp) + le_trans := by + rintro x y z (rfl | hx) (rfl | hy) + · simp [le_def] + · simp [le_def, *] + · simp [le_def, *] + · exact Or.inr (Arithmetic.lt_trans _ _ _ hx hy) + le_antisymm := by + rintro x y (rfl | hx) <;> try simp + rintro (rfl | hy) <;> try simp + exact False.elim <| Arithmetic.lt_irrefl _ <| Arithmetic.lt_trans _ _ _ hx hy + le_total := by + intro x y + rcases Arithmetic.lt_tri x y with (h | rfl | h) <;> simp [*, le_def] + lt_iff_le_not_ge := fun x y ↦ + ⟨fun h => + ⟨Or.inr h, by + simp only [le_def]; rintro (rfl | h'); · exact lt_irrefl y h + · exact lt_irrefl _ (Arithmetic.lt_trans _ _ _ h h')⟩, + by + simp only [le_def, not_or, and_imp] + rintro (rfl | h) <;> simp [*]⟩ + toDecidableLE := fun _ _ => Classical.dec _ + +protected lemma zero_mul : ∀ x : M, 0 * x = 0 := fun x => by + simpa [mul_comm] using Arithmetic.mul_zero' x + +/-- The inst Comm Semiring lean Pool construction in `FFL.FirstOrder.Arithmetic`. -/ +scoped instance instCommSemiringModel : CommSemiring M + where + left_distrib := Arithmetic.mul_add_distr + right_distrib := fun x y z ↦ by simp [mul_comm _ z, mul_add_distr] + zero_mul := Arithmetic.zero_mul + mul_zero := Arithmetic.mul_zero' + +scoped instance : IsStrictOrderedRing M + where + add_le_add_left := by + rintro x y (rfl | h) z + · simp + · exact Or.inr (add_lt_add x y z h) + le_of_add_le_add_left := by + rintro x y z h + have : y ≤ z ∨ z < y := le_or_gt y z + rcases this with (hyz | hyz) + · exact hyz + · have : x + z < x + y := by simpa [add_comm] using add_lt_add z y x hyz + exact False.elim (lt_iff_not_ge.mp this h) + zero_le_one := Or.inr zero_lt_one + exists_pair_ne := ⟨0, 1, ne_of_lt zero_lt_one⟩ + mul_lt_mul_of_pos_left := by + intro z hz x y h + simpa [mul_comm z] using mul_lt_mul x y z h hz + mul_lt_mul_of_pos_right := by + intro z hz x y h + exact mul_lt_mul x y z h hz +scoped instance : CanonicallyOrderedAdd M + where + exists_add_of_le := by + rintro x y (rfl | h) + · exact ⟨0, by simp⟩ + · simpa [eq_comm] using add_eq_of_lt x y h + le_self_add := by intro x y; simp + le_add_self := by intro x y; simp + +scoped instance : IsOrderedAddMonoid M where + add_le_add_left _ _ h z := (add_le_add_iff_right z).mpr h + +lemma numeral_eq_natCast_app : (n : ℕ) → (ORingStructure.numeral n : M) = n + | 0 => rfl + | 1 => by simp + | n + 2 => by + simp [ORingStructure.numeral, numeral_eq_natCast_app (n + 1), add_assoc, one_add_one_eq_two] + +lemma numeral_eq_natCast : (ORingStructure.numeral : ℕ → M) = Nat.cast := by + ext x; exact numeral_eq_natCast_app x + +lemma not_neg (x : M) : ¬x < 0 := by simp + +lemma eq_succ_of_pos {x : M} (h : 0 < x) : ∃ y, x = y + 1 := + by + rcases le_iff_exists_add.mp (one_le_of_zero_lt x h) with ⟨y, rfl⟩ + exact ⟨y, add_comm 1 y⟩ + +lemma le_iff_lt_succ {x y : M} : x ≤ y ↔ x < y + 1 := + ⟨by intro h; exact lt_of_le_of_lt h (lt_add_one y), fun h => + by + rcases lt_iff_exists_add.mp h with ⟨z, hz, h⟩ + rcases eq_succ_of_pos hz with ⟨z', rfl⟩ + have : y = x + z' := by simpa [← add_assoc] using h + simp [this]⟩ + +lemma eq_nat_of_lt_nat : ∀ {n : ℕ} {x : M}, x < n → ∃ m : ℕ, x = m + | 0, x, hx => by simp_all + | n + 1, x, hx => by + have : x ≤ n := by simpa [le_iff_lt_succ] using hx + rcases this with (rfl | hx) + · exact ⟨n, rfl⟩ + · exact eq_nat_of_lt_nat hx + +lemma eq_nat_of_le_nat {n : ℕ} {x : M} : x ≤ n → ∃ m : ℕ, x = m := fun h ↦ + by + have : x < ↑(n + 1) := by simpa [← le_iff_lt_succ] using h + exact eq_nat_of_lt_nat this + +instance models_R0_of_models_PeanoMinus : M↓[ℒₒᵣ] ⊧* 𝐑₀ := + models_theory_iff.mpr <| by + intro φ h + rcases h + case equal h => + have : M↓[ℒₒᵣ] ⊧* 𝐄𝐐 ℒₒᵣ := inferInstance + exact models_theory_iff.mp this _ h + case Ω₁ n m => simp [models_iff, numeral_eq_natCast] + case Ω₂ n m => simp [models_iff, numeral_eq_natCast] + case Ω₃ + n => + suffices ∀ x : M, x < ↑n ↔ ∃ i < n, x = ↑i by simpa [models_iff, numeral_eq_natCast]; + intro x + constructor + · intro hx; rcases eq_nat_of_lt_nat hx with ⟨x, rfl⟩; + exact ⟨x, by simpa using hx, by simp⟩ + · rintro ⟨i, hi, rfl⟩; simp [hi] + +instance : 𝐑₀ ≼ 𝐏𝐀⁻ := + weakerThan_of_models.{0} _ _ fun _ _ _ ↦ inferInstance + +instance models_RobinsonQ_of_models_PeanoMinus : M↓[ℒₒᵣ] ⊧* 𝐐 := + models_theory_iff.mpr <| by + intro φ h + rcases h + case equal h => + have : M↓[ℒₒᵣ] ⊧* 𝐄𝐐 ℒₒᵣ := inferInstance + exact models_theory_iff.mp this _ h + case addSucc + h => + suffices ∀ a b : M, a + (b + 1) = a + b + 1 by simpa [models_iff]; + simp [add_assoc] + case mulSucc + h => + suffices ∀ a b : M, a * (b + 1) = a * b + a by simpa [models_iff]; + intro a b; + calc + a * (b + 1) = (a * b) + (a * 1) := by rw [mul_add_distr] + _ = (a * b) + a := by rw [mul_one] + case zeroOrSucc + h => + suffices ∀ a b : M, a = 0 ∨ ∃ x, a = x + 1 by simpa [models_iff]; + intro a b; by_cases h : 0 < a; · right; apply eq_succ_of_pos h; + · left; simpa using h; + case ltDef + h => + suffices ∀ a b : M, a < b ↔ ∃ x, a + (x + 1) = b by simpa [models_iff]; + intro a b; apply Iff.trans lt_iff_exists_add; constructor; + · rintro ⟨a, ha₁, ha₂⟩; obtain ⟨b, rfl⟩ : ∃ b, a = b + 1 := eq_succ_of_pos ha₁; use b; + tauto; + · rintro ⟨a, ha⟩; use (a + 1); constructor; · simp; + · apply ha.symm; + all_goals simp [models_iff]; + +instance : 𝐐 ≼ 𝐏𝐀⁻ := + weakerThan_of_models.{0} _ _ fun _ _ _ ↦ inferInstance + +variable {a b c : M} + +@[simp] +lemma numeral_two_eq_two : (ORingStructure.numeral 2 : M) = 2 := by simp [numeral_eq_natCast] + +@[simp] +lemma numeral_three_eq_three : (ORingStructure.numeral 3 : M) = 3 := by + simp [numeral_eq_natCast] + +@[simp] +lemma numeral_four_eq_four : (ORingStructure.numeral 4 : M) = 4 := by simp [numeral_eq_natCast] + +lemma lt_succ_iff_le {x y : M} : x < y + 1 ↔ x ≤ y := + Iff.symm le_iff_lt_succ + +lemma lt_iff_succ_le : a < b ↔ a + 1 ≤ b := by simp [le_iff_lt_succ] + +lemma succ_le_iff_lt : a + 1 ≤ b ↔ a < b := by simp [le_iff_lt_succ] + +lemma pos_iff_one_le : 0 < a ↔ 1 ≤ a := by simp [lt_iff_succ_le] + +lemma one_lt_iff_two_le : 1 < a ↔ 2 ≤ a := by simp [lt_iff_succ_le, one_add_one_eq_two] + +lemma not_nonpos (a : M) : ¬a < 0 := by simp + +lemma lt_two_iff_le_one : a < 2 ↔ a ≤ 1 := by + simp [lt_iff_succ_le, + show a + 1 ≤ 2 ↔ a ≤ 1 from by + rw [show (2 : M) = 1 + 1 from one_add_one_eq_two.symm]; exact add_le_add_iff_right 1] + +lemma lt_one_iff_eq_zero : a < 1 ↔ a = 0 := + ⟨by + intro hx + have : a ≤ 0 := by exact le_iff_lt_succ.mpr (show a < 0 + 1 from by simpa using hx) + exact nonpos_iff_eq_zero.mp this, by rintro rfl; exact zero_lt_one⟩ + +lemma le_one_iff_eq_zero_or_one : a ≤ 1 ↔ a = 0 ∨ a = 1 := + ⟨by + intro h; rcases h with (rfl | ltx) + · simp + · simp [show a = 0 from by simpa using ltx], by rintro (rfl | rfl) <;> simp⟩ + +lemma le_two_iff_eq_zero_or_one_or_two : a ≤ 2 ↔ a = 0 ∨ a = 1 ∨ a = 2 := + ⟨by + intro h; rcases h with (rfl | lt) + · simp + · rcases lt_two_iff_le_one.mp lt with (rfl | lt) + · simp + · simp [show a = 0 from by simpa using lt], by rintro (rfl | rfl | rfl) <;> simp⟩ + +lemma le_three_iff_eq_zero_or_one_or_two_or_three : a ≤ 3 ↔ a = 0 ∨ a = 1 ∨ a = 2 ∨ a = 3 := + ⟨by + intro h; rcases h with (rfl | lt) + · simp + · have : a ≤ 2 := by simpa [← le_iff_lt_succ, ← two_add_one_eq_three] using lt + rcases this with (rfl | lt) + · simp + · rcases lt_two_iff_le_one.mp lt with (rfl | lt) + · simp + · simp [show a = 0 from by simpa using lt], by + rintro (rfl | rfl | rfl | rfl) <;> simp [← two_add_one_eq_three]⟩ + +lemma two_mul_two_eq_four : 2 * 2 = (4 : M) := by + rw [← one_add_one_eq_two, mul_add, add_mul, mul_one, ← add_assoc, one_add_one_eq_two, + two_add_one_eq_three, three_add_one_eq_four] + +lemma two_pow_two_eq_four : 2 ^ 2 = (4 : M) := by simp [sq, two_mul_two_eq_four] + +lemma two_pos : (0 : M) < 2 := by exact _root_.two_pos + +@[simp] +lemma le_mul_self (a : M) : a ≤ a * a := + by + have : 0 ≤ a := Arithmetic.zero_le a + rcases this with (rfl | pos) <;> simp [*, ← pos_iff_one_le] + +@[simp] +lemma le_sq (a : M) : a ≤ a ^ 2 := by simp [sq] + +@[simp] +lemma sq_le_sq : a ^ 2 ≤ b ^ 2 ↔ a ≤ b := by + simpa [sq] using Iff.symm <| mul_self_le_mul_self_iff (by simp) (by simp) + +@[simp] +lemma sq_lt_sq : a ^ 2 < b ^ 2 ↔ a < b := by + simpa [sq] using Iff.symm <| mul_self_lt_mul_self_iff (by simp) (by simp) + +lemma le_mul_of_pos_right (h : 0 < b) : a ≤ a * b := + le_mul_of_one_le_right (by simp) (pos_iff_one_le.mp h) + +lemma le_mul_of_pos_left (h : 0 < b) : a ≤ b * a := + le_mul_of_one_le_left (by simp) (pos_iff_one_le.mp h) + +@[simp] +lemma le_two_mul_left : a ≤ 2 * a := + le_mul_of_pos_left (by simp) + +lemma lt_mul_of_pos_of_one_lt_right (pos : 0 < a) (h : 1 < b) : a < a * b := + _root_.lt_mul_of_one_lt_right pos h + +lemma lt_mul_of_pos_of_one_lt_left (pos : 0 < a) (h : 1 < b) : a < b * a := + _root_.lt_mul_of_one_lt_left pos h + +lemma mul_le_mul_left (h : b ≤ c) : a * b ≤ a * c := + mul_le_mul_of_nonneg_left h (by simp) + +lemma mul_le_mul_right (h : b ≤ c) : b * a ≤ c * a := + mul_le_mul_of_nonneg_right h (by simp) + +theorem lt_of_mul_lt_mul_left (h : a * b < a * c) : b < c := + lt_of_mul_lt_mul_of_nonneg_left h (by simp) + +theorem lt_of_mul_lt_mul_right (h : b * a < c * a) : b < c := + lt_of_mul_lt_mul_of_nonneg_right h (by simp) + +lemma pow_three (x : M) : x ^ 3 = x * x * x := by rw [← two_add_one_eq_three, pow_add, sq]; simp + +lemma pow_four (x : M) : x ^ 4 = x * x * x * x := by + rw [← three_add_one_eq_four, pow_add, pow_three]; simp + +lemma pow_four_eq_sq_sq (x : M) : x ^ 4 = (x ^ 2) ^ 2 := by simp [pow_four, sq, mul_assoc] + +scoped instance : CovariantClass M M (· * ·) (· ≤ ·) := + ⟨by intro; exact mul_le_mul_left⟩ + +scoped instance : CovariantClass M M (· + ·) (· ≤ ·) := + ⟨by intro; simp⟩ + +scoped instance : CovariantClass M M (Function.swap (· * ·)) (· ≤ ·) := + ⟨by intro; exact mul_le_mul_right⟩ + +@[simp] +lemma one_lt_mul_self_iff {a : M} : 1 < a * a ↔ 1 < a := + ⟨(fun h ↦ by push Not at h ⊢; exact mul_le_one' h h).mtr, fun h ↦ one_lt_mul'' h h⟩ + +@[simp] +lemma opos_lt_sq_pos_iff {a : M} : 0 < a ^ 2 ↔ 0 < a := by simp [sq, pos_iff_ne_zero] + +@[simp] +lemma one_lt_sq_iff {a : M} : 1 < a ^ 2 ↔ 1 < a := by simp [sq] + +@[simp] +lemma mul_self_eq_one_iff {a : M} : a * a = 1 ↔ a = 1 := + not_iff_not.mp (by simp [ne_iff_lt_or_gt]) + +@[simp] +lemma sq_eq_one_iff {a : M} : a ^ 2 = 1 ↔ a = 1 := by simp [sq] + +lemma lt_square_of_lt {a : M} (pos : 1 < a) : a < a ^ 2 := by rw [sq]; apply lt_mul_self pos + +lemma two_mul_le_sq {i : M} (h : 2 ≤ i) : 2 * i ≤ i ^ 2 := by + simpa [sq] using mul_le_mul_right h + +lemma two_mul_le_sq_add_one (i : M) : 2 * i ≤ i ^ 2 + 1 := + by + rcases Arithmetic.zero_le i with (rfl | pos) + · simp + · rcases pos_iff_one_le.mp pos with (rfl | lt) + · simp [one_add_one_eq_two] + · exact le_trans (two_mul_le_sq (one_lt_iff_two_le.mp lt)) (by simp) + +lemma two_mul_lt_sq {i : M} (h : 2 < i) : 2 * i < i ^ 2 := by + simpa [sq] using (mul_lt_mul_iff_left₀ (show 0 < i from pos_of_gt h)).mpr h + +lemma succ_le_double_of_pos {a : M} (h : 0 < a) : a + 1 ≤ 2 * a := by + simpa [two_mul] using pos_iff_one_le.mp h + +lemma two_mul_add_one_lt_two_mul_of_lt (h : a < b) : 2 * a + 1 < 2 * b := + calc + 2 * a + 1 < 2 * (a + 1) := by simp [mul_add] + _ ≤ 2 * b := by simp [← lt_iff_succ_le, h] + +@[simp] +lemma le_add_add_left (a b c : M) : a ≤ a + b + c := by simp [add_assoc] + +@[simp] +lemma le_add_add_right (a b c : M) : b ≤ a + b + c := by simp [add_right_comm a b c] + +lemma add_le_cancel (a : M) : AddLECancellable a := by intro b c; simp + +open FirstOrder FirstOrder.Semiterm + +@[simp] +lemma val_npow (k : ℕ) (a : M) : (Operator.npow ℒₒᵣ k).val ![a] = a ^ k := + by + induction k + case zero => simp [Operator.npow_zero, Operator.val_comp, Matrix.empty_eq] + case succ k IH => + simp [Operator.npow_succ, Operator.val_comp] + simp [pow_succ, IH] + +instance : Tarski.Structure.Monotone ℒₒᵣ M := + ⟨fun {k} f v₁ v₂ h ↦ + match k, f with + | 0, Language.Zero.zero => by rfl + | 0, Language.One.one => by rfl + | 2, Language.Add.add => add_le_add (h 0) (h 1) + | 2, Language.Mul.mul => mul_le_mul (h 0) (h 1) (by simp) (by simp)⟩ + +@[simp] +lemma zero_ne_add_one (x : M) : 0 ≠ x + (1 : M) := + ne_of_lt (by simp) + +@[simp] +lemma nat_cast_inj {n m : ℕ} : (n : M) = (m : M) ↔ n = m := by + induction n with + | zero => cases m <;> simp + | succ n ih => cases m <;> simp + +@[simp] +lemma coe_coe_lt {n m : ℕ} : (n : M) < (m : M) ↔ n < m := by + induction n with + | zero => cases m <;> simp + | succ n ih => cases m <;> simp + +lemma coe_add_one (x : ℕ) : ((x + 1 : ℕ) : M) = (x : M) + 1 := by simp + +lemma eq_fin_of_lt_nat {n : ℕ} {x : M} (hx : x < (n : M)) : ∃ i : Fin n, x = i := + by + rcases eq_nat_of_lt_nat hx with ⟨x, rfl⟩ + exact ⟨⟨x, by simpa using hx⟩, by simp⟩ + +@[simp] +lemma eval_ballLTSucc' {t : ArithmeticSemiterm ξ n} {φ : ArithmeticSemiformula ξ (n + 1)} : + (φ.ballLTSucc t).Eval e ε ↔ ∀ x ≤ t.val (M := M) e ε, φ.Eval (x :> e) ε := by + simp [Semiformula.eval_ballLTSucc, lt_succ_iff_le] + +@[simp] +lemma eval_bexsLTSucc' {t : ArithmeticSemiterm ξ n} {φ : ArithmeticSemiformula ξ (n + 1)} : + (φ.bexsLTSucc t).Eval e ε ↔ ∃ x ≤ t.val (M := M) e ε, φ.Eval (x :> e) ε := by + simp [Semiformula.eval_bexsLTSucc, lt_succ_iff_le] + +variable (M) + +/-- The nat Cast construction in `FFL.FirstOrder.Arithmetic`. -/ +abbrev natCast : NatCast M := + inferInstance + +variable {M} + +@[simp] +lemma natCast_nat (n : ℕ) : @Nat.cast ℕ (natCast ℕ) n = n := + by + induction n + · rfl + · unfold natCast; rw [coe_add_one]; simp [*] + +variable {T : ArithmeticTheory} [𝐏𝐀⁻ ≼ T] + +instance : 𝐑₀ ≺ 𝐏𝐀⁻ := + Entailment.StrictlyWeakerThan.of_unprovable_provable R0.unprovable_addZero + (Entailment.by_axm PeanoMinus.addZero) + +instance (M : Type*) [ORingStructure M] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] : M↓[ℒₒᵣ] ⊧* 𝐑₀ := + models_of_subtheory (U := 𝐏𝐀⁻) inferInstance + +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/PeanoMinus/Functions.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/PeanoMinus/Functions.lean new file mode 100644 index 000000000..a5f172d03 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/PeanoMinus/Functions.lean @@ -0,0 +1,356 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Definability +public import Mathlib.Algebra.Prime.Lemmas +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.ExistsUnique + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +/-! +# Functions and relations defined in $\mathsf{PA^-}$ + +This file provides functions and relations defined in $\mathsf{PA^-} + +-/ + +namespace FFL +namespace FirstOrder +namespace Arithmetic + +variable {V : Type*} [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] + +variable {a b c : V} + +/-! +### (Modified) Subtraction -/ + +section sub + +lemma sub_existsUnique (a b : V) : ∃! c, (a ≥ b → a = b + c) ∧ (a < b → c = 0) := + by + have : b ≤ a ∨ a < b := le_or_gt b a + rcases this with (hxy | hxy) + · have : ∃ c, a = b + c := exists_add_of_le hxy + rcases this with ⟨c, rfl⟩ + simp [hxy] + · simp [hxy] + +/-- The sub construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def sub (a b : V) : V := + Classical.chooseUnique (sub_existsUnique a b) + +/-- The inst Sub lean Pool construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable scoped instance instSubModel : Sub V := + ⟨sub⟩ + +lemma sub_spec_of_ge (h : a ≥ b) : a = b + (a - b) := + (Classical.chooseUnique_spec (sub_existsUnique a b)).1 h + +lemma sub_spec_of_lt (h : a < b) : a - b = 0 := + (Classical.chooseUnique_spec (sub_existsUnique a b)).2 h + +lemma sub_eq_iff : c = a - b ↔ ((a ≥ b → a = b + c) ∧ (a < b → c = 0)) := + Classical.chooseUnique_eq_iff_right (sub_existsUnique a b) + +lemma sub_le_self (a b : V) : a - b ≤ a := + by + have : b ≤ a ∨ a < b := le_or_gt b a + rcases this with (hxy | hxy) <;> simp + · simpa [← sub_spec_of_ge hxy] using show a - b ≤ b + (a - b) from le_add_self + · simp [sub_spec_of_lt hxy] + +open FirstOrder.Arithmetic.HierarchySymbol.Definable + +/-- The sub Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.subDef : Σ₀.Semisentence 3 := + .mkSigma (“z x y. (x ≥ y → x = y + z) ∧ (x < y → z = 0)”) + +instance sub_defined : Σ₀-Function₂ ((· - ·) : V → V → V) via subDef := + .mk <| by intro v; simp [FirstOrder.Arithmetic.subDef, sub_eq_iff] + +instance sub_definable (ℌ : HierarchySymbol) : ℌ.DefinableFunction₂ ((· - ·) : V → V → V) := + sub_defined.to_definable₀ + +instance sub_polybounded : Bounded₂ ((· - ·) : V → V → V) := + ⟨#0, fun v ↦ by simpa using sub_le_self (v 0) (v 1)⟩ + +@[simp] +lemma sub_self (a : V) : a - a = 0 := + add_eq_left.mp (sub_spec_of_ge (a := a) (b := a) (by rfl)).symm + +lemma sub_spec_of_le (h : a ≤ b) : a - b = 0 := by + rcases lt_or_eq_of_le h with (lt | rfl) <;> simp [sub_spec_of_lt, *] + +lemma sub_add_self_of_le (h : b ≤ a) : a - b + b = a := by + symm; rw [add_comm]; + exact sub_spec_of_ge h + +lemma add_tsub_self_of_le (h : b ≤ a) : b + (a - b) = a := by symm; exact sub_spec_of_ge h + +@[simp] +lemma add_sub_self : (a + b) - b = a := by + symm; + simpa [add_comm b] using sub_spec_of_ge (show b ≤ a + b from le_add_self) + +@[simp] +lemma add_sub_self' : (b + a) - b = a := by simp [add_comm] + +@[simp] +lemma zero_sub (a : V) : 0 - a = 0 := + sub_spec_of_le (by simp) + +@[simp] +lemma sub_zero (a : V) : a - 0 = a := by + simpa using sub_add_self_of_le (show 0 ≤ a from Arithmetic.zero_le a) + +lemma sub_remove_left (e : a = b + c) : a - c = b := by simp [e] + +lemma sub_sub : a - b - c = a - (b + c) := + by + by_cases ha : b + c ≤ a + · exact + sub_remove_left <| + sub_remove_left <| by + simp [add_assoc, show c + b = b + c from add_comm _ _, sub_add_self_of_le, ha] + · suffices a - b - c = 0 by simpa [sub_spec_of_lt (show a < b + c from not_le.mp ha)] + by_cases hc : c ≤ a - b + · by_cases hb : b ≤ a + · have : a < a := + calc + a < b + c := not_le.mp ha + _ ≤ b + (a - b) := by simp [hc] + _ = a := add_tsub_self_of_le hb + simp at this + · simp [show a - b = 0 from sub_spec_of_lt (not_le.mp hb)] + · exact sub_spec_of_lt (not_le.mp hc) + +@[simp] +lemma pos_sub_iff_lt : 0 < a - b ↔ b < a := + ⟨by contrapose; simpa using sub_spec_of_le, + by + intro h; by_contra hs + have : a = b := by + simpa [show a - b = 0 by simpa using hs] using sub_spec_of_ge (show b ≤ a from LT.lt.le h) + simp [this] at h⟩ + +@[simp] +lemma sub_eq_zero_iff_le : a - b = 0 ↔ a ≤ b := + not_iff_not.mp (by simp [← pos_iff_ne_zero]) + +instance : OrderedSub V where + tsub_le_iff_right := by + intro a b c + by_cases h : b ≤ a + · calc + a - b ≤ c ↔ (a - b) + b ≤ c + b := by simp + _ ↔ a ≤ c + b := by rw [sub_add_self_of_le h] + · suffices a ≤ c + b by simpa [sub_spec_of_lt (show a < b from by simpa using h)] + exact le_trans (le_of_lt <| show a < b from by simpa using h) (by simp) + +lemma pred_lt_self_of_pos (h : 0 < a) : a - 1 < a := + by + rcases zero_or_succ a with (rfl | ⟨a, rfl⟩) + · simp_all + · simp + +protected lemma tsub_lt_iff_left (h : b ≤ a) : a - b < c ↔ a < c + b := + AddLECancellable.tsub_lt_iff_right (add_le_cancel b) h + +lemma sub_mul (h : b ≤ a) : (a - b) * c = a * c - b * c := + by + have : a = (a - b) + b := (tsub_eq_iff_eq_add_of_le h).mp rfl + calc + (a - b) * c = (a - b) * c + b * c - b * c := by simp + _ = (a - b + b) * c - b * c := by simp [add_mul] + _ = a * c - b * c := by simp [sub_add_self_of_le h] + +lemma mul_sub (h : b ≤ a) : c * (a - b) = c * a - c * b := by simp [mul_comm c, sub_mul, h] + +lemma add_sub_of_le (h : c ≤ b) (a : V) : a + b - c = a + (b - c) := + add_tsub_assoc_of_le h a + +lemma sub_succ_add_succ {x y : V} (h : y < x) (z) : x - (y + 1) + (z + 1) = x - y + z := + calc + x - (y + 1) + (z + 1) = x - (y + 1) + 1 + z := by simp [add_assoc, add_comm] + _ = x - y - 1 + 1 + z := by simp [sub_sub] + _ = x - y + z := by + simp [show x - y - 1 + 1 = x - y from + sub_add_self_of_le <| one_le_of_zero_lt _ <| pos_sub_iff_lt.mpr h] + +lemma le_sub_one_of_lt {a b : V} (h : a < b) : a ≤ b - 1 := + by + have : 1 ≤ b := one_le_of_zero_lt _ (pos_of_gt h) + simp [le_iff_lt_succ, sub_add_self_of_le this, h] + +instance instAddCancelCommMonoidModel : AddCancelCommMonoid V where + add_left_cancel x y z e := by simpa using congr_arg (· - x) e + +end sub + +/-! +### Divisibility -/ + +section Dvd + +lemma le_mul_self_of_pos_left (hy : 0 < b) : a ≤ b * a := + by + have : 1 * a ≤ b * a := mul_le_mul_of_nonneg_right (one_le_of_zero_lt b hy) (by simp) + simpa using this + +lemma le_mul_self_of_pos_right (hy : 0 < b) : a ≤ a * b := by + simpa [mul_comm a b] using le_mul_self_of_pos_left hy + + + +lemma dvd_iff_bounded {a b : V} : a ∣ b ↔ ∃ c ≤ b, b = a * c := + by + by_cases hx : a = 0 + · simp [hx, show ∃ x, x ≤ b from ⟨0, by simp⟩] + · constructor + · rintro ⟨c, rfl⟩; exact ⟨c, le_mul_self_of_pos_left (pos_iff_ne_zero.mpr hx), rfl⟩ + · rintro ⟨c, hz, rfl⟩; exact dvd_mul_right a c + +/-- The dvd construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.dvd : Σ₀.Semisentence 2 := + .mkSigma (“x y. ∃ z <⁺ y, y = x * z”) + +instance dvd_defined : Σ₀-Relation (fun a b : V ↦ a ∣ b) via dvd := + .mk fun v ↦ by simp [dvd_iff_bounded, dvd] + +instance dvd_definable (ℌ : HierarchySymbol) : ℌ.DefinableRel ((· ∣ ·) : V → V → Prop) := + dvd_defined.to_definable₀ + +section + +/-- The «first order formula ∣ » construction in `FFL.FirstOrder.Arithmetic`. -/ +syntax :45 firstOrderTerm:45 " ∣ " firstOrderTerm:0 : firstOrderFormula + +macro_rules + | `(quoteformula(lit)[$binders* | $fbinders* | $t:firstOrderTerm ∣ $u:firstOrderTerm]) => + `(quoteformula(lit)[$binders* | $fbinders* | !dvd.val$t$u]) + +end + +end Dvd + +lemma le_of_dvd (h : 0 < b) : a ∣ b → a ≤ b := + by + rintro ⟨c, rfl⟩ + exact + le_mul_self_of_pos_right (pos_iff_ne_zero.mpr (show c ≠ 0 from by rintro rfl; simp at h)) + +lemma not_dvd_of_lt (pos : 0 < b) : b < a → ¬a ∣ b := by + intro hb h; + exact not_le.mpr hb (le_of_dvd pos h) + +lemma dvd_antisymm : a ∣ b → b ∣ a → a = b := + by + intro hx hy + rcases show a = 0 ∨ 0 < a from eq_zero_or_pos a with (rfl | ltx) + · simp [show b = 0 from by simpa using hx] + · rcases show b = 0 ∨ 0 < b from eq_zero_or_pos b with (rfl | lty) + · simp [show a = 0 from by simpa using hy] + · exact le_antisymm (le_of_dvd lty hx) (le_of_dvd ltx hy) + +lemma dvd_one_iff : a ∣ 1 ↔ a = 1 := + ⟨by { intro hx; exact dvd_antisymm hx (by simp) + }, by rintro rfl; simp⟩ + +theorem units_eq_one (u : Vˣ) : u = 1 := + Units.ext <| dvd_one_iff.mp ⟨u.inv, u.val_inv.symm⟩ + +@[simp] +lemma unit_iff_eq_one {a : V} : IsUnit a ↔ a = 1 := + ⟨by rintro ⟨u, rfl⟩; simp [units_eq_one u], by rintro rfl; simp⟩ + +/-! +### Prime number -/ + +section Prime + +instance instCommMonoidWithZeroModel : CommMonoidWithZero V where + +instance : IsCancelMulZero V where + +open _root_.Classical Classical in +lemma eq_one_or_eq_of_dvd_of_prime {p a : V} (pp : Prime p) (hxp : a ∣ p) : a = 1 ∨ a = p := + by + have : p ∣ a ∨ a ∣ 1 := + Prime.left_dvd_or_dvd_right_of_dvd_mul pp (show a ∣ p * 1 from by simpa using hxp) + rcases this with (hx | hx) + · right; exact dvd_antisymm hxp hx + · left; exact dvd_one_iff.mp hx + +/-- The Is Prime construction in `FFL.FirstOrder.Arithmetic`. -/ +def IsPrime (a : V) : Prop := + 1 < a ∧ ∀ b ≤ a, b ∣ a → b = 1 ∨ b = a + +/-- The is Prime construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.isPrime : Σ₀.Semisentence 1 := + .mkSigma (“x. 1 < x ∧ ∀ y <⁺ x, !dvd.val y x → y = 1 ∨ y = x”) + +instance isPrime_defined : Σ₀-Predicate (fun a : V ↦ IsPrime a) via isPrime := + .mk fun v ↦ by simp [Semiformula.eval_substs, IsPrime, isPrime] + +end Prime + +/-! +### Minimum -/ + +section min + +/-- The dfn construction in `FFL.FirstOrder.Arithmetic.min`. -/ +def min.dfn : Σ₀.Semisentence 3 := + .mkSigma (“z x y. (x ≤ y → z = x) ∧ (x ≥ y → z = y)”) + +instance min_defined : Σ₀-Function₂[V] min via min.dfn := + .mk fun v ↦ by simp [min.dfn]; grind + +instance min_definable (ℌ) : ℌ-Function₂[V] min := + min_defined.to_definable₀ + +instance min_polybounded : Bounded₂ (min : V → V → V) := + ⟨#0, fun _ ↦ by simp⟩ + +end min + +/-! +### Maximum -/ + +section max + +/-- The dfn construction in `FFL.FirstOrder.Arithmetic.max`. -/ +def max.dfn : Σ₀.Semisentence 3 := + .mkSigma (“z x y. (x ≥ y → z = x) ∧ (x ≤ y → z = y)”) + +instance max_defined : Σ₀-Function₂[V] max via max.dfn := + .mk fun v ↦ by simp [max.dfn]; grind + +instance max_definable (Γ) : Γ-Function₂[V] max := + max_defined.to_definable₀ + +instance max_polybounded : Bounded₂ (max : V → V → V) := + ⟨‘#0 + #1’, fun v ↦ by simp⟩ + +end max + +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Prenex.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Prenex.lean new file mode 100644 index 000000000..a0ca0c258 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Prenex.lean @@ -0,0 +1,802 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Basic.Model +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Basic.StrictHierarchy +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.BoundedCollection +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Definability.Hierarchy + +/-! Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# Prenex normal form for the arithmetical hierarchy + +For `𝐈Σ s ≼ T`, every `Hierarchy Γ s` formula `φ` is `T`-provably equivalent to `φ₀.toPrenex Γ s` +for some `φ₀ : ArithmeticSemisentence (n + s)` in `Hierarchy Σ 0`. + +## References + +- [HP98] +-/ + +@[expose] public section + +open FFL + +namespace FFL +namespace FirstOrder + +namespace Arithmetic + +/-- Data and laws for Prenex in `FFL.FirstOrder.Arithmetic`. -/ +structure Prenex (Γ : Polarity) (s : ℕ) (ξ : Type*) (n : ℕ) where + /-- The matrix construction in `FFL.FirstOrder.Arithmetic.Prenex`. -/ + matrix : Σ₀.Semiformula ξ (n + s) + +namespace Prenex + +variable {Γ : Polarity} {s : ℕ} {ξ ξ₁ ξ₂ : Type*} {n n₁ n₂ : ℕ} +variable {V : Type*} [ORingStructure V] + +/-- The val construction in `FFL.FirstOrder.Arithmetic.Prenex`. -/ +@[coe] +def val (φ : Prenex Γ s ξ n) : ArithmeticSemiformula ξ n := + φ.matrix.val.toPrenex Γ s + +instance : CoeTC (Prenex Γ s ξ n) (ArithmeticSemiformula ξ n) := + ⟨val⟩ + +/-- The neg construction in `FFL.FirstOrder.Arithmetic.Prenex`. -/ +def neg (φ : Prenex Γ s ξ n) : Prenex Γ.alt s ξ n := + ⟨.mkSigma (∼φ.matrix.val) φ.matrix.sigma_prop.neg.of_zero⟩ + +instance : HTilde (Prenex Γ s ξ n) (Prenex Γ.alt s ξ n) := + ⟨neg⟩ + +/-- The rew construction in `FFL.FirstOrder.Arithmetic.Prenex`. -/ +def rew (φ : Prenex Γ s ξ₁ n₁) (ω : Rew ℒₒᵣ ξ₁ n₁ ξ₂ n₂) : Prenex Γ s ξ₂ n₂ := + ⟨φ.matrix.rew (ω.qpow s)⟩ + +/-- The sigma construction in `FFL.FirstOrder.Arithmetic.Prenex`. -/ +def sigma (φ : Prenex Π s ξ (n + 1)) : Prenex Σ (s + 1) ξ n := + ⟨φ.matrix.rew (Rew.castLE (Nat.succ_add n s).le)⟩ + +/-- The pi construction in `FFL.FirstOrder.Arithmetic.Prenex`. -/ +def pi (φ : Prenex Σ s ξ (n + 1)) : Prenex Π (s + 1) ξ n := + ⟨φ.matrix.rew (Rew.castLE (Nat.succ_add n s).le)⟩ + +/-- The sigma Inv construction in `FFL.FirstOrder.Arithmetic.Prenex`. -/ +def sigmaInv (φ : Prenex Σ (s + 1) ξ n) : Prenex Π s ξ (n + 1) := + ⟨φ.matrix.rew (Rew.castLE (Nat.succ_add n s).ge)⟩ + +/-- The pi Inv construction in `FFL.FirstOrder.Arithmetic.Prenex`. -/ +def piInv (φ : Prenex Π (s + 1) ξ n) : Prenex Σ s ξ (n + 1) := + ⟨φ.matrix.rew (Rew.castLE (Nat.succ_add n s).ge)⟩ + +/-- The alt Up construction in `FFL.FirstOrder.Arithmetic.Prenex`. -/ +def altUp (φ : Prenex Γ s ξ n) : Prenex Γ.alt (s + 1) ξ n := + by + rcases Γ with _ | _ + · exact (φ.rew Rew.bShift).pi + · exact (φ.rew Rew.bShift).sigma + +/-- The ofΔ₀ construction in `FFL.FirstOrder.Arithmetic.Prenex`. -/ +def ofΔ₀ (φ : Σ₀.Semiformula ξ n) : (Γ : Polarity) → (s : ℕ) → Prenex Γ s ξ n + | Γ, 0 => ⟨φ⟩ + | Γ, s + 1 => by simpa using altUp (ofΔ₀ φ Γ.alt s) + +/-- The verum construction in `FFL.FirstOrder.Arithmetic.Prenex`. -/ +def verum : Prenex Γ s ξ n := + ofΔ₀ (.mkSigma ⊤ (Hierarchy.verum Σ 0 n)) Γ s + +/-- The falsum construction in `FFL.FirstOrder.Arithmetic.Prenex`. -/ +def falsum : Prenex Γ s ξ n := + ofΔ₀ (.mkSigma ⊥ (Hierarchy.falsum Σ 0 n)) Γ s + +/-- The rel construction in `FFL.FirstOrder.Arithmetic.Prenex`. -/ +def rel (r : (ℒₒᵣ).Rel k) (v : Fin k → ArithmeticSemiterm ξ n) : Prenex Γ s ξ n := + ofΔ₀ (.mkSigma (.rel r v) (Hierarchy.rel Σ 0 r v)) Γ s + +/-- The nrel construction in `FFL.FirstOrder.Arithmetic.Prenex`. -/ +def nrel (r : (ℒₒᵣ).Rel k) (v : Fin k → ArithmeticSemiterm ξ n) : Prenex Γ s ξ n := + ofΔ₀ (.mkSigma (.nrel r v) (Hierarchy.nrel Σ 0 r v)) Γ s + +@[simp, grind .] +lemma val_hierarchy {φ : Prenex Γ s ξ n} : Hierarchy Γ s φ.val := + by + change Hierarchy Γ s (φ.matrix.val.toPrenex Γ s) + simpa only [Nat.zero_add] using + Hierarchy.toPrenex (Γ := Γ) (j := 0) φ.matrix.sigma_prop.of_zero + +@[simp, grind .] +lemma val_deltaZero {φ : Prenex Γ 0 ξ n} : Hierarchy Σ 0 φ.val := + φ.matrix.sigma_prop + +@[simp, grind .] +lemma val_neg (φ : Prenex Γ s ξ n) : (∼φ).val = ∼φ.val := + by + change (neg φ).val = ∼φ.val + simp [neg, val] + +@[simp, grind .] +lemma val_rew (φ : Prenex Γ s ξ₁ n₁) (ω : Rew ℒₒᵣ ξ₁ n₁ ξ₂ n₂) : (φ.rew ω).val = ω ▹ φ.val := by + simp [val, rew] + +@[grind .] +lemma val_sigma {φ : Prenex Π s ξ (n + 1)} : φ.sigma.val = ∃¹ φ.val := by + simp [val, sigma, Rewriting.quantItr_succ_smul_castLE] + +@[grind .] +lemma val_pi {φ : Prenex Σ s ξ (n + 1)} : φ.pi.val = ∀¹ φ.val := by + simp [val, pi, Rewriting.quantItr_succ_smul_castLE] + +@[simp, grind .] +lemma val_sigmaInv {φ : Prenex Σ (s + 1) ξ n} : φ.val = ∃¹ φ.sigmaInv.val := + by + unfold val sigmaInv + simp only [HierarchySymbol.Semiformula.val_rew] + rw [← Polarity.quant_sigma, ← Polarity.alt_sigma, ← Rewriting.quantItr_succ_smul_castLE, ← + TransitiveRewriting.comp_app] + simp + +@[simp, grind .] +lemma val_piInv {φ : Prenex Π (s + 1) ξ n} : φ.val = ∀¹ φ.piInv.val := + by + unfold val piInv + simp only [HierarchySymbol.Semiformula.val_rew] + rw [← Polarity.quant_pi, ← Polarity.alt_pi, ← Rewriting.quantItr_succ_smul_castLE, ← + TransitiveRewriting.comp_app] + simp + +lemma models_sigmaInv (φ : Prenex Σ (s + 1) Empty n) (e : Fin n → V) : + V ⊧/e φ.val ↔ ∃ x, V ⊧/(x :> e) φ.sigmaInv.val := by + rw [val_sigmaInv]; exact Semiformula.eval_ex; + +lemma models_piInv (φ : Prenex Π (s + 1) Empty n) (e : Fin n → V) : + V ⊧/e φ.val ↔ ∀ x, V ⊧/(x :> e) φ.piInv.val := by + rw [val_piInv]; exact Semiformula.eval_all; + +lemma models_sigma (φ : Prenex Π s Empty (n + 1)) (e : Fin n → V) : + V ⊧/e φ.sigma.val ↔ ∃ x, V ⊧/(x :> e) φ.val := by rw [val_sigma]; exact Semiformula.eval_ex; + +lemma models_pi (φ : Prenex Σ s Empty (n + 1)) (e : Fin n → V) : + V ⊧/e φ.pi.val ↔ ∀ x, V ⊧/(x :> e) φ.val := by rw [val_pi]; exact Semiformula.eval_all; + +lemma models_altUp (φ : Prenex Γ s Empty n) (e : Fin n → V) : V ⊧/e φ.altUp.val ↔ V ⊧/e φ.val := + by + rcases Γ <;> + simp [Polarity.eq_sigma, Polarity.eq_pi, Polarity.alt_sigma, altUp, -val_piInv, + -val_sigmaInv, models_pi, models_sigma] + +lemma models_ofΔ₀ (φ : Σ₀.Semisentence n) (e : Fin n → V) : + V ⊧/e (ofΔ₀ φ Γ s).val ↔ V ⊧/e φ.val := by + induction s generalizing Γ with + | zero => rfl + | succ s ih => + rcases Γ with _ | _ + · change V ⊧/e (ofΔ₀ φ Π s).altUp.val ↔ V ⊧/e φ.val + exact (models_altUp (ofΔ₀ φ Π s) e).trans (ih (Γ := Π)) + · change V ⊧/e (ofΔ₀ φ Σ s).altUp.val ↔ V ⊧/e φ.val + exact (models_altUp (ofΔ₀ φ Σ s) e).trans (ih (Γ := Σ)) + +lemma models_verum (e : Fin n → V) : + V ⊧/e (verum : Prenex Γ s Empty n).val ↔ V ⊧/e (⊤ : ArithmeticSemisentence n) := + models_ofΔ₀ (.mkSigma ⊤ (Hierarchy.verum Σ 0 n)) e + +lemma models_falsum (e : Fin n → V) : + V ⊧/e (falsum : Prenex Γ s Empty n).val ↔ V ⊧/e (⊥ : ArithmeticSemisentence n) := + models_ofΔ₀ (.mkSigma ⊥ (Hierarchy.falsum Σ 0 n)) e + +lemma models_rel {k} (r : (ℒₒᵣ).Rel k) (v : Fin k → ArithmeticSemiterm Empty n) + (e : Fin n → V) : V ⊧/e (rel r v : Prenex Γ s Empty n).val ↔ V ⊧/e (Semiformula.rel r v) := + models_ofΔ₀ (.mkSigma (.rel r v) (Hierarchy.rel Σ 0 r v)) e + +lemma models_nrel {k} (r : (ℒₒᵣ).Rel k) (v : Fin k → ArithmeticSemiterm Empty n) + (e : Fin n → V) : + V ⊧/e (nrel r v : Prenex Γ s Empty n).val ↔ V ⊧/e (Semiformula.nrel r v) := + models_ofΔ₀ (.mkSigma (.nrel r v) (Hierarchy.nrel Σ 0 r v)) e + +variable {T : ArithmeticTheory} + +lemma provable_iff_sigmaInv {φ' : Prenex Σ (s + 1) Empty n} (hφ' : T ⊢ ∀¹* (φ ⇔ₗ φ'.val)) : + T ⊢ ∀¹* (φ ⇔ₗ ∃¹ φ'.sigmaInv.val) := + φ'.val_sigmaInv ▸ hφ' + +lemma provable_iff_piInv {φ' : Prenex Π (s + 1) Empty n} (hφ' : T ⊢ ∀¹* (φ ⇔ₗ φ'.val)) : + T ⊢ ∀¹* (φ ⇔ₗ ∀¹ φ'.piInv.val) := + φ'.val_piInv ▸ hφ' + +mutual + +/-- The ball construction in `FFL.FirstOrder.Arithmetic.Prenex`. -/ +def ball : {Γ : Polarity} → {s n : ℕ} → + ArithmeticSemiterm ξ n → Prenex Γ s ξ (n + 1) → Prenex Γ s ξ n + | _, 0 , _, u, φ => ⟨.mkSigma _ (Hierarchy.ball (Rew.bShift_positive u) φ.val_deltaZero)⟩ + | Σ, _ + 1, _, u, φ => (ball (Rew.bShift u) (bexs ‘#1 + 1’ (φ.sigmaInv.rew (Rew.subst (#0 :> + #1 :> (#·.succ.succ.succ)))))).sigma + | Π, _ + 1, _, u, φ => ∼(bexs u (∼φ)) +termination_by Γ s n _u _φ => (s, match Γ with | Σ => 0 | Π => 1) + +/-- The bexs construction in `FFL.FirstOrder.Arithmetic.Prenex`. -/ +def bexs : {Γ : Polarity} → {s n : ℕ} → + ArithmeticSemiterm ξ n → Prenex Γ s ξ (n + 1) → Prenex Γ s ξ n + | _, 0 , _, u, φ => ⟨.mkSigma _ (Hierarchy.bexs (Rew.bShift_positive u) φ.val_deltaZero)⟩ + | Σ, _ + 1, _, u, φ => (bexs (Rew.bShift u) (φ.sigmaInv.rew (Rew.subst (#1 :> #0 :> + (#·.succ.succ))))).sigma + | Π, _ + 1, _, u, φ => ∼(ball u (∼φ)) +termination_by Γ s n _u _φ => (s, match Γ with | Σ => 0 | Π => 1) + +end + + + +local notation:64 "∀'[" u "] " φ => Prenex.ball u φ +local notation:64 "∃'[" u "] " φ => Prenex.bexs u φ + +@[simp] +lemma _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.Prenex.ball_zero {u : + ArithmeticSemiterm ξ n} {φ : Prenex Γ 0 ξ (n + 1)} : + (∀'[u] φ) = ⟨.mkSigma _ (Hierarchy.ball (Rew.bShift_positive u) φ.val_deltaZero)⟩ := by + simp [ball] + + + +lemma _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.Prenex.ball_succ_sigma {u : + ArithmeticSemiterm ξ n} {φ : Prenex Σ (s + 1) ξ (n + 1)} : + (∀'[u] φ) = + (∀'[Rew.bShift u] + (∃'[‘#1 + 1’] + (φ.sigmaInv.rew (Rew.subst (#0 :> #1 :> (#·.succ.succ.succ)))))).sigma := + by rw [ball] + + + +lemma _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.Prenex.ball_succ_pi {u : + ArithmeticSemiterm ξ n} {φ : Prenex Π (s + 1) ξ (n + 1)} : + (∀'[u] φ) = ∼(∃'[u] ∼φ) := by rw [ball] + + + +@[simp] +lemma _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.Prenex.bexs_zero {u : + ArithmeticSemiterm ξ n} {φ : Prenex Γ 0 ξ (n + 1)} : + (∃'[u] φ) = ⟨.mkSigma _ (Hierarchy.bexs (Rew.bShift_positive u) φ.val_deltaZero)⟩ := by + simp [bexs] + + + +lemma _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.Prenex.bexs_succ_sigma {u : + ArithmeticSemiterm ξ n} {φ : Prenex Σ (s + 1) ξ (n + 1)} : + (∃'[u] φ) = + (∃'[Rew.bShift u] (φ.sigmaInv.rew (Rew.subst (#1 :> #0 :> (#·.succ.succ))))).sigma := + by rw [bexs] + + + +lemma _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.Prenex.bexs_succ_pi {u : + ArithmeticSemiterm ξ n} {φ : Prenex Π (s + 1) ξ (n + 1)} : + (∃'[u] φ) = ∼(∀'[u] ∼φ) := by rw [bexs] + + + +mutual + /-- The and construction in `FFL.FirstOrder.Arithmetic.Prenex`. -/ + def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.Prenex.and : {Γ : Polarity} → {s n : + ℕ} → Prenex Γ s ξ n → Prenex Γ s ξ n → Prenex Γ s ξ n + | _, 0, _, φ, ψ => ⟨.mkSigma _ (Hierarchy.and φ.val_deltaZero ψ.val_deltaZero)⟩ + | Σ, _ + 1, _, φ, ψ => + (and (∃'[‘#0 + 1’] (φ.sigmaInv.rew (Rew.subst (#0 :> (#·.succ.succ))))) + (∃'[‘#0 + 1’] (ψ.sigmaInv.rew (Rew.subst (#0 :> (#·.succ.succ)))))).sigma + | Π, _ + 1, _, φ, ψ => ∼(or (∼φ) (∼ψ)) + termination_by Γ s n φ ψ => + (s, + match Γ with + | Σ => 0 + | Π => 1) + /-- The or construction in `FFL.FirstOrder.Arithmetic.Prenex`. -/ + def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.Prenex.or : {Γ : Polarity} → {s n : + ℕ} → Prenex Γ s ξ n → Prenex Γ s ξ n → Prenex Γ s ξ n + | _, 0, _, φ, ψ => ⟨.mkSigma _ (Hierarchy.or φ.val_deltaZero ψ.val_deltaZero)⟩ + | Σ, _ + 1, _, φ, ψ => (or φ.sigmaInv ψ.sigmaInv).sigma + | Π, _ + 1, _, φ, ψ => ∼(and (∼φ) (∼ψ)) + termination_by Γ s n φ ψ => + (s, + match Γ with + | Σ => 0 + | Π => 1) +end + + + +instance : HWedge (Prenex Γ s ξ n) (Prenex Γ s ξ n) (Prenex Γ s ξ n) := + ⟨and⟩ +instance : HVee (Prenex Γ s ξ n) (Prenex Γ s ξ n) (Prenex Γ s ξ n) := + ⟨or⟩ + +@[simp] +lemma _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.Prenex.and_zero + {φ ψ : Prenex Γ 0 ξ n} : + (φ ⋏ ψ) = ⟨.mkSigma _ (Hierarchy.and φ.val_deltaZero ψ.val_deltaZero)⟩ := + by + change and φ ψ = _ + simp [and] + +lemma _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.Prenex.and_succ_sigma {φ ψ : Prenex + Σ (s + 1) ξ n} : + (φ ⋏ ψ) = + ((∃'[‘#0 + 1’] (φ.sigmaInv.rew (Rew.subst (#0 :> (#·.succ.succ))))) ⋏ + (∃'[‘#0 + 1’] (ψ.sigmaInv.rew (Rew.subst (#0 :> (#·.succ.succ)))))).sigma := + by + change and φ ψ = _ + rw [and]; rfl + + + +lemma _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.Prenex.and_succ_pi {φ ψ : Prenex Π + (s + 1) ξ n} : (φ ⋏ ψ) = ∼(∼φ ⋎ ∼ψ) := + by + change and φ ψ = _ + rw [and]; rfl + + + +@[simp] +lemma _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.Prenex.or_zero + {φ ψ : Prenex Γ 0 ξ n} : + (φ ⋎ ψ) = ⟨.mkSigma _ (Hierarchy.or φ.val_deltaZero ψ.val_deltaZero)⟩ := + by + change or φ ψ = _ + simp [or] + +lemma _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.Prenex.or_succ_sigma {φ ψ : Prenex Σ + (s + 1) ξ n} : (φ ⋎ ψ) = (φ.sigmaInv ⋎ ψ.sigmaInv).sigma := + by + change or φ ψ = _ + rw [or]; rfl + + + +lemma _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.Prenex.or_succ_pi {φ ψ : Prenex Π (s + + 1) ξ n} : (φ ⋎ ψ) = ∼(∼φ ⋏ ∼ψ) := + by + change or φ ψ = _ + rw [or]; rfl + + + +private lemma models_bexs_witness [V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] + (hb : ∀ {m : ℕ} (u : ArithmeticSemiterm Empty m) (φ : Prenex Π s Empty (m + 1)) + (e : Fin m → V), V ⊧/e (∃'[u] φ).val ↔ ∃ x < u.valb e, V ⊧/(x :> e) φ.val) + (φ : Prenex Σ (s + 1) Empty (n + 1)) (x w : V) (e : Fin n → V) : + V ⊧/(x :> w :> e) + (∃'[‘#1 + 1’] (φ.sigmaInv.rew (Rew.subst (#0 :> #1 :> (#·.succ.succ.succ))))).val + ↔ ∃ y ≤ w, V ⊧/(y :> x :> e) φ.sigmaInv.val := by + rw [hb]; + have hswap : ∀ z : V, + V ⊧/(z :> x :> w :> e) (φ.sigmaInv.rew (Rew.subst (#0 :> #1 :> (#·.succ.succ.succ)))).val ↔ + V ⊧/(z :> x :> e) φ.sigmaInv.val := by + intro z; + rw [val_rew, Semiformula.eval_rew]; + have hA : (Semiterm.val (L := ℒₒᵣ) (M := V) (z :> x :> w :> e) Empty.elim) ∘ + (Rew.subst (#0 :> #1 :> (#·.succ.succ.succ))) ∘ Semiterm.bvar + = (z :> x :> e : Fin (n + 2) → V) := by + funext i; + cases i using Fin.cases with + | zero => simp; + | succ i => + cases i using Fin.cases with + | zero => simp; + | succ i => simp; + have hB : (Semiterm.val (L := ℒₒᵣ) (M := V) (z :> x :> w :> e) Empty.elim) ∘ + (Rew.subst (#0 :> #1 :> (#·.succ.succ.succ))) ∘ Semiterm.fvar + = (Empty.elim : Empty → V) := by + funext i; exact i.elim; + rw [hA, hB]; + have hval : (‘#1 + 1’ : ArithmeticSemiterm Empty (n + 2)).valb (x :> w :> e) = w + 1 := by simp; + rw [hval]; + simp only [hswap, Arithmetic.lt_succ_iff_le]; + +mutual + +theorem _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.Prenex.models_ball : + {Γ : Polarity} → {s n : ℕ} → [V↓[ℒₒᵣ] ⊧* 𝐈Σ s] → (u : ArithmeticSemiterm Empty n) → + (φ : Prenex Γ s Empty (n + 1)) → (e : Fin n → V) → + V ⊧/e (∀'[u] φ).val ↔ ∀ x < u.valb e, V ⊧/(x :> e) φ.val + | _, 0, _, _, u, φ, e => by + simp [ball_zero, Prenex.val, Semiformula.eval_ball]; + | Σ, s + 1, _, _, u, φ, e => by + have : V↓[ℒₒᵣ] ⊧* 𝐈Σ s := modISigmaOfLe (s₂ := s + 1) (by omega); + have : V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := mod_paMinus_of_ISigma (s := s + 1); + have iha : ∀ {m : ℕ} (u : ArithmeticSemiterm Empty m) (φ : Prenex Π s Empty (m + 1)) + (e : Fin m → V), V ⊧/e (∀'[u] φ).val ↔ ∀ x < u.valb e, V ⊧/(x :> e) φ.val := + fun u φ e => models_ball u φ e; + have ihb : ∀ {m : ℕ} (u : ArithmeticSemiterm Empty m) (φ : Prenex Π s Empty (m + 1)) + (e : Fin m → V), V ⊧/e (∃'[u] φ).val ↔ ∃ x < u.valb e, V ⊧/(x :> e) φ.val := + fun u φ e => models_bexs u φ e; + rw [ball_succ_sigma (u := u) (φ := φ), models_sigma]; + simp only [iha (Rew.bShift u), Semiterm.val_bShift, models_bexs_witness ihb φ, + models_sigmaInv φ]; + constructor; + · rintro ⟨w, hw⟩ x hx; + obtain ⟨y, -, hy⟩ := hw x hx; + exact ⟨y, hy⟩; + · intro h; + have hθ : Hierarchy Σ (s + 1) φ.sigmaInv.val := φ.sigmaInv.val_hierarchy.accum Σ; + exact sigma_exists_bound_witness hθ e (u.valb e) h; + | Π, s + 1, _, _, u, φ, e => by + have ih : ∀ {m : ℕ} (u : ArithmeticSemiterm Empty m) (φ : Prenex Σ (s + 1) Empty (m + 1)) + (e : Fin m → V), V ⊧/e (∃'[u] φ).val ↔ ∃ x < u.valb e, V ⊧/(x :> e) φ.val := + fun u φ e => models_bexs u φ e; + have hthis : V ⊧/e (∃'[u] ∼φ).val ↔ ∃ x < u.valb e, V ⊧/(x :> e) (∼φ).val := ih u (∼φ) e; + have hval : (∀'[u] φ).val = ∼(∃'[u] ∼φ).val := by + rw [ball_succ_pi (u := u) (φ := φ)]; + exact val_neg (∃'[u] ∼φ); + rw [hval]; + simp only [val_neg, LogicalConnective.HomClass.map_neg, LogicalConnective.Prop.neg_eq] + at hthis ⊢; + grind; +termination_by Γ s n _inst _u _φ _e => (s, match Γ with | Σ => 0 | Π => 1) + +theorem _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.Prenex.models_bexs : + {Γ : Polarity} → {s n : ℕ} → [V↓[ℒₒᵣ] ⊧* 𝐈Σ s] → (u : ArithmeticSemiterm Empty n) → + (φ : Prenex Γ s Empty (n + 1)) → (e : Fin n → V) → + V ⊧/e (∃'[u] φ).val ↔ ∃ x < u.valb e, V ⊧/(x :> e) φ.val + | _, 0, _, _, u, φ, e => by + simp [bexs_zero, Prenex.val, Semiformula.eval_bexs]; + | Σ, s + 1, n, _, u, φ, e => by + have : V↓[ℒₒᵣ] ⊧* 𝐈Σ s := modISigmaOfLe (s₂ := s + 1) (by omega); + have ih : ∀ {m : ℕ} (u : ArithmeticSemiterm Empty m) (φ : Prenex Π s Empty (m + 1)) + (e : Fin m → V), V ⊧/e (∃'[u] φ).val ↔ ∃ x < u.valb e, V ⊧/(x :> e) φ.val := + fun u φ e => models_bexs u φ e; + set φ₁' := φ.sigmaInv; + set φ₁ := φ₁'.val; + set v := #1 :> #0 :> fun i => #(i.succ.succ) with hv; + let φ₂' := φ₁'.rew (Rew.subst v); + have hswap : ∀ (x b : V), V ⊧/(x :> b :> e) φ₂'.val ↔ V ⊧/(b :> x :> e) φ₁ := by + intro x b; + rw [val_rew, Semiformula.eval_rew]; + have hA : (Semiterm.val (M := V) (x :> b :> e) Empty.elim) ∘ (Rew.subst v) ∘ Semiterm.bvar + = (b :> x :> e : Fin (n + 2) → V) := by + funext i; + cases i using Fin.cases with + | zero => simp [hv]; + | succ i => + cases i using Fin.cases with + | zero => simp [hv]; + | succ i => simp [hv]; + have hB : (Semiterm.val (M := V) (x :> b :> e) Empty.elim) ∘ (Rew.subst v) ∘ Semiterm.fvar + = (Empty.elim : Empty → V) := by + funext i; exact i.elim; + rw [hA, hB]; + rw [bexs_succ_sigma (u := u) (φ := φ), val_sigma] + change (∃ b, V ⊧/(b :> e) (∃'[Rew.bShift u] φ₂').val) ↔ ∃ x < u.valb e, V ⊧/(x :> e) φ.val; + simp only [ih (Rew.bShift u) φ₂', Semiterm.val_bShift, hswap, models_sigmaInv φ]; + grind; + | Π, s + 1, _, _, u, φ, e => by + have ih : ∀ {m : ℕ} (u : ArithmeticSemiterm Empty m) (φ : Prenex Σ (s + 1) Empty (m + 1)) + (e : Fin m → V), V ⊧/e (∀'[u] φ).val ↔ ∀ x < u.valb e, V ⊧/(x :> e) φ.val := + fun u φ e => models_ball u φ e; + have hthis : V ⊧/e (∀'[u] ∼φ).val ↔ ∀ x < u.valb e, V ⊧/(x :> e) (∼φ).val := ih u (∼φ) e; + have hval : (∃'[u] φ).val = ∼(∀'[u] ∼φ).val := by + rw [bexs_succ_pi (u := u) (φ := φ)]; + exact val_neg (∀'[u] ∼φ); + rw [hval]; + simp only [val_neg, LogicalConnective.HomClass.map_neg, LogicalConnective.Prop.neg_eq] + at hthis ⊢; + grind; +termination_by Γ s n _inst _u _φ _e => (s, match Γ with | Σ => 0 | Π => 1) + +end + +mutual + +theorem _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.Prenex.models_and : + {Γ : Polarity} → {s n : ℕ} → [V↓[ℒₒᵣ] ⊧* 𝐈Σ s] → (φ ψ : Prenex Γ s Empty n) → (e : Fin n → V) → + V ⊧/e (φ ⋏ ψ).val ↔ V ⊧/e φ.val ∧ V ⊧/e ψ.val + | _, 0, _, _, φ, ψ, e => by + simp [and_zero, Prenex.val]; + | Σ, s + 1, n, _, φ, ψ, e => by + have : V↓[ℒₒᵣ] ⊧* 𝐈Σ s := modISigmaOfLe (s₂ := s + 1) (by omega); + have : V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := mod_paMinus_of_ISigma (s := s); + have iha : ∀ {m : ℕ} (φ ψ : Prenex Π s Empty m) (e : Fin m → V), + V ⊧/e (φ ⋏ ψ).val ↔ V ⊧/e φ.val ∧ V ⊧/e ψ.val := + fun φ ψ e => models_and φ ψ e; + rw [and_succ_sigma (φ := φ) (ψ := ψ), models_sigma]; + set φ₂' := φ.sigmaInv.rew (Rew.subst (#0 :> (#·.succ.succ))); + set ψ₂' := ψ.sigmaInv.rew (Rew.subst (#0 :> (#·.succ.succ))); + have hα_eval : ∀ z : V, + V ⊧/(z :> e) (∃'[‘#0 + 1’] φ₂').val ↔ ∃ x ≤ z, V ⊧/(x :> e) φ.sigmaInv.val := by + intro z; + rw [models_bexs ‘#0 + 1’ φ₂' (z :> e)]; + simp only [φ₂', val_rew, Semiformula.eval_insert1]; + simp [Arithmetic.lt_succ_iff_le]; + have hβ_eval : ∀ z : V, + V ⊧/(z :> e) (∃'[‘#0 + 1’] ψ₂').val ↔ ∃ x ≤ z, V ⊧/(x :> e) ψ.sigmaInv.val := by + intro z; + rw [models_bexs ‘#0 + 1’ ψ₂' (z :> e)]; + simp only [ψ₂', val_rew, Semiformula.eval_insert1]; + simp [Arithmetic.lt_succ_iff_le]; + simp only [iha (∃'[‘#0 + 1’] φ₂') (∃'[‘#0 + 1’] ψ₂'), models_sigmaInv φ, models_sigmaInv ψ, + hα_eval, hβ_eval]; + constructor; + · rintro ⟨z, ⟨x, -, hx⟩, ⟨y, -, hy⟩⟩; + exact ⟨⟨x, hx⟩, ⟨y, hy⟩⟩; + · rintro ⟨⟨x, hx⟩, ⟨y, hy⟩⟩; + exact ⟨max x y, ⟨x, le_max_left x y, hx⟩, ⟨y, le_max_right x y, hy⟩⟩; + | Π, s + 1, _, _, φ, ψ, e => by + have ih : ∀ {m : ℕ} (φ ψ : Prenex Σ (s + 1) Empty m) (e : Fin m → V), + V ⊧/e (φ ⋎ ψ).val ↔ V ⊧/e φ.val ∨ V ⊧/e ψ.val := + fun φ ψ e => models_or φ ψ e; + have hthis : V ⊧/e (∼φ ⋎ ∼ψ).val ↔ V ⊧/e (∼φ).val ∨ V ⊧/e (∼ψ).val := ih (∼φ) (∼ψ) e; + have hval : (φ ⋏ ψ).val = ∼(∼φ ⋎ ∼ψ).val := by + rw [and_succ_pi (φ := φ) (ψ := ψ)]; + exact val_neg (∼φ ⋎ ∼ψ); + rw [hval]; + simp only [val_neg, LogicalConnective.HomClass.map_neg, LogicalConnective.Prop.neg_eq] + at hthis ⊢; + grind; +termination_by Γ s n _inst _φ _ψ _e => (s, match Γ with | Σ => 0 | Π => 1) + +theorem _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.Prenex.models_or : + {Γ : Polarity} → {s n : ℕ} → [V↓[ℒₒᵣ] ⊧* 𝐈Σ s] → (φ ψ : Prenex Γ s Empty n) → (e : Fin n → V) → + V ⊧/e (φ ⋎ ψ).val ↔ V ⊧/e φ.val ∨ V ⊧/e ψ.val + | _, 0, _, _, φ, ψ, e => by + simp [or_zero, Prenex.val]; + | Σ, s + 1, _, _, φ, ψ, e => by + have : V↓[ℒₒᵣ] ⊧* 𝐈Σ s := modISigmaOfLe (s₂ := s + 1) (by omega); + have ih : ∀ {m : ℕ} (φ ψ : Prenex Π s Empty m) (e : Fin m → V), + V ⊧/e (φ ⋎ ψ).val ↔ V ⊧/e φ.val ∨ V ⊧/e ψ.val := + fun φ ψ e => models_or φ ψ e; + rw [or_succ_sigma (φ := φ) (ψ := ψ), models_sigma]; + simp only [ih φ.sigmaInv ψ.sigmaInv, models_sigmaInv φ, models_sigmaInv ψ]; + exact exists_or; + | Π, s + 1, _, _, φ, ψ, e => by + have ih : ∀ {m : ℕ} (φ ψ : Prenex Σ (s + 1) Empty m) (e : Fin m → V), + V ⊧/e (φ ⋏ ψ).val ↔ V ⊧/e φ.val ∧ V ⊧/e ψ.val := + fun φ ψ e => models_and φ ψ e; + have hthis : V ⊧/e (∼φ ⋏ ∼ψ).val ↔ V ⊧/e (∼φ).val ∧ V ⊧/e (∼ψ).val := ih (∼φ) (∼ψ) e; + have hval : (φ ⋎ ψ).val = ∼(∼φ ⋏ ∼ψ).val := by + rw [or_succ_pi (φ := φ) (ψ := ψ)]; + exact val_neg (∼φ ⋏ ∼ψ); + rw [hval]; + simp only [val_neg, LogicalConnective.HomClass.map_neg, LogicalConnective.Prop.neg_eq] + at hthis ⊢; + grind; +termination_by Γ s n _inst _φ _ψ _e => (s, match Γ with | Σ => 0 | Π => 1) + +end + +/-- The exs construction in `FFL.FirstOrder.Arithmetic.Prenex`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.Prenex.exs (φ : Prenex Σ (s + 1) ξ (n + + 1)) : Prenex Σ (s + 1) ξ n := + (∃'[‘#0 + 1’] + (∃'[‘#1 + 1’] (φ.sigmaInv.rew (Rew.subst (#0 :> #1 :> (#·.succ.succ.succ)))))).sigma + + + +/-- The all construction in `FFL.FirstOrder.Arithmetic.Prenex`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.Prenex.all (φ : Prenex Π (s + 1) ξ (n + + 1)) : Prenex Π (s + 1) ξ n := + ∼(exs (∼φ)) + + + +local prefix:64 "∃' " => Prenex.exs +local prefix:64 "∀' " => Prenex.all + +lemma _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.Prenex.models_exs [V↓[ℒₒᵣ] ⊧* 𝐈Σs] + (φ : Prenex Σ (s + 1) Empty (n + 1)) (e : Fin n → V) : + V ⊧/e (∃' φ).val ↔ ∃ x, V ⊧/(x :> e) φ.val := + by + have : V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := mod_paMinus_of_ISigma (s := s); + change + V ⊧/e + (∃'[‘#0 + 1’] + (∃'[‘#1 + 1’] + (φ.sigmaInv.rew (Rew.subst (#0 :> #1 :> (#·.succ.succ.succ)))))).sigma.val ↔ + ∃ x, V ⊧/(x :> e) φ.val; + rw [models_sigma]; + have hβeval : + ∀ z : V, + V ⊧/(z :> e) + (∃'[‘#0 + 1’] + (∃'[‘#1 + 1’] + (φ.sigmaInv.rew (Rew.subst (#0 :> #1 :> (#·.succ.succ.succ)))))).val ↔ + ∃ y ≤ z, + V ⊧/(y :> z :> e) + (∃'[‘#1 + 1’] (φ.sigmaInv.rew (Rew.subst (#0 :> #1 :> (#·.succ.succ.succ))))).val := + by + intro z; rw [models_bexs]; + have hval : (‘#0 + 1’ : ArithmeticSemiterm Empty (n + 1)).valb (z :> e) = z + 1 := by simp; + rw [hval]; simp only [Arithmetic.lt_succ_iff_le]; + have hαeval : + ∀ y z : V, + V ⊧/(y :> z :> e) + (∃'[‘#1 + 1’] (φ.sigmaInv.rew (Rew.subst (#0 :> #1 :> (#·.succ.succ.succ))))).val ↔ + ∃ x ≤ z, V ⊧/(x :> y :> e) φ.sigmaInv.val := + fun y z => models_bexs_witness models_bexs φ y z e; + simp only [hβeval, hαeval, models_sigmaInv φ]; constructor; + · rintro ⟨z, y, -, x, -, hx⟩; exact ⟨y, x, hx⟩; + · rintro ⟨y, x, hx⟩; exact ⟨max x y, y, le_max_right x y, x, le_max_left x y, hx⟩; + + + +lemma _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.Prenex.models_all [V↓[ℒₒᵣ] ⊧* 𝐈Σs] + (φ : Prenex Π (s + 1) Empty (n + 1)) (e : Fin n → V) : + V ⊧/e (∀' φ).val ↔ ∀ x, V ⊧/(x :> e) φ.val := + by + have hthis : V ⊧/e (∃' ∼φ).val ↔ ∃ x, V ⊧/(x :> e) (∼φ).val := models_exs (∼φ) e; + have hval : (∀' φ).val = ∼(∃' ∼φ).val := by unfold all; exact val_neg (∃' ∼φ); + rw [hval]; + simp only [val_neg, LogicalConnective.HomClass.map_neg, + LogicalConnective.Prop.neg_eq] at hthis ⊢; + grind; + + + +theorem _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.Prenex.models_exists_prenex {Γ : + Polarity} {s n : ℕ} {φ : ArithmeticSemisentence n} (h : + Hierarchy Γ s φ) : + ∃ φ' : Prenex Γ s Empty n, + ∀ (V : Type*) [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐈Σ s] (e : Fin n → V), V ⊧/e φ ↔ V ⊧/e φ'.val := by + induction h with + | verum Γ s n => + use verum; + intro V _ _ e; + exact (models_verum e).symm; + | falsum Γ s n => + use falsum; + intro V _ _ e; + exact (models_falsum e).symm; + | rel Γ s r v => + use rel r v; + intro V _ _ e; + exact (models_rel r v e).symm; + | nrel Γ s r v => + use nrel r v; + intro V _ _ e; + exact (models_nrel r v e).symm; + | and _ _ ihφ ihψ => + obtain ⟨φ', hφ'⟩ := ihφ; + obtain ⟨ψ', hψ'⟩ := ihψ; + use φ' ⋏ ψ'; + intro V _ _ e; + rw [models_and φ' ψ' e]; + simp only [LogicalConnective.HomClass.map_and, LogicalConnective.Prop.and_eq]; + exact and_congr (hφ' V e) (hψ' V e); + | or _ _ ihφ ihψ => + obtain ⟨φ', hφ'⟩ := ihφ; + obtain ⟨ψ', hψ'⟩ := ihψ; + use φ' ⋎ ψ'; + intro V _ _ e; + rw [models_or φ' ψ' e]; + simp only [LogicalConnective.HomClass.map_or, LogicalConnective.Prop.or_eq]; + exact or_congr (hφ' V e) (hψ' V e); + | ball pos _ ih => + obtain ⟨u, rfl⟩ := Rew.positive_iff.mp pos; + obtain ⟨φ', hφ'⟩ := ih; + use ∀'[u] φ'; + intro V _ _ e; + rw [models_ball u φ' e]; + simp only [Semiformula.eval_ball]; + exact forall_congr' fun x => (imp_congr Iff.rfl (hφ' V (x :> e))).trans (by simp); + | bexs pos _ ih => + obtain ⟨u, rfl⟩ := Rew.positive_iff.mp pos; + obtain ⟨φ', hφ'⟩ := ih; + use ∃'[u] φ'; + intro V _ _ e; + rw [models_bexs u φ' e]; + simp only [Semiformula.eval_bexs]; + exact exists_congr fun x => (and_congr Iff.rfl (hφ' V (x :> e))).trans (by simp); + | @exs s n φ _ ih => + obtain ⟨φ', hφ'⟩ := ih; + use ∃' φ'; + intro V _ _ e; + have : V↓[ℒₒᵣ] ⊧* 𝐈Σ s := modISigmaOfLe (s₂ := s + 1) (by omega); + rw [models_exs φ' e, Semiformula.eval_ex]; + exact exists_congr fun x => hφ' V (x :> e); + | @all s n φ _ ih => + obtain ⟨φ', hφ'⟩ := ih; + use ∀' φ'; + intro V _ _ e; + have : V↓[ℒₒᵣ] ⊧* 𝐈Σ s := modISigmaOfLe (s₂ := s + 1) (by omega); + rw [models_all φ' e, Semiformula.eval_all]; + exact forall_congr' fun x => hφ' V (x :> e); + | @sigma s n φ _ ih => + obtain ⟨φ', hφ'⟩ := ih; + use φ'.sigma; + intro V _ _ e; + have : V↓[ℒₒᵣ] ⊧* 𝐈Σ s := modISigmaOfLe (s₂ := s + 1) (by omega); + rw [models_sigma φ' e, Semiformula.eval_ex]; + exact exists_congr fun x => hφ' V (x :> e); + | @pi s n φ _ ih => + obtain ⟨φ', hφ'⟩ := ih; + use φ'.pi; + intro V _ _ e; + have : V↓[ℒₒᵣ] ⊧* 𝐈Σ s := modISigmaOfLe (s₂ := s + 1) (by omega); + rw [models_pi φ' e, Semiformula.eval_all]; + exact forall_congr' fun x => hφ' V (x :> e); + | @dummy_sigma s n φ _ ih => + obtain ⟨φ', hφ'⟩ := ih; + use (∀' φ').altUp; + intro V _ _ e; + have : V↓[ℒₒᵣ] ⊧* 𝐈Σ s := modISigmaOfLe (show s ≤ s + 1 + 1 by omega); + have : V↓[ℒₒᵣ] ⊧* 𝐈Σ (s + 1) := modISigmaOfLe (show s + 1 ≤ s + 1 + 1 by omega); + exact Semiformula.eval_all.trans + ((forall_congr' fun x => hφ' V (x :> e)).trans + ((models_all φ' e).symm.trans (models_altUp (∀' φ') e).symm)); + | @dummy_pi s n φ _ ih => + obtain ⟨φ', hφ'⟩ := ih; + use (∃' φ').altUp; + intro V _ _ e; + have : V↓[ℒₒᵣ] ⊧* 𝐈Σ s := modISigmaOfLe (show s ≤ s + 1 + 1 by omega); + have : V↓[ℒₒᵣ] ⊧* 𝐈Σ (s + 1) := modISigmaOfLe (show s + 1 ≤ s + 1 + 1 by omega); + exact Semiformula.eval_ex.trans + ((exists_congr fun x => hφ' V (x :> e)).trans + ((models_exs φ' e).symm.trans (models_altUp (∃' φ') e).symm)); + + + + + +end Prenex + +theorem _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.exists_prenex_of_hierarchy {Γ : + Polarity} {s : ℕ} (T : ArithmeticTheory) [𝐈Σs ≼ T] + {n : ℕ} {φ : ArithmeticSemisentence n} (h : Hierarchy Γ s φ) : + ∃ φ' : Prenex Γ s Empty n, T ⊢ ∀¹* (φ ⇔ₗ φ'.val) := by + have : 𝐄𝐐 ℒₒᵣ ≼ T := eq_weakerThan_of_ISigma (s := s); + obtain ⟨φ', hφ'⟩ := Prenex.models_exists_prenex h; use φ'; apply provable_iff_of_models_iff; + intro V _ _ e; + have : V↓[ℒₒᵣ] ⊧* 𝐈Σs := models_of_subtheory (T := 𝐈Σs) (U := T) (inferInstance); + exact hφ' V e; + + + +theorem _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.exists_matrix_provable {Γ : + Polarity} {s : ℕ} (T : ArithmeticTheory) [𝐈Σs ≼ T] {n : ℕ} + {φ : ArithmeticSemisentence n} (h : Hierarchy Γ s φ) : + ∃ φ₀ : Σ₀.Semisentence (n + s), T ⊢ ∀¹* (φ ⇔ₗ φ₀.val.toPrenex Γ s) := by + obtain ⟨_, hφ'⟩ := exists_prenex_of_hierarchy T h; exact ⟨_, by simpa [Prenex.val] using hφ'⟩; + + + +section +variable {Γ : Polarity} {s n : ℕ} {ξ : Type*} + +@[simp, grind .] +lemma _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.Prenex.val_strictHierarchy {φ : + Prenex Γ s ξ n} : StrictHierarchy Γ s φ.val := + StrictHierarchy.toPrenex_of_deltaZero φ.matrix.sigma_prop + + + +theorem + _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.exists_strictHierarchy_of_hierarchy (T + : ArithmeticTheory) [𝐈Σs ≼ T] + {φ : ArithmeticSemisentence n} (h : Hierarchy Γ s φ) : + ∃ ψ : ArithmeticSemisentence n, StrictHierarchy Γ s ψ ∧ T ⊢ ∀¹* (φ ⇔ₗ ψ) := by + obtain ⟨φ', hφ'⟩ := exists_prenex_of_hierarchy T h; + exact ⟨φ'.val, Prenex.val_strictHierarchy, hφ'⟩; + + + +end + +end Arithmetic + +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Q/Basic.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Q/Basic.lean new file mode 100644 index 000000000..f841a2e0a --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Q/Basic.lean @@ -0,0 +1,342 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.R0.Basic +public import Mathlib.Data.ENat.Basic + +/-! Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section +/-! +# Robinson's theory $\mathsf{Q}$ +-/ + +noncomputable section + +namespace FFL +namespace FirstOrder +namespace Arithmetic + +/-- Data and laws for 𝐐 in `𝐐`. -/ +inductive RobinsonQ : ArithmeticTheory + | equal : ∀ φ ∈ 𝐄𝐐 ℒₒᵣ, RobinsonQ φ + | succNeZero : RobinsonQ “∀ a, a + 1 ≠ 0” + | succInj : RobinsonQ “∀ a b, a + 1 = b + 1 → a = b” + | zeroOrSucc : RobinsonQ “∀ a, a = 0 ∨ ∃ b, a = b + 1” + | addZero : RobinsonQ “∀ a, a + 0 = a” + | addSucc : RobinsonQ “∀ a b, a + (b + 1) = (a + b) + 1” + | mulZero : RobinsonQ “∀ a, a * 0 = 0” + | mulSucc : RobinsonQ “∀ a b, a * (b + 1) = a * b + a” + | ltDef : RobinsonQ “∀ a b, a < b ↔ ∃ c, a + (c + 1) = b” + +/-- The «term𝐐» construction in `FFL.FirstOrder.Arithmetic`. -/ +notation "𝐐" => RobinsonQ + +namespace RobinsonQ + +open ORingStructure + +@[simp] +instance : ℕ↓[ℒₒᵣ] ⊧* 𝐐 := + ⟨by + intro σ h + cases h + case + ltDef => + suffices ∀ a b : ℕ, a < b ↔ ∃ c : ℕ, a + (c + 1) = b by simpa [models_iff] + intro a b + constructor; · intro h; use (b - a - 1); omega; + · rintro ⟨c, hc⟩; simp [← hc]; + case zeroOrSucc => + simp [models_iff] + omega; + case equal h => + suffices σ.Evalb ![] by simpa [models_iff] + have : ℕ↓[ℒₒᵣ] ⊧* (𝐄𝐐 ℒₒᵣ : ArithmeticTheory) := inferInstance + exact models_theory_iff.mp this _ h + repeat case _ => simp [models_iff, add_assoc, mul_add]⟩ + +instance : 𝐄𝐐 ℒₒᵣ ≼ 𝐐 := + Entailment.WeakerThan.ofSubset <| fun φ hp ↦ equal φ hp + +end RobinsonQ + +variable {M : Type*} [ORingStructure M] [M↓[ℒₒᵣ] ⊧* 𝐐] + +@[simp] +protected lemma succ_ne_zero : ∀ a : M, a + 1 ≠ 0 := by + simpa [models_iff] using Theory.models M _ RobinsonQ.succNeZero + +lemma succ_inj {a b : M} : a + 1 = b + 1 → a = b := + by + have := by simpa [models_iff] using Theory.models M _ RobinsonQ.succInj + exact this a b + +@[simp] +protected lemma add_zero {a : M} : a + 0 = a := + by + have := by simpa [models_iff] using Theory.models M _ RobinsonQ.addZero + exact this a + +protected lemma add_succ (a b : M) : a + (b + 1) = a + b + 1 := + by + have := by simpa [models_iff] using Theory.models M _ RobinsonQ.addSucc + exact this a b + +@[simp] +protected lemma mul_zero (a : M) : a * 0 = 0 := + by + have := by simpa [models_iff] using Theory.models M _ RobinsonQ.mulZero + exact this a + +protected lemma mul_succ : ∀ a b : M, a * (b + 1) = a * b + a := by + simpa [models_iff] using Theory.models M _ RobinsonQ.mulSucc + +lemma zero_or_succ (a : M) : a = 0 ∨ ∃ b : M, a = b + 1 := + by + have := by simpa [models_iff] using Theory.models M _ RobinsonQ.zeroOrSucc + exact this a + +lemma exists_succ_of_ne_zero {a : M} (ha : a ≠ 0) : ∃ b : M, a = b + 1 := by + have := zero_or_succ (a := a); tauto; + +lemma exists_succ_of_ne_zero' {a : M} (ha : a ≠ 0) : ∃ b : M, b + 1 = a := by + obtain ⟨b, rfl⟩ := exists_succ_of_ne_zero ha; use b; + +protected lemma lt_def {a b : M} : a < b ↔ ∃ c : M, a + (c + 1) = b := + by + have := by simpa [models_iff] using Theory.models M _ RobinsonQ.ltDef + exact this a b + +@[simp] +lemma one_ne_zero : (1 : M) ≠ 0 := by + by_contra h; + apply Arithmetic.succ_ne_zero (M := M) (a := 0); + rw [h]; + apply Arithmetic.add_zero; + +lemma one_add_zero : (1 : M) + 0 = 1 := by simp; + +@[simp] +lemma zero_add_one : (0 : M) + 1 = 1 := by + obtain ⟨a, ha⟩ := exists_succ_of_ne_zero' (M := M) one_ne_zero; convert ha; by_contra; + obtain ⟨b, rfl⟩ := exists_succ_of_ne_zero' (M := M) (a := a) (by tauto); + apply Arithmetic.succ_ne_zero (M := M) (a := (0 + b)); apply succ_inj; + calc + 0 + b + 1 + 1 = 0 + (b + 1) + 1 := by rw [Arithmetic.add_succ (a := 0) (b := b)]; + _ = 0 + (b + 1 + 1) := by rw [Arithmetic.add_succ (a := 0) (b := (b + 1))]; + _ = 0 + 1 := by rw [ha]; + +lemma succ_inj_zero {a : M} : a + 1 = 1 → a = 0 := by nth_rw 2 [← zero_add_one]; apply succ_inj; + +lemma eq_zero_of_eq_add_zero {a b : M} (h : a + b = 0) : a = 0 ∧ b = 0 := by + classical + by_contra hz + have hab : a ≠ 0 ∨ b ≠ 0 := not_and_or.mp hz + suffices a + b ≠ 0 from this h + rcases hab with ha | hb + · obtain ⟨c, rfl⟩ := exists_succ_of_ne_zero (M := M) ha; by_cases hb0 : b = 0; + · subst hb0; rwa [Arithmetic.add_zero] + · obtain ⟨d, rfl⟩ := exists_succ_of_ne_zero (M := M) hb0; + rw [Arithmetic.add_succ (a := c + 1) (b := d)]; apply Arithmetic.succ_ne_zero; + · obtain ⟨c, rfl⟩ := exists_succ_of_ne_zero' (M := M) hb; rw [Arithmetic.add_succ]; simp; + +@[simp] +lemma one_mul_one : (1 : M) * 1 = 1 := + calc + (1 : M) * 1 = 1 * (0 + 1) := by simp + _ = 1 * 0 + 1 := by rw [Arithmetic.mul_succ] + _ = 1 := by simp + +@[simp] +lemma zero_mul_one : (0 : M) * 1 = 0 := + calc + (0 : M) * 1 = 0 * (0 + 1) := by simp + _ = 0 * 0 + 0 := by rw [Arithmetic.mul_succ] + _ = 0 := by simp + +@[simp] +lemma not_le_zero {a : M} : ¬a < 0 := by + apply Arithmetic.lt_def.not.mpr; + push Not; + intro b; + calc + a + (b + 1) = (a + b) + 1 := Arithmetic.add_succ _ _ + _ ≠ 0 := by simp; + +lemma lt_of_not_zero {a b : M} (ha : b ≠ 0) : a < a + b := by + apply Arithmetic.lt_def.mpr; + obtain ⟨b, rfl⟩ := exists_succ_of_ne_zero (M := M) ha; + use b; + +@[simp] +lemma iff_le_one_eq_zero {a : M} : a < 1 ↔ a = 0 := + by + constructor; + · rw [Arithmetic.lt_def]; rintro ⟨b, hb⟩; apply eq_zero_of_eq_add_zero (b := b) ?_ |>.1; + apply succ_inj_zero; rwa [Arithmetic.add_succ] at hb; + · rintro rfl; apply Arithmetic.lt_def.mpr; use 0; simp; + +open ORingStructure + +@[simp] +lemma numeral_zero_add (n : ℕ) : 0 + (numeral n : M) = numeral n := by + match n with + | 0 => simp + | 1 => simp + | n + 2 => simp [ORingStructure.numeral, Arithmetic.add_succ, numeral_zero_add (n + 1)] + +lemma numeral_add_one (n : ℕ) : (numeral n : M) + 1 = numeral (n + 1) := by + match n with + | 0 => simp; + | n + 1 => rfl + +lemma numeral_add (n m : ℕ) : (numeral n : M) + numeral m = numeral (n + m) := by + match m with + | 0 => simp + | 1 => simp [numeral_add_one] + | m + 2 => + calc + (numeral n : M) + (numeral (m + 1) + 1) = (numeral n + numeral (m + 1)) + 1 := + Arithmetic.add_succ _ _ + _ = numeral (n + (m + 1)) + 1 := by rw [numeral_add n (m + 1)] + _ = numeral (n + (m + 2)) := by simp [← add_assoc]; rfl + +lemma numeral_zero_mul {n : ℕ} : 0 * (numeral n : M) = 0 := by + match n with + | 0 => simp + | 1 => simp + | n + 2 => + calc + (0 : M) * numeral (n + 2) = 0 * (numeral (n + 1) + 1) := rfl + _ = 0 * numeral (n + 1) + 0 := by rw [Arithmetic.mul_succ] + _ = 0 := by simp [numeral_zero_mul] + +lemma numeral_mul_one {n : ℕ} : (numeral n : M) * 1 = numeral n := + calc + (numeral n : M) * 1 = numeral n * (0 + 1) := by simp + _ = numeral n * 0 + numeral n := by rw [Arithmetic.mul_succ] + _ = numeral n := by simp + +lemma numeral_mul {n m : ℕ} : (numeral n : M) * numeral m = numeral (n * m) := by + match m with + | 0 => simp + | 1 => simp [numeral_mul_one] + | m + 2 => + calc + (numeral n : M) * (numeral (m + 1) + 1) = numeral n * numeral (m + 1) + numeral n := by + rw [Arithmetic.mul_succ] + _ = numeral (n * (m + 1)) + numeral n := by rw [numeral_mul] + _ = numeral (n * (m + 2)) := by simp [numeral_add, mul_add, mul_two, ← add_assoc] + +lemma exists_numeral_of_ne_zero {n : ℕ} (h : n ≠ 0) : ∃ m, (numeral n : M) = (numeral (m + 1)) := by + match n with + | 0 => contradiction + | 1 => use 0; + | n + 2 => + obtain ⟨m, hm⟩ := exists_numeral_of_ne_zero (n := n + 1) (by omega); + use m + 1; + calc + numeral (n + 2) = numeral (n + 1 + 1) := by simp; + _ = numeral (n + 1) + numeral 1 := by simp [numeral_add_one]; + _ = numeral (m + 1) + numeral 1 := by rw [hm]; + +lemma numeral_zero_succ_ne {n : ℕ} : (numeral 0 : M) ≠ (numeral (n + 1)) := by + apply Ne.symm; + simp [←numeral_add]; + +lemma numeral_succ_inj {n m : ℕ} (h : (numeral (n + 1) : M) = numeral (m + 1)) : (numeral n : M) + = (numeral m : M) := by + rw [←numeral_add_one, ←numeral_add_one] at h; + apply succ_inj h; + +lemma numeral_ne_of_ne {n m : ℕ} (h : n ≠ m) : (numeral n : M) ≠ numeral m := by + match n, m with + | 0, m => + obtain ⟨k, hk⟩ := exists_numeral_of_ne_zero (M := M) h.symm; + rw [hk]; + exact numeral_zero_succ_ne; + | n + 1, 0 => + apply Ne.symm; + exact numeral_zero_succ_ne; + | n + 1, m + 1 => + have := numeral_ne_of_ne (n := n) (m := m) (by omega); + contrapose! this; + apply numeral_succ_inj this; + +lemma numeral_lt_of_lt {n m : ℕ} (h : n < m) : (numeral n : M) < numeral m := by + apply Arithmetic.lt_def.mpr; obtain ⟨k, rfl, hk⟩ := Arithmetic.lt_def.mp h; + use (numeral k : M); + calc + (numeral n + (numeral k + 1) : M) = numeral n + (numeral k + numeral 1) := by simp; + _ = numeral n + (numeral (k + 1)) := by rw [numeral_add]; + _ = numeral (n + (k + 1)) := by rw [numeral_add]; + +lemma numeral_lt_add {n m : ℕ} (hm : m ≠ 0) : (numeral n : M) < numeral n + numeral m := by + rw [numeral_add]; apply numeral_lt_of_lt; omega; + +lemma numeral_lt_succ {n : ℕ} : (numeral n : M) < numeral n + numeral 1 := + numeral_lt_add <| by omega; + +lemma iff_lt_numeral_exists_numeral {n : ℕ} {x : M} : x < numeral n ↔ ∃ m < n, x = numeral m := + by + match n with + | 0 => simp; + | 1 => simp; + | n + 2 => + constructor; + · intro h; obtain ⟨a, ha⟩ := Arithmetic.lt_def.mp h; by_cases ha0 : a = 0; + · subst ha0; use n + 1; constructor; · omega; + · apply succ_inj; have ha' : (x : M) + 1 = numeral (n + 2) := by simpa using ha + rw [ha', numeral_add_one]; + · obtain ⟨m, hm, rfl⟩ := + iff_lt_numeral_exists_numeral (x := x) (n := n + 1) |>.mp <| + by + have ha : x + a = numeral (n + 1) := succ_inj <| by rwa [Arithmetic.add_succ] at ha; + rw [← ha]; apply lt_of_not_zero ha0; + use m; constructor; · omega; + · rfl; + · rintro ⟨m, hm, rfl⟩; apply numeral_lt_of_lt; exact hm; + +namespace R0 + +instance : M↓[ℒₒᵣ] ⊧* 𝐑₀ := + models_theory_iff.mpr <| by + intro φ h + rcases h + case equal h => + have : M↓[ℒₒᵣ] ⊧* (𝐄𝐐 ℒₒᵣ : ArithmeticTheory) := inferInstance + exact models_theory_iff.mp this _ h + case Ω₁ n m => simp [models_iff, numeral_add] + case Ω₂ n m => simp [models_iff, numeral_mul] + case Ω₃ + n => + suffices ∀ (x : M), x < numeral n ↔ ∃ i < n, x = numeral i by simpa [models_iff]; + apply iff_lt_numeral_exists_numeral; + +end R0 + +instance : 𝐑₀ ≼ 𝐐 := + weakerThan_of_models.{0} _ _ fun _ _ _ ↦ inferInstance + +instance : 𝐑₀ ≺ 𝐐 := + Entailment.StrictlyWeakerThan.of_unprovable_provable R0.unprovable_addZero + (Entailment.by_axm RobinsonQ.addZero) + +end Arithmetic +end FirstOrder +end FFL + +end +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/R0/Basic.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/R0/Basic.lean new file mode 100644 index 000000000..0311cee9e --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/R0/Basic.lean @@ -0,0 +1,322 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Basic + +/-! Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section +/-! +# Cobham's theory $\mathsf{R_0}$ + +-/ + +noncomputable section + +namespace FFL +namespace FirstOrder +namespace Arithmetic + +/-- Data and laws for 𝐑₀ in `𝐑₀`. -/ +inductive R0 : ArithmeticTheory + | equal : ∀ φ ∈ 𝐄𝐐 ℒₒᵣ, R0 φ + | Ω₁ (n m : ℕ) : R0 “↑n + ↑m = ↑(n + m)” + | Ω₂ (n m : ℕ) : R0 “↑n * ↑m = ↑(n * m)” + | Ω₃ (n : ℕ) : R0 “∀ x, x < ↑n ↔ ⋁ i < n, x = ↑i” + +/-- The «term𝐑₀» construction in `FFL.FirstOrder.Arithmetic`. -/ +notation "𝐑₀" => R0 + +namespace R0 + +instance : 𝐄𝐐 ℒₒᵣ ≼ 𝐑₀ := + Entailment.WeakerThan.ofSubset <| fun φ hp ↦ R0.equal φ hp + +instance : ℕ↓[ℒₒᵣ] ⊧* 𝐑₀ := + ⟨by + intro σ h + rcases h <;> + try { simp [models_iff]; done + } + case equal h => + have : ℕ↓[ℒₒᵣ] ⊧* (𝐄𝐐 ℒₒᵣ : ArithmeticTheory) := inferInstance + simpa [models_iff] using models_theory_iff.mp this _ h⟩ + +end R0 + +section model + +variable {M : Type*} [ORingStructure M] [M↓[ℒₒᵣ] ⊧* 𝐑₀] + +open Language ORingStructure + +lemma numeral_add_numeral (n m : ℕ) : (numeral n : M) + numeral m = numeral (n + m) := by + simpa [models_iff] using Theory.models M _ (R0.Ω₁ n m) + +lemma numeral_mul_numeral (n m : ℕ) : (numeral n : M) * numeral m = numeral (n * m) := by + simpa [models_iff] using Theory.models M _ (R0.Ω₂ n m) + +lemma lt_numeral_iff {x : M} {n : ℕ} : x < numeral n ↔ ∃ i : Fin n, x = numeral i := + by + have := by simpa [models_iff] using Theory.models M _ (R0.Ω₃ n) + constructor + · intro hx + rcases (this x).mp hx with ⟨i, hi, rfl⟩ + exact ⟨⟨i, hi⟩, by simp⟩ + · rintro ⟨i, rfl⟩ + exact (this (numeral i)).mpr ⟨i, by simp, rfl⟩ + +lemma not_numeral_lt_self (n : ℕ) : ¬(numeral n : M) < numeral n := by + induction n using Nat.strong_induction_on with + | _ n ih => + intro h + rcases lt_numeral_iff.mp h with ⟨i, hi⟩ + exact ih i i.isLt (hi ▸ h) + +lemma numeral_ne_numeral_of_ne {n m : ℕ} (h : n ≠ m) : (numeral n : M) ≠ numeral m := + by + rcases Nat.lt_or_gt_of_ne h with hnm | hnm + · intro he + exact not_numeral_lt_self n (he ▸ lt_numeral_iff.mpr ⟨⟨n, hnm⟩, by simp⟩) + · intro he + exact not_numeral_lt_self m (he ▸ lt_numeral_iff.mpr ⟨⟨m, hnm⟩, by simp⟩) + +@[simp] +lemma numeral_inj_iff {n m : ℕ} : (numeral n : M) = numeral m ↔ n = m := + ⟨by contrapose; exact numeral_ne_numeral_of_ne, by rintro rfl; rfl⟩ + +@[simp] +lemma numeral_lt_numeral_iff : (numeral n : M) < numeral m ↔ n < m := + ⟨by + contrapose + intro h H + rcases lt_numeral_iff.mp H with ⟨i, hi⟩ + rcases numeral_inj_iff.mp hi + exact (lt_self_iff_false m).mp (lt_of_le_of_lt (Nat.le_of_not_gt h) i.prop), fun h ↦ + lt_numeral_iff.mpr ⟨⟨n, h⟩, by simp⟩⟩ + +open Hierarchy + +lemma val_numeral {n ξ} (bv : Fin n → ℕ) (fv : ξ → ℕ) (t : ArithmeticSemiterm ξ n) : + t.val (M := M) (numeral ∘ bv) (numeral ∘ fv) = numeral (t.val bv fv) := + match t with + | #_ => by simp + | &_ => by simp + | .func Language.Zero.zero _ => by simp [Matrix.empty_eq] + | .func Language.One.one _ => by simp [Matrix.empty_eq] + | .func Language.Add.add v => by + simp [Semiterm.val_func, val_numeral _ _ (v 0), val_numeral _ _ (v 1), numeral_add_numeral] + | .func Language.Mul.mul v => by + simp [Semiterm.val_func, val_numeral _ _ (v 0), val_numeral _ _ (v 1), numeral_mul_numeral] + +lemma bold_sigma_one_completeness {n} {φ : ArithmeticSemiformula ξ n} (hp : Hierarchy Σ 1 φ) + {bv : Fin n → ℕ} {fv : ξ → ℕ} : + φ.Eval bv fv → φ.Eval (M := M) (numeral ∘ bv) (numeral ∘ fv) := + by + revert bv + apply sigma₁_induction' hp + case hVerum => simp + case hFalsum => simp + case hEQ => intro n t₁ t₂ e; simp [val_numeral] + case hNEQ => intro n t₁ t₂ e; simp [val_numeral] + case hLT => intro n t₁ t₂ e; simp [val_numeral] + case hNLT => intro n t₁ t₂ e; simp [val_numeral] + case hAnd => simp; grind + case hOr => simp; grind + case hBall => + intro n t φ _ ihp bv + suffices + (∀ x < t.val bv fv, (φ.Eval (x :> bv) fv)) → + ∀ x < numeral (t.val bv fv), (φ.Eval (x :> numeral ∘ bv) (numeral ∘ fv)) + by simpa [val_numeral] + intro hp x hx + rcases lt_numeral_iff.mp hx with ⟨x, rfl⟩ + simpa [Matrix.comp_vecCons''] using ihp (hp x (by simp)) + case hExs => + simp only [Semiformula.eval_ex, Nat.succ_eq_add_one, forall_exists_index] + intro n φ _ ihp e x hp + exact ⟨numeral x, by simpa [Matrix.comp_vecCons''] using ihp hp⟩ + +lemma R0.model_complete {σ : ArithmeticSentence} (hσ : Hierarchy Σ 1 σ) : + ℕ↓[ℒₒᵣ] ⊧ σ → M↓[ℒₒᵣ] ⊧ σ := + by + suffices σ.Evalb (M := ℕ) ![] → σ.Evalb (M := M) ![] by simpa [models_iff] + intro h + simpa [Matrix.empty_eq, Empty.eq_elim] using bold_sigma_one_completeness hσ h + +variable (M) + +lemma nat_extention_sigmaOne {σ : ArithmeticSentence} (hσ : Hierarchy Σ 1 σ) : + ℕ↓[ℒₒᵣ] ⊧ σ → M↓[ℒₒᵣ] ⊧ σ := fun h ↦ by + simpa [Matrix.empty_eq] using R0.model_complete (M := M) hσ h + +lemma nat_extention_piOne {σ : ArithmeticSentence} (hσ : Hierarchy Π 1 σ) : + M↓[ℒₒᵣ] ⊧ σ → ℕ↓[ℒₒᵣ] ⊧ σ := by + contrapose + simpa using nat_extention_sigmaOne M (σ := ∼σ) (by simpa using hσ) + +variable {M} + +lemma bold_sigma_one_completeness' {n} {σ : ArithmeticSemisentence n} (hσ : Hierarchy Σ 1 σ) + {bv} : σ.Evalb (M := ℕ) bv → σ.Evalb (M := M) (numeral ∘ bv) := fun h ↦ by + simpa [Empty.eq_elim] using + bold_sigma_one_completeness (M := M) (φ := σ) hσ (fv := Empty.elim) (bv := bv) h + +instance consistent : Entailment.Consistent 𝐑₀ := + let : ℕ↓[ℒₒᵣ] ⊧* 𝐑₀ := inferInstance + Sound.consistent_of_satisfiable ⟨_, this⟩ + +end model + +variable {T : ArithmeticTheory} [𝐑₀ ≼ T] + +theorem sigma_one_completeness {σ : ArithmeticSentence} (hσ : Hierarchy Σ 1 σ) : + ℕ↓[ℒₒᵣ] ⊧ σ → T ⊢ σ := fun H => + haveI : 𝐄𝐐 _ ≼ T := Entailment.WeakerThan.trans (𝓣 := 𝐑₀) inferInstance inferInstance + complete.{0} _ _ <| fun M _ _ ↦ + by + have : M↓[ℒₒᵣ] ⊧* 𝐑₀ := ModelsTheory.of_provably_subtheory M 𝐑₀ T inferInstance + exact R0.model_complete hσ H + +open _root_.Classical Classical in +theorem sigma_one_completeness_iff [T.SoundOnHierarchy Σ 1] {σ : ArithmeticSentence} + (hσ : Hierarchy Σ 1 σ) : ℕ↓[ℒₒᵣ] ⊧ σ ↔ T ⊢ σ := + haveI : 𝐑₀ ≼ T := Entailment.WeakerThan.trans (𝓣 := T) inferInstance inferInstance + ⟨fun h ↦ sigma_one_completeness hσ h, fun h ↦ T.soundOnHierarchy Σ 1 h (by simp [hσ])⟩ + +/-! +## Unprovable theorems of $\mathsf{R}_0$ + +$\omega + 1$ (the structure of order type $\omega + 1$) is a models of $\mathsf{R}_0$. +-/ + +/-! ω + 1 models 𝐑₀ -/ +namespace R0 +namespace Countermodel + +/-- The Omega Add One construction in `FFL.FirstOrder.Arithmetic.R0.Countermodel`. -/ +def OmegaAddOne := + Option ℕ + +namespace OmegaAddOne + +instance : NatCast OmegaAddOne := + ⟨fun i ↦ .some i⟩ + +instance (n : ℕ) : OfNat OmegaAddOne n := + ⟨.some n⟩ + +instance : Top OmegaAddOne := + ⟨.none⟩ + +instance : ORingStructure OmegaAddOne + where + add a + b := + match a, b with + | .some i, .some j => i + j + | .none, _ => 0 + | _, .none => 0 + mul a + b := + match a, b with + | .some i, .some j => (i * j) + | .none, _ => 0 + | _, .none => 0 + lt a + b := + match a, b with + | .some i, .some j => i < j + | .none, _ => False + | .some _, .none => True + +@[simp] +lemma coe_zero : (↑(0 : ℕ) : OmegaAddOne) = 0 := + rfl + +@[simp] +lemma coe_one : (↑(1 : ℕ) : OmegaAddOne) = 1 := + rfl + +@[simp] +lemma coe_add (a b : ℕ) : ↑(a + b) = ((↑a + ↑b) : OmegaAddOne) := + rfl + +@[simp] +lemma coe_mul (a b : ℕ) : ↑(a * b) = ((↑a * ↑b) : OmegaAddOne) := + rfl + +@[simp] +lemma lt_coe_iff (n m : ℕ) : (n : OmegaAddOne) < (m : OmegaAddOne) ↔ n < m := by rfl + +@[simp] +lemma not_top_lt (n : ℕ) : ¬⊤ < (n : OmegaAddOne) := by rintro ⟨⟩ + +@[simp] +lemma lt_top (n : ℕ) : (n : OmegaAddOne) < ⊤ := by trivial + +@[simp] +lemma top_add_zero : (⊤ : OmegaAddOne) + 0 = 0 := by rfl + +lemma exists_add_zero_ne_self : ∃ x : OmegaAddOne, x + 0 ≠ x := + ⟨⊤, by simp⟩ + +@[simp] +lemma numeral_eq (n : ℕ) : (ORingStructure.numeral n : OmegaAddOne) = n := + match n with + | 0 => rfl + | 1 => rfl + | n + 2 => by simp [ORingStructure.numeral, numeral_eq (n + 1)]; rfl + +@[simp] +lemma coe_inj_iff (n m : ℕ) : (↑n : OmegaAddOne) = (↑m : OmegaAddOne) ↔ n = m := + Option.some_inj + +/-- The cases' construction in `FFL.FirstOrder.Arithmetic.R0.Countermodel.OmegaAddOne`. -/ +def cases' {P : OmegaAddOne → Sort*} (nat : (n : ℕ) → P n) (top : P ⊤) : ∀ x : OmegaAddOne, P x + | .some n => nat n + | .none => top + +instance : OmegaAddOne↓[ℒₒᵣ] ⊧* 𝐑₀ := + ⟨by + intro σ h + rcases h + case equal + h => + have : OmegaAddOne↓[ℒₒᵣ] ⊧* (𝐄𝐐 _ : ArithmeticTheory) := inferInstance + exact models_theory_iff.mp this _ h + case Ω₃ + n => + suffices ∀ x : OmegaAddOne, x < ↑n ↔ ∃ i < n, x = ↑i by simpa [models_iff] + intro x + cases x using cases' <;> simp + all_goals simp [models_iff]⟩ + +end OmegaAddOne + +end Countermodel + +lemma unprovable_addZero : 𝐑₀ ⊬ “∀ x, x + 0 = x” := + unprovable_of_countermodel _ (M := Countermodel.OmegaAddOne) <| by + simpa [notModels_iff] using Countermodel.OmegaAddOne.exists_add_zero_ne_self + +end R0 + +end Arithmetic +end FirstOrder +end FFL + +end + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/R0/Representation.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/R0/Representation.lean new file mode 100644 index 000000000..d8eb02d9c --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/R0/Representation.lean @@ -0,0 +1,623 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Definability.Definable +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.PeanoMinus.Basic +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.R0.Basic +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Arithmetic +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Computability + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +open Encodable Denumerable + +namespace FFL +namespace FirstOrder +namespace Arithmetic + +open Mathlib Encodable Semiterm.Operator.GödelNumber + +section + +lemma term_primrec {k f} : + (t : ArithmeticSemiterm ξ k) → Primrec (fun v : List.Vector ℕ k ↦ t.val v.get f) + | #x => by simpa using Primrec.vector_get.comp .id (.const _) + | &x => by simpa using Primrec.const _ + | .func Language.Zero.zero _ => by simpa using Primrec.const 0 + | .func Language.One.one _ => by simpa using Primrec.const 1 + | .func Language.Add.add v => by + simpa [Semiterm.val_func] using + Primrec.nat_add.comp (term_primrec (v 0)) (term_primrec (v 1)) + | .func Language.Mul.mul v => by + simpa [Semiterm.val_func] using + Primrec.nat_mul.comp (term_primrec (v 0)) (term_primrec (v 1)) + +lemma primrecPred_ball (ε : ξ → ℕ) {n} (t : ArithmeticSemiterm ξ n) + {ψ : ArithmeticSemiformula ξ (n + 1)} + (h : PrimrecPred fun v : List.Vector ℕ (n + 1) ↦ ψ.Eval v.get ε) : + PrimrecPred fun v : List.Vector ℕ n ↦ ∀ x < t.val v.get ε, ψ.Eval (x :> v.get) ε := by + have hbounded : + PrimrecPred fun p : ℕ × List.Vector ℕ n ↦ ∀ x < p.1, ψ.Eval (x ::ᵥ p.2).get ε := + ((PrimrecRel.forall_mem_list (h.comp (Primrec.vector_cons.comp .fst .snd)).primrecRel).comp + (Primrec.list_range.comp Primrec.fst) Primrec.snd).of_eq + (by simp); + exact + (hbounded.comp ((term_primrec (f := ε) t).pair Primrec.id)).of_eq fun v ↦ by + simp [List.Vector.cons_get]; + +lemma primrecPred_bexs (ε : ξ → ℕ) {n} (t : ArithmeticSemiterm ξ n) + {ψ : ArithmeticSemiformula ξ (n + 1)} + (h : PrimrecPred fun v : List.Vector ℕ (n + 1) ↦ ψ.Eval v.get ε) : + PrimrecPred fun v : List.Vector ℕ n ↦ ∃ x < t.val v.get ε, ψ.Eval (x :> v.get) ε := by + have hbounded : + PrimrecPred fun p : ℕ × List.Vector ℕ n ↦ ∃ x < p.1, ψ.Eval (x ::ᵥ p.2).get ε := + ((PrimrecRel.exists_mem_list (h.comp (Primrec.vector_cons.comp .fst .snd)).primrecRel).comp + (Primrec.list_range.comp Primrec.fst) Primrec.snd).of_eq + (by simp); + exact + (hbounded.comp ((term_primrec (f := ε) t).pair Primrec.id)).of_eq fun v ↦ by + simp [List.Vector.cons_get]; + +lemma delta0_primrec (ε : ξ → ℕ) {k} {φ : ArithmeticSemiformula ξ k} (hp : Hierarchy Σ 0 φ) : + PrimrecPred fun v : List.Vector ℕ k ↦ φ.Eval v.get ε := by + apply + sigma₁_induction' (P := fun n φ ↦ + Hierarchy Σ 0 φ → PrimrecPred fun v : List.Vector ℕ n ↦ φ.Eval v.get ε) + (hp.mono (by simp)) + case hVerum => + intro _ _; exact (Primrec.const true).primrecPred (p := fun _ ↦ True); + case hFalsum => + intro _ _; exact (Primrec.const false).primrecPred (p := fun _ ↦ False); + case hEQ => + intro n t₁ t₂ _; exact Primrec.eq.comp (term_primrec t₁) (term_primrec t₂); + case hNEQ => + intro n t₁ t₂ _; exact (Primrec.eq.comp (term_primrec t₁) (term_primrec t₂)).not; + case hLT => + intro n t₁ t₂ _; exact Primrec.nat_lt.comp (term_primrec t₁) (term_primrec t₂); + case hNLT => + intro n t₁ t₂ _; + exact (Primrec.nat_lt.comp (term_primrec t₁) (term_primrec t₂)).not; + case hAnd => + intro n φ ψ _ _ ihp ihq h; + exact + (ihp (Hierarchy.and_iff.mp h).1).and (ihq (Hierarchy.and_iff.mp h).2) |>.of_eq fun v ↦ by + simp; + case hOr => + intro n φ ψ _ _ ihp ihq h; + exact + (ihp (Hierarchy.or_iff.mp h).1).or (ihq (Hierarchy.or_iff.mp h).2) |>.of_eq fun v ↦ by + simp; + case hBall => + intro n t φ _ ih h; + exact + (primrecPred_ball ε t + (ih ((Hierarchy.ball_iff (t := Rew.bShift t) (by simp)).mp h))).of_eq + fun v ↦ by simp; + case hExs => + intro n ψ _ ih h; + cases h with + | @bexs _ _ _ ψ _ ht hφ => + rcases Rew.positive_iff.mp ht with ⟨t, rfl⟩ + exact (primrecPred_bexs ε t (ih (by simp [hφ]))).of_eq fun v ↦ by simp; + exact hp; + +lemma sigma1_re (ε : ξ → ℕ) {k} {φ : ArithmeticSemiformula ξ k} (hp : Hierarchy Σ 1 φ) : + REPred fun v : List.Vector ℕ k ↦ φ.Eval v.get ε := + by + apply sigma₁_induction' hp + case hVerum => simp; + case hFalsum => simp + case hEQ => + intro n t₁ t₂ + refine + ComputablePred.to_re <| + ComputablePred.computable_iff.mpr <| + ⟨fun v : List.Vector ℕ n ↦ decide (t₁.val v.get ε = t₂.val v.get ε), ?_, ?_⟩ + · apply Primrec.to_comp (Primrec.eq.comp (term_primrec t₁) (term_primrec t₂)).decide + · simp + case hNEQ => + intro n t₁ t₂ + refine + ComputablePred.to_re <| + ComputablePred.computable_iff.mpr <| + ⟨fun v : List.Vector ℕ n ↦ !decide (t₁.val v.get ε = t₂.val v.get ε), ?_, ?_⟩ + · apply + Primrec.to_comp <| + Primrec.not.comp (Primrec.eq.comp (term_primrec t₁) (term_primrec t₂)).decide + · simp + case hLT => + intro n t₁ t₂ + refine + ComputablePred.to_re <| + ComputablePred.computable_iff.mpr <| + ⟨fun v : List.Vector ℕ n ↦ decide (t₁.val v.get ε < t₂.val v.get ε), ?_, ?_⟩ + · apply Primrec.to_comp (Primrec.nat_lt.comp (term_primrec t₁) (term_primrec t₂)).decide + · simp + case hNLT => + intro n t₁ t₂ + refine + ComputablePred.to_re <| + ComputablePred.computable_iff.mpr <| + ⟨fun v : List.Vector ℕ n ↦ !decide (t₁.val v.get ε < t₂.val v.get ε), ?_, ?_⟩ + · apply + Primrec.to_comp <| + Primrec.not.comp (Primrec.nat_lt.comp (term_primrec t₁) (term_primrec t₂)).decide + · simp + case hAnd => + intro n φ ψ _ _ ihp ihq + exact REPred.of_eq ((PointwiseComposition.REPred.and ihp) ihq) fun v ↦ by simp + case hOr => + intro n φ ψ _ _ ihp ihq + exact REPred.of_eq ((PointwiseComposition.REPred.or ihp) ihq) fun v ↦ by simp + case hBall => + intro n t φ _ ih + rcases REPred.iff'.mp ih with ⟨f, hf, H⟩ + let g : List.Vector ℕ n →. Unit := fun v ↦ + Nat.rec (.some ()) (fun x ih ↦ ih.bind fun _ ↦ f (x ::ᵥ v)) (t.val v.get ε) + have : Partrec g := + Partrec.nat_rec (term_primrec t).to_comp (Computable.const ()) + (Partrec.to₂ <| + hf.comp (Primrec.to_comp <| Primrec.vector_cons.comp (Primrec.fst.comp .snd) .fst)) + refine REPred.iff.mpr ⟨_, this, ?_⟩ + funext v + suffices + ∀ k : ℕ, + (∀ x < k, φ.Eval (x :> v.get) ε) ↔ + Part.Dom (Nat.rec (.some ()) (fun x ih ↦ ih.bind fun _ ↦ f (x ::ᵥ v)) k) + by simpa [g] using this _ + intro k; induction k + case zero => simp + case succ k + ih => + suffices + (∀ x < k + 1, φ.Eval (x :> v.get) ε) ↔ + (∀ x < k, φ.Eval (x :> v.get) ε) ∧ (f (k ::ᵥ v)).Dom + by simpa [← ih] + constructor + · intro h + exact + ⟨fun x hx ↦ h x (lt_trans hx (by simp)), + (H (k ::ᵥ v)).mp (by simpa [List.Vector.cons_get] using h k (by simp))⟩ + · rintro ⟨hs, hd⟩ x hx + rcases lt_or_eq_of_le (Nat.le_of_lt_succ hx) with (hx | rfl) + · exact hs x hx + · simpa [List.Vector.cons_get] using (H (x ::ᵥ v)).mpr hd + case hExs => + intro n φ _ ih + rcases REPred.iff'.mp ih with ⟨f, _, _⟩ + have : REPred fun vx : List.Vector ℕ n × ℕ ↦ φ.Eval (vx.2 :> vx.1.get) ε := by + simpa [List.Vector.cons_get] using + REPred.comp (Primrec.to_comp <| Primrec.vector_cons.comp .snd .fst) ih + simpa using (PointwiseComposition.REPred.projection this) + +end + +section code + +open Nat.ArithPart₁ + +/-- The code Aux construction in `FFL.FirstOrder.Arithmetic`. -/ +def codeAux {k : ℕ} : Nat.ArithPart₁.Code k → ArithmeticFormula (Fin (k + 1)) + | Code.zero _ => “&0 = 0” + | Code.one _ => “&0 = 1” + | Code.add i j => “&0 = &i.succ + &j.succ” + | Code.mul i j => “&0 = &i.succ * &j.succ” + | Code.equal i j => “(&i.succ = &j.succ ∧ &0 = 1) ∨ (&i.succ ≠ &j.succ ∧ &0 = 0)” + | Code.lt i j => “(&i.succ < &j.succ ∧ &0 = 1) ∨ (&i.succ ≮ &j.succ ∧ &0 = 0)” + | Code.proj i => “&0 = !!&i.succ” + | @Code.comp _ n c d => + exsClosure + ((Rew.bind (L := ℒₒᵣ) (ξ₁ := Fin (n + 1)) ![] (&0 :> (#·)) ▹ (codeAux c)) ⋏ + Matrix.conj fun i ↦ + Rew.bind (L := ℒₒᵣ) (ξ₁ := Fin (k + 1)) ![] (#i :> (&·.succ)) ▹ codeAux (d i)) + | Code.rfind c => + (Rew.bind (L := ℒₒᵣ) (ξ₁ := Fin (k + 1 + 1)) ![] (‘0’ :> &0 :> (&·.succ)) ▹ codeAux c) ⋏ + (∀¹[“z. z < &0”] + ∃¹ + (“z. z ≠ 0”) ⋏ + ((Rew.bind (L := ℒₒᵣ) (ξ₁ := Fin (k + 1 + 1)) ![] (#0 :> #1 :> (&·.succ)) ▹ + codeAux c))) + +/-- The code construction in `FFL.FirstOrder.Arithmetic`. -/ +def code (c : Code k) : ArithmeticSemisentence (k + 1) := + (Rew.bind (L := ℒₒᵣ) (ξ₁ := Fin (k + 1)) ![] (#0 :> (#·.succ))) ▹ (codeAux c) + +private lemma codeAux_sigma_one {k} (c : Nat.ArithPart₁.Code k) : Hierarchy Σ 1 (codeAux c) := + by + induction c + case zero => simp [codeAux] + case one => simp [codeAux] + case add => simp [codeAux] + case mul => simp [codeAux] + case lt => simp [codeAux, Matrix.fun_eq_vec_two] + case equal => simp [codeAux, Matrix.fun_eq_vec_two] + case proj => simp [codeAux] + case comp c d ihc ihg => exact Hierarchy.exsClosure (by simp [ihc, ihg]) + case rfind k c ih => simp [codeAux, Matrix.fun_eq_vec_two]; simp [ih] + +@[simp] +lemma code_sigma_one {k} (c : Nat.ArithPart₁.Code k) : Hierarchy Σ 1 (code c) := + Hierarchy.rew _ (codeAux_sigma_one c) + +@[simp] +lemma natCast_nat' (n : ℕ) : Nat.cast n = n := by rfl + +private lemma models_codeAux {c : Code k} {f : List.Vector ℕ k →. ℕ} (hc : c.eval f) (y : ℕ) + (v : Fin k → ℕ) : (codeAux c).Evalf (y :> v) ↔ f (List.Vector.ofFn v) = Part.some y := + by + induction hc generalizing y + case zero => + have : (0 : Part ℕ) = Part.some 0 := rfl + simp [codeAux, this, eq_comm] + case one => + have : (1 : Part ℕ) = Part.some 1 := rfl + simp [codeAux, this, eq_comm] + case equal i j => by_cases hv : v i = v j <;> simp [codeAux, hv, Nat.isEqNat, eq_comm] + case lt i j => + simp [codeAux] + by_cases hv : v i < v j <;> simp [hv, Nat.isLtNat, eq_comm, Nat.not_lt.mp] + case add => simp [codeAux, eq_comm] + case mul => simp [codeAux, eq_comm] + case proj => simp [codeAux, eq_comm] + case comp m n c d f g _ _ ihf + ihg => + suffices + (∃ e' : Fin n → ℕ, (codeAux c).Evalf (y :> e') ∧ ∀ i, (codeAux (d i)).Evalf (e' i :> v)) ↔ + (List.Vector.mOfFn (g · (List.Vector.ofFn v))).bind f = Part.some y + by + simp [codeAux] + simpa [Semiformula.eval_rew, Function.comp_def, Matrix.empty_eq, Matrix.comp_vecCons'] + constructor + · rintro ⟨e, hf, hg⟩ + have hf : f (List.Vector.ofFn e) = Part.some y := (ihf _ _).mp hf + have hg : ∀ i, g i (List.Vector.ofFn v) = Part.some (e i) := fun i => + (ihg i _ _).mp (hg i) + simp only [hg, Vector.mOfFn_part_some] + exact (Part.bind_some (List.Vector.ofFn e) f).trans hf + · intro h + have : ∃ w, (∀ i, List.Vector.get w i ∈ g i (List.Vector.ofFn v)) ∧ y ∈ f w := + by + obtain ⟨w, hw, hy⟩ := Part.mem_bind_iff.mp (Part.eq_some_iff.mp h) + exact ⟨w, Part.mem_vector_mOfFn.mp hw, hy⟩ + rcases this with ⟨w, hw, hy⟩ + exact + ⟨w.get, (ihf y w.get).mpr (by simpa [Part.eq_some_iff] using hy), fun i ↦ + (ihg i (w.get i) v).mpr (by simpa [Part.eq_some_iff] using hw i)⟩ + case rfind c f _ + ihf => + suffices + (f (y ::ᵥ List.Vector.ofFn v) = 0 ∧ ∀ x < y, 0 < f (x ::ᵥ List.Vector.ofFn v)) ↔ + (Nat.rfind fun n ↦ Part.some (decide (f (n ::ᵥ List.Vector.ofFn v) = 0))) = Part.some y + by + simp [codeAux] + simpa [Semiformula.eval_rew, Function.comp_def, Matrix.empty_eq, Matrix.comp_vecCons', + ihf, List.Vector.ofFn_vecCons] + constructor + · rintro ⟨hy, h⟩ + exact + Part.eq_some_iff.mpr + (Nat.mem_rfind.mpr ⟨by simp [hy], fun hz => by simp [Nat.ne_zero_of_lt (h _ hz)]⟩) + · intro h; simpa [pos_iff_ne_zero] using Nat.mem_rfind.mp (Part.eq_some_iff.mp h) + +lemma models_code {c : Code k} {f : List.Vector ℕ k →. ℕ} (hc : c.eval f) (y : ℕ) + (v : Fin k → ℕ) : (code c).Evalb (y :> v) ↔ y ∈ f (List.Vector.ofFn v) := by + simpa [code, models_iff, Semiformula.eval_rew, Matrix.empty_eq, Function.comp_def, + Matrix.comp_vecCons', ← Part.eq_some_iff] using models_codeAux hc y v + +/-- The code Of Partrec' construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def codeOfPartrec' {k} (f : List.Vector ℕ k →. ℕ) : + ArithmeticSemisentence (k + 1) := + code <| Classical.epsilon fun c ↦ ∀ y v, (code c).Evalb (y :> v) ↔ y ∈ f (List.Vector.ofFn v) + +lemma codeOfPartrec'_spec {k} {f : List.Vector ℕ k →. ℕ} (hf : Nat.Partrec' f) {y : ℕ} + {v : Fin k → ℕ} : (codeOfPartrec' f).Evalb (y :> v) ↔ y ∈ f (List.Vector.ofFn v) := + by + have : ∃ c, ∀ y v, (code c).Evalb (y :> v) ↔ y ∈ f (List.Vector.ofFn v) := + by + rcases Nat.ArithPart₁.exists_code (of_partrec hf) with ⟨c, hc⟩ + exact ⟨c, models_code hc⟩ + exact Classical.epsilon_spec this y v + +section model + +variable {M : Type*} [ORingStructure M] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] + +private lemma codeAux_uniq {k} {c : Code k} {v : Fin k → M} {z z' : M} : + (codeAux c).Evalf (M := M) (z :> v) → (codeAux c).Evalf (M := M) (z' :> v) → z = z' := by + induction c generalizing z z' with + | zero _ => intro h h'; simp_all [codeAux] + | one _ => intro h h'; simp_all [codeAux] + | add i j => intro h h'; simp_all [codeAux] + | mul i j => intro h h'; simp_all [codeAux] + | proj i => intro h h'; simp_all [codeAux] + | equal i j => + intro h h' + by_cases hv : v i = v j <;> simp_all [codeAux] + | lt i j => + intro h h' + by_cases hv : v i < v j <;> simp_all [codeAux] + | comp c d ihc ihd => + intro h h' + obtain ⟨w₁, hc₁, hd₁⟩ : + ∃ e', + (codeAux c).Evalf (M := M) (z :> e') ∧ + ∀ i, (codeAux (d i)).Evalf (M := M) (e' i :> v) := + by + simpa [codeAux, Semiformula.eval_rew, Function.comp_def, Matrix.empty_eq, + Matrix.comp_vecCons'] using h + obtain ⟨w₂, hc₂, hd₂⟩ : + ∃ e', + (codeAux c).Evalf (M := M) (z' :> e') ∧ + ∀ i, (codeAux (d i)).Evalf (M := M) (e' i :> v) := + by + simpa [codeAux, Semiformula.eval_rew, Function.comp_def, Matrix.empty_eq, + Matrix.comp_vecCons'] using h' + have : w₁ = w₂ := funext fun i => ihd i (hd₁ i) (hd₂ i) + rcases this with rfl + exact ihc hc₁ hc₂ + | rfind c ih => + intro H₁ H₂ + obtain ⟨h₁, hm₁⟩ : + (codeAux c).Evalf (M := M) (0 :> z :> v) ∧ + ∀ x < z, ∃ y, y ≠ 0 ∧ (codeAux c).Evalf (M := M) (y :> x :> v) := + by + simpa [codeAux, Semiformula.eval_rew, Function.comp_def, Matrix.empty_eq, + Matrix.comp_vecCons'] using H₁ + obtain ⟨h₂, hm₂⟩ : + (codeAux c).Evalf (M := M) (0 :> z' :> v) ∧ + ∀ x < z', ∃ y, y ≠ 0 ∧ (codeAux c).Evalf (M := M) (y :> x :> v) := + by + simpa [codeAux, Semiformula.eval_rew, Function.comp_def, Matrix.empty_eq, + Matrix.comp_vecCons'] using H₂ + clear H₁ H₂ + by_contra hz + wlog h : z < z' with Hz + case + rfind.isFalse => + have : z' < z := lt_of_le_of_ne (not_lt.mp h) (Ne.symm hz) + exact Hz (k := k) c ih h₂ hm₂ h₁ hm₁ (Ne.symm hz) this + have : ∃ x, x ≠ 0 ∧ (codeAux c).Evalf (M := M) (x :> z :> fun i => v i) := hm₂ z h + rcases this with ⟨x, xz, hx⟩ + exact xz (ih hx h₁) + +lemma code_uniq {k} {c : Code k} {v : Fin k → M} {z z' : M} : + (code c).Evalb (M := M) (z :> v) → (code c).Evalb (M := M) (z' :> v) → z = z' := + by + intro h h' + exact + codeAux_uniq + (by simpa [code, Semiformula.eval_rew, Matrix.empty_eq, Function.comp_def] using h) + (by simpa [code, Semiformula.eval_rew, Matrix.empty_eq, Function.comp_def] using h') + +end model + +end code + +section codeOfREPred + +/-- The code Of REPred construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def codeOfREPred (p : ℕ → Prop) : ArithmeticSemisentence 1 := + let f : ℕ →. Unit := fun a ↦ Part.assert (p a) fun _ ↦ Part.some () + (codeOfPartrec' (fun v ↦ (f (v.get 0)).map fun _ ↦ 0))/[‘0’, #0] + +lemma codeOfREPred_spec {p : ℕ → Prop} (hp : REPred p) {x : ℕ} : + (codeOfREPred p).Evalb ![x] ↔ p x := + by + let f : ℕ →. Unit := fun a ↦ Part.assert (p a) fun _ ↦ Part.some () + suffices + (codeOfPartrec' fun v ↦ Part.map (fun _ ↦ 0) (f (v.get 0)))/[‘0’, #0].Evalb (![x]) ↔ p x + from this + have : Partrec fun v : List.Vector ℕ 1 ↦ (f (v.get 0)).map fun _ ↦ 0 := by + refine + Partrec.map (Partrec.comp hp (Primrec.to_comp <| Primrec.vector_get.comp .id (.const 0))) + (Computable.const 0).to₂ + simpa [Semiformula.eval_substs, Matrix.comp_vecCons', Matrix.constant_eq_singleton] using + (codeOfPartrec'_spec (Nat.Partrec'.of_part this) (v := ![x]) (y := 0)).trans (by simp [f]) + +variable {T : ArithmeticTheory} [𝐑₀ ≼ T] [T.SoundOnHierarchy Σ 1] + +/-- Weak representation of a r.e. predicate -/ +theorem rePred_weak_representation {p : ℕ → Prop} (hp : REPred p) {x : ℕ} : + p x ↔ T ⊢ (codeOfREPred p)/[x] := + Iff.trans + (by + simpa [models_iff, Semiformula.eval_substs, Matrix.constant_eq_singleton] using + (codeOfREPred_spec hp (x := x)).symm) + (sigma_one_completeness_iff <| by simp [codeOfREPred, codeOfPartrec']) + +end codeOfREPred + +section codeOfComputablePred + + + +open _root_.Classical in +/-- The code Of Computable Pred construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def codeOfComputablePred (p : ℕ → Prop) : ArithmeticSemisentence 1 := + (codeOfPartrec' (fun v ↦ Part.some (if p (v.get 0) then 1 else 0)))/[‘1’, #0] + +@[simp] +lemma codeOfComputablePred_sigma1 (p : ℕ → Prop) : Hierarchy Σ 1 (codeOfComputablePred p) := by + simp [codeOfComputablePred, codeOfPartrec'] + +variable {p : ℕ → Prop} + +open _root_.Classical in +private lemma codeOfComputablePred_val_spec (hp : ComputablePred p) (x y : ℕ) : + (codeOfPartrec' (fun v ↦ Part.some (if p (v.get 0) then 1 else 0))).Evalb (y :> ![x]) ↔ + y = if p x then 1 else 0 := + by + classical + have hpart : + Nat.Partrec' (fun v : List.Vector ℕ 1 ↦ Part.some (if p (v.get 0) then 1 else 0)) := + by + obtain ⟨f, hf, rfl⟩ := ComputablePred.computable_iff.mp hp + have hc : Computable fun v : List.Vector ℕ 1 ↦ f (v.get 0) := + hf.comp (Primrec.to_comp <| Primrec.vector_get.comp .id (.const 0)) + have : Computable fun v : List.Vector ℕ 1 ↦ if (f (v.get 0) : Prop) then (1 : ℕ) else 0 := + (Computable.cond hc (Computable.const 1) (Computable.const 0)).of_eq fun v ↦ by + cases f (v.get 0) <;> simp + exact Nat.Partrec'.of_part (this.partrec.of_eq fun v ↦ by simp) + simpa using codeOfPartrec'_spec hpart (y := y) (v := ![x]) + +variable {T : ArithmeticTheory} {x : ℕ} + +/-- Positive representation of a computable predicate. -/ +theorem codeOfComputablePred_provable [𝐑₀ ≼ T] (hp : ComputablePred p) (h : p x) : + T ⊢ (codeOfComputablePred p)/[↑x] := by + classical + exact sigma_one_completeness (by simp) + (by + have : (codeOfComputablePred p).Evalb ![x] ↔ p x := by + simpa [codeOfComputablePred, Semiformula.eval_substs, Matrix.comp_vecCons', + Matrix.constant_eq_singleton] using + (codeOfComputablePred_val_spec hp x 1).trans (by by_cases hx : p x <;> simp [hx]) + simpa [models_iff, Semiformula.eval_substs, Matrix.constant_eq_singleton] using + this.mpr h) + +/-- Negative representation of a computable predicate. -/ +theorem codeOfComputablePred_provable_neg [𝐏𝐀⁻ ≼ T] (hp : ComputablePred p) (h : ¬p x) : + T ⊢ ∼((codeOfComputablePred p)/[↑x]) := + by + classical + have : 𝐄𝐐 _ ≼ T := Entailment.WeakerThan.trans (𝓣 := 𝐏𝐀⁻) inferInstance inferInstance + refine complete.{0} T _ fun M _ _ ↦ ?_ + have hPA : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := ModelsTheory.of_provably_subtheory M 𝐏𝐀⁻ T inferInstance + have hNotEval : ¬(codeOfComputablePred p).Evalb (M := M) ![ORingStructure.numeral x] := + by + intro hM + have hR0 : M↓[ℒₒᵣ] ⊧* 𝐑₀ := ModelsTheory.of_provably_subtheory M 𝐑₀ 𝐏𝐀⁻ inferInstance + have h0 : + (codeOfPartrec' (fun v ↦ Part.some (if p (v.get 0) then 1 else 0))).Evalb (M := ℕ) + (0 :> ![x]) := + (codeOfComputablePred_val_spec hp x 0).mpr (by simp [h]) + have h1 : + (codeOfPartrec' (fun v ↦ Part.some (if p (v.get 0) then 1 else 0))).Evalb (M := M) + ((0 : M) :> ![ORingStructure.numeral x]) := + by + simpa using + bold_sigma_one_completeness' (M := M) (σ := + codeOfPartrec' (fun v ↦ Part.some (if p (v.get 0) then 1 else 0))) + (by simp [codeOfPartrec']) h0 + have h2 : + (codeOfPartrec' (fun v ↦ Part.some (if p (v.get 0) then 1 else 0))).Evalb (M := M) + ((1 : M) :> ![ORingStructure.numeral x]) := + by + simpa [codeOfComputablePred, Semiformula.eval_substs, Matrix.comp_vecCons', + Matrix.constant_eq_singleton] using hM + exact absurd (code_uniq h1 h2) (ne_of_lt zero_lt_one) + simpa [models_iff, Semiformula.eval_substs, Matrix.constant_eq_singleton] using hNotEval + +end codeOfComputablePred + +section + +theorem rePred_iff_sigma1 {p : ℕ → Prop} : REPred p ↔ Σ₁-Predicate p := + by + constructor + · intro h + refine ⟨.mkSigma (codeOfREPred p) (by simp [codeOfREPred, codeOfPartrec']), ?_⟩ + intro v + simpa [← Matrix.fun_eq_vec_one] using codeOfREPred_spec h (x := v 0) + · rintro ⟨φ, hφ⟩ + have : REPred fun x ↦ (Semiformula.Eval (x ::ᵥ List.Vector.nil).get id) _ := + (sigma1_re id (φ.sigma_prop)).comp + (Primrec.to_comp <| Primrec.vector_cons.comp .id <| .const _) + exact this.of_eq <| by intro x; simpa [List.Vector.cons_get, Matrix.empty_eq] using hφ ![x] + +theorem computablePred_iff_delta1 {p : ℕ → Prop} : ComputablePred p ↔ ∆₁-Predicate p := by + classical + constructor + · intro hp + change ∆₁.Definable (fun v : Fin 1 → ℕ ↦ p (v 0)) + rw [HierarchySymbol.Definable.delta_iff_sigma_and_pi] + rcases ComputablePred.computable_iff_re_compl_re'.mp hp with ⟨hp, hnp⟩ + exact + ⟨(rePred_iff_sigma1.mp hnp).notSigma.of_iff (by intro v; simp), rePred_iff_sigma1.mp hp⟩ + · intro h + change ∆₁.Definable (fun v : Fin 1 → ℕ ↦ p (v 0)) at h + rw [HierarchySymbol.Definable.delta_iff_sigma_and_pi] at h + exact + ComputablePred.computable_iff_re_compl_re'.mpr + ⟨rePred_iff_sigma1.mpr h.2, rePred_iff_sigma1.mpr h.1.notPi⟩ + +theorem computable_iff_sigma1 {f : ℕ → ℕ} : Computable f ↔ Σ₁-Function₁ f := + by + constructor + · intro hf + let F : List.Vector ℕ 1 →. ℕ := fun v ↦ Part.some (f (v.get 0)) + have hF : Partrec F := + by + change Partrec fun v : List.Vector ℕ 1 ↦ Part.some (f (v.get 0)) + exact hf.comp (Primrec.to_comp <| Primrec.vector_get.comp .id (.const (0 : Fin 1))) + refine ⟨.mkSigma (codeOfPartrec' F) (by simp [codeOfPartrec']), ?_⟩ + intro v + simpa [F, ← Matrix.fun_eq_vec_two] using + codeOfPartrec'_spec (Nat.Partrec'.of_part hF) (y := v 0) (v := ![v 1]) + · rintro ⟨φ, hφ⟩ + have hRe : + REPred fun p : ℕ × ℕ ↦ + φ.val.Eval (p.2 ::ᵥ p.1 ::ᵥ List.Vector.nil : List.Vector ℕ 2).get id := + (sigma1_re id φ.sigma_prop).comp + (Primrec.to_comp <| + Primrec.vector_cons.comp .snd + (Primrec.vector_cons.comp .fst (.const List.Vector.nil))) + exact + ComputablePred.of_graph_rePred <| + hRe.of_eq <| by + intro p + simpa [List.Vector.cons_get] using hφ ![p.2, p.1] + +theorem computable₂_iff_sigma1 {f : ℕ → ℕ → ℕ} : Computable₂ f ↔ Σ₁-Function₂ f := + by + constructor + · intro hf + let F : List.Vector ℕ 2 →. ℕ := fun v ↦ Part.some (f (v.get 0) (v.get 1)) + have hF : Partrec F := + by + have hArg : Computable fun v : List.Vector ℕ 2 ↦ (v.get 0, v.get 1) := + (Primrec.vector_get.comp .id (.const (0 : Fin 2))).to_comp.pair + (Primrec.vector_get.comp .id (.const (1 : Fin 2))).to_comp + have hf' : Computable fun p : ℕ × ℕ ↦ f p.1 p.2 := hf + change Partrec fun v : List.Vector ℕ 2 ↦ Part.some (f (v.get 0) (v.get 1)) + exact hf'.comp hArg + refine ⟨.mkSigma (codeOfPartrec' F) (by simp [codeOfPartrec']), ?_⟩ + intro v + simpa [F, ← Matrix.fun_eq_vec_three] using + codeOfPartrec'_spec (Nat.Partrec'.of_part hF) (y := v 0) (v := ![v 1, v 2]) + · rintro ⟨φ, hφ⟩ + have hRe : + REPred fun p : (ℕ × ℕ) × ℕ ↦ + φ.val.Eval (p.2 ::ᵥ p.1.1 ::ᵥ p.1.2 ::ᵥ List.Vector.nil : List.Vector ℕ 3).get id := + (sigma1_re id φ.sigma_prop).comp + (Primrec.to_comp <| + Primrec.vector_cons.comp .snd + (Primrec.vector_cons.comp (Primrec.fst.comp .fst) + (Primrec.vector_cons.comp (Primrec.snd.comp .fst) (.const List.Vector.nil)))) + exact + ComputablePred.of_graph_rePred <| + hRe.of_eq <| by + intro p + simpa [List.Vector.cons_get] using hφ ![p.2, p.1.1, p.1.2] + +end + +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Schemata.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Schemata.lean new file mode 100644 index 000000000..885b04a07 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Schemata.lean @@ -0,0 +1,593 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.PeanoMinus.Functions +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.TA.Basic + +/-! Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# Induction and least number schemata of Arithmetic + +## References + +- [HP98, §I.2(a), I.2.3] +-/ + +@[expose] public section + +namespace FFL +namespace FirstOrder +namespace Arithmetic + +section axioms + +/-! ### Axiom formulas -/ + +variable {L : Language} [L.ORing] {ξ : Type*} [DecidableEq ξ] + +/-- The succ Ind construction in `FFL.FirstOrder.Arithmetic`. -/ +def succInd {ξ} (φ : Semiformula L ξ 1) : Formula L ξ := + “!φ 0 → (∀ x, !φ x → !φ(x + 1)) → ∀ x, !φ x” + +/-- The order Ind construction in `FFL.FirstOrder.Arithmetic`. -/ +def orderInd {ξ} (φ : Semiformula L ξ 1) : Formula L ξ := + “(∀ x, (∀ y < x, !φ y) → !φ x) → ∀ x, !φ x” + +/-- The least Number construction in `FFL.FirstOrder.Arithmetic`. -/ +def leastNumber {ξ} (φ : Semiformula L ξ 1) : Formula L ξ := + “(∃ x, !φ x) → ∃ z, !φ z ∧ ∀ x < z, ¬!φ x” + +/-! ### Induction schemata -/ + +variable (L) + +/-- The Induction Scheme construction in `FFL.FirstOrder.Arithmetic`. -/ +def InductionScheme (Γ : Semiformula L ℕ 1 → Prop) : Theory L := + {ψ | ∃ φ : Semiformula L ℕ 1, Γ φ ∧ ψ = .univCl (succInd φ)} + +/-- The 𝐈𝐎𝐩𝐞𝐧 construction in `𝐈𝐎𝐩𝐞𝐧`. -/ +abbrev IOpen : ArithmeticTheory := + 𝐏𝐀⁻ ∪ InductionScheme ℒₒᵣ Semiformula.Open + +/-- The «term𝐈𝐎𝐩𝐞𝐧» construction in `FFL.FirstOrder.Arithmetic`. -/ +notation "𝐈𝐎𝐩𝐞𝐧" => IOpen + +/-- The Induction On Hierarchy construction in `FFL.FirstOrder.Arithmetic`. -/ +abbrev InductionOnHierarchy (Γ : Polarity) (s : ℕ) : ArithmeticTheory := + 𝐏𝐀⁻ ∪ InductionScheme ℒₒᵣ (Arithmetic.Hierarchy Γ s) + +/-- The «term𝐈𝐍𝐃 » construction in `FFL.FirstOrder.Arithmetic`. -/ +prefix:max "𝐈𝐍𝐃 " => InductionOnHierarchy + +/-- The ISigma construction in `FFL.FirstOrder.Arithmetic`. -/ +abbrev ISigma (s : ℕ) : ArithmeticTheory := + 𝐈𝐍𝐃 Σ s + +/-- The «term𝐈Σ » construction in `FFL.FirstOrder.Arithmetic`. -/ +prefix:max "𝐈Σ" => ISigma + +/-- The «term𝐈Σ₀» construction in `FFL.FirstOrder.Arithmetic`. -/ +notation "𝐈Σ₀" => ISigma 0 + +/-- The IPi construction in `FFL.FirstOrder.Arithmetic`. -/ +abbrev IPi (s : ℕ) : ArithmeticTheory := + 𝐈𝐍𝐃 Π s + +/-- The «term𝐈Π » construction in `FFL.FirstOrder.Arithmetic`. -/ +prefix:max "𝐈Π" => IPi + +/-- The «term𝐈Π₀» construction in `FFL.FirstOrder.Arithmetic`. -/ +notation "𝐈Π₀" => IPi 0 + +/-- The «term𝐈Σ₁» construction in `FFL.FirstOrder.Arithmetic`. -/ +notation "𝐈Σ₁" => ISigma 1 + +/-- The «term𝐈Π₁» construction in `FFL.FirstOrder.Arithmetic`. -/ +notation "𝐈Π₁" => IPi 1 + +/-- The 𝐏𝐀 construction in `𝐏𝐀`. -/ +abbrev Peano : ArithmeticTheory := + 𝐏𝐀⁻ ∪ InductionScheme ℒₒᵣ Set.univ + +/-- The «term𝐏𝐀» construction in `FFL.FirstOrder.Arithmetic`. -/ +notation "𝐏𝐀" => Peano + +variable {L} + +/-! ### Least number schemata -/ + +/-- The Least Number Scheme construction in `FFL.FirstOrder.Arithmetic`. -/ +def LeastNumberScheme (Γ : ArithmeticSemiformula ℕ 1 → Prop) : ArithmeticTheory := + {ψ | ∃ φ : ArithmeticSemiformula ℕ 1, Γ φ ∧ ψ = .univCl (leastNumber φ)} + +/-- The Least Number On Hierarchy construction in `FFL.FirstOrder.Arithmetic`. -/ +abbrev LeastNumberOnHierarchy (Γ : Polarity) (s : ℕ) : ArithmeticTheory := + 𝐏𝐀⁻ ∪ LeastNumberScheme (Arithmetic.Hierarchy Γ s) + +/-- The «term𝐋 » construction in `FFL.FirstOrder.Arithmetic`. -/ +prefix:max "𝐋 " => LeastNumberOnHierarchy + +/-- The LSigma construction in `FFL.FirstOrder.Arithmetic`. -/ +abbrev LSigma (s : ℕ) : ArithmeticTheory := + 𝐋 Σ s + +/-- The «term𝐋Σ » construction in `FFL.FirstOrder.Arithmetic`. -/ +prefix:max "𝐋Σ" => LSigma + +/-- The LPi construction in `FFL.FirstOrder.Arithmetic`. -/ +abbrev LPi (s : ℕ) : ArithmeticTheory := + 𝐋 Π s + +/-- The «term𝐋Π » construction in `FFL.FirstOrder.Arithmetic`. -/ +prefix:max "𝐋Π" => LPi + +/-! ### Induction scheme lemmas -/ + +section + +variable {C C' : ArithmeticSemiformula ℕ 1 → Prop} + +lemma InductionScheme_subset (h : ∀ {φ : ArithmeticSemiformula ℕ 1}, C φ → C' φ) : + InductionScheme ℒₒᵣ C ⊆ InductionScheme ℒₒᵣ C' := by + intro _; simp only [InductionScheme, Set.mem_ofPred_eq, forall_exists_index, and_imp]; rintro + φ hp rfl; exact ⟨φ, h hp, rfl⟩ + + + +lemma mem_InductionScheme_of_mem {φ : ArithmeticSemiformula ℕ 1} (hp : C φ) : + .univCl (succInd φ) ∈ InductionScheme ℒₒᵣ C := by simpa [InductionScheme] using ⟨φ, hp, rfl⟩ + +lemma mem_IOpen_of_qfree {φ : ArithmeticSemiformula ℕ 1} (hp : φ.Open) : + .univCl (succInd φ) ∈ InductionScheme ℒₒᵣ Semiformula.Open := by exact ⟨φ, hp, rfl⟩ + +lemma ISigma_subset_mono {s₁ s₂} (h : s₁ ≤ s₂) : 𝐈Σs₁ ⊆ 𝐈Σs₂ := + Set.union_subset_union_right _ (InductionScheme_subset (fun H ↦ H.mono h)) + +lemma ISigma_weakerThan_of_le {s₁ s₂} (h : s₁ ≤ s₂) : 𝐈Σs₁ ≼ 𝐈Σs₂ := + Entailment.WeakerThan.ofSubset (ISigma_subset_mono h) + +lemma ISigma_weakerThan_of_le_trans {T : ArithmeticTheory} {s₁ s₂} (h : s₁ ≤ s₂) + (hT : 𝐈Σs₂ ≼ T) : 𝐈Σs₁ ≼ T := + Entailment.WeakerThan.trans (ISigma_weakerThan_of_le h) hT + +end + +/-! ### Least number scheme lemmas -/ + +section + +variable {C C' : ArithmeticSemiformula ℕ 1 → Prop} + +lemma LeastNumberScheme_subset (h : ∀ {φ : ArithmeticSemiformula ℕ 1}, C φ → C' φ) : + LeastNumberScheme C ⊆ LeastNumberScheme C' := by + rintro _ ⟨φ, hφ, rfl⟩; exact ⟨φ, h hφ, rfl⟩; + +lemma mem_LeastNumberScheme_of_mem {φ : ArithmeticSemiformula ℕ 1} (hφ : C φ) : + .univCl (leastNumber φ) ∈ LeastNumberScheme C := + ⟨φ, hφ, rfl⟩ + +lemma LeastNumberOnHierarchy_subset_mono {s₁ s₂} (h : s₁ ≤ s₂) : 𝐋 Γ s₁ ⊆ 𝐋 Γ s₂ := + Set.union_subset_union_right _ (LeastNumberScheme_subset (fun H ↦ H.mono h)) + +lemma LeastNumberOnHierarchy_weakerThan_of_le {s₁ s₂} (h : s₁ ≤ s₂) : 𝐋 Γ s₁ ≼ 𝐋 Γ s₂ := + Entailment.WeakerThan.ofSubset (LeastNumberOnHierarchy_subset_mono h) + +end + +/-! ### Relations between the theories -/ + +instance : 𝐄𝐐 ℒₒᵣ ≼ 𝐈𝐍𝐃 Γ s := + have : 𝐄𝐐 ℒₒᵣ ≼ 𝐏𝐀⁻ := inferInstance + Entailment.WeakerThan.trans this inferInstance + +instance : 𝐄𝐐 ℒₒᵣ ≼ 𝐈𝐎𝐩𝐞𝐧 := + have : 𝐄𝐐 ℒₒᵣ ≼ 𝐏𝐀⁻ := inferInstance + Entailment.WeakerThan.trans this inferInstance + +instance : 𝐈𝐎𝐩𝐞𝐧 ≼ 𝐈𝐍𝐃 Γ s := + Entailment.WeakerThan.ofSubset <| + Set.union_subset_union_right _ <| InductionScheme_subset Arithmetic.Hierarchy.of_open + +instance : 𝐈Σ₀ ≼ 𝐈Σ₁ := + ISigma_weakerThan_of_le (by decide) + +instance : 𝐈Σs ≼ 𝐏𝐀 := + Entailment.WeakerThan.ofSubset <| + Set.union_subset_union_right _ <| InductionScheme_subset (by intros; trivial) + +instance : 𝐏𝐀⁻ ≼ 𝐈𝐎𝐩𝐞𝐧 := + inferInstance + +instance : 𝐈𝐎𝐩𝐞𝐧 ≼ 𝐈Σ₀ := + inferInstance + +instance : 𝐈Σ₁ ≼ 𝐏𝐀 := + inferInstance + +instance : 𝐄𝐐 ℒₒᵣ ≼ 𝐏𝐀 := + have : 𝐄𝐐 ℒₒᵣ ≼ 𝐏𝐀⁻ := inferInstance + Entailment.WeakerThan.trans this inferInstance + +instance (Γ : Polarity) (s : ℕ) : 𝐏𝐀⁻ ≼ 𝐋 Γ s := + Entailment.WeakerThan.ofSubset Set.subset_union_left + +instance (Γ : Polarity) (s : ℕ) : 𝐄𝐐 ℒₒᵣ ≼ 𝐋 Γ s := + Entailment.WeakerThan.trans (inferInstance : 𝐄𝐐 ℒₒᵣ ≼ 𝐏𝐀⁻) inferInstance + +-- This is stated as a `lemma`, not an `instance`, since `s` does not occur in the conclusion +-- `𝐄𝐐 ℒₒᵣ ≼ T`, so instance search cannot infer it. +lemma eq_weakerThan_of_ISigma {T : ArithmeticTheory} {s : ℕ} [𝐈Σs ≼ T] : 𝐄𝐐 ℒₒᵣ ≼ T := + Entailment.WeakerThan.trans (inferInstance : 𝐄𝐐 ℒₒᵣ ≼ 𝐈Σ₀) + (ISigma_weakerThan_of_le_trans (by omega) ‹𝐈Σs ≼ T›) + +end axioms + +section models + +variable {V : Type*} [ORingStructure V] + +namespace InductionScheme + +variable {C : ArithmeticSemiformula ℕ 1 → Prop} [V↓[ℒₒᵣ] ⊧* InductionScheme ℒₒᵣ C] + +private lemma induction_eval {φ : ArithmeticSemiformula ℕ 1} (hp : C φ) (v : ℕ → V) : + φ.Eval ![0] v → (∀ x, φ.Eval ![x] v → φ.Eval ![x + 1] v) → ∀ x, φ.Eval ![x] v := + by + have : V↓[ℒₒᵣ] ⊧ .univCl (succInd φ) := + Theory.models (T := InductionScheme _ C) V (by simpa using mem_InductionScheme_of_mem hp) + revert v + simpa [models_iff, Semiformula.eval_univCl, succInd, Semiformula.eval_substs, + Matrix.constant_eq_singleton] using this + +@[elab_as_elim] +lemma succ_induction {P : V → Prop} + (hP : ∃ e : ℕ → V, ∃ φ : ArithmeticSemiformula ℕ 1, C φ ∧ ∀ x, P x ↔ φ.Eval ![x] e) : + P 0 → (∀ x, P x → P (x + 1)) → ∀ x, P x := by + rcases hP with ⟨e, φ, Cp, hp⟩; simpa [←hp] using induction_eval (V := V) Cp e + +end InductionScheme + +namespace InductionOnHierarchy + +section + +variable (Γ : Polarity) (s : ℕ) [V↓[ℒₒᵣ] ⊧* 𝐈𝐍𝐃 Γ s] + +instance : V↓[ℒₒᵣ] ⊧* InductionScheme ℒₒᵣ (Hierarchy Γ s) := + have : V↓[ℒₒᵣ] ⊧* 𝐈𝐍𝐃 Γ s := inferInstance + models_of_subtheory this + +lemma succ_induction {P : V → Prop} (hP : Γ-[s].DefinablePred P) + (zero : P 0) (succ : ∀ x, P x → P (x + 1)) : ∀ x, P x := + have : V↓[ℒₒᵣ] ⊧* 𝐈𝐍𝐃 Γ s := inferInstance + have : V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory this + InductionScheme.succ_induction (P := P) (C := Hierarchy Γ s) (by + rcases hP with ⟨φ, hp⟩ + have : Inhabited V := Classical.inhabited_of_nonempty' + exact ⟨φ.val.enumerateFVar, (Rew.rewriteMap φ.val.idxOfFVar) ▹ φ.val, by simp, + by intro x; simp [Semiformula.eval_rewriteMap, hp.df.iff]⟩) + zero succ + +lemma order_induction {P : V → Prop} (hP : Γ-[s].DefinablePred P) + (ind : ∀ x, (∀ y < x, P y) → P x) : ∀ x, P x := by + have : V↓[ℒₒᵣ] ⊧* 𝐈𝐍𝐃 Γ s := inferInstance + have : V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory this + suffices ∀ x, ∀ y < x, P y by + intro x; exact this (x + 1) x (by simp only [lt_add_iff_pos_right, lt_one_iff_eq_zero]) + intro x; induction x using succ_induction + · exact Γ + · exact s + · suffices Γ-[s].DefinablePred fun x ↦ ∀ y < x, P y by exact this + exact HierarchySymbol.Definable.ball_blt (by simp) (hP.retraction ![0]) + case zero => simp + case succ x IH => + intro y hxy + rcases show y < x ∨ y = x from lt_or_eq_of_le (le_iff_lt_succ.mpr hxy) with (lt | rfl) + · exact IH y lt + · exact ind y IH + case inst => infer_instance + +private lemma neg_succ_induction {P : V → Prop} (hP : Γ-[s].DefinablePred P) (nzero : ¬P 0) + (nsucc : ∀ x, ¬P x → ¬P (x + 1)) : ∀ x, ¬P x := + by + have : V↓[ℒₒᵣ] ⊧* 𝐈𝐍𝐃 Γ s := inferInstance + have : V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory this + by_contra A + have : ∃ x, P x := by simpa using A + rcases this with ⟨a, ha⟩ + have : ∀ x ≤ a, P (a - x) := by + intro x; induction x using succ_induction + · exact Γ + · exact s + · suffices Γ-[s].DefinablePred fun x ↦ x ≤ a → P (a - x) by exact this + apply HierarchySymbol.Definable.imp + · apply HierarchySymbol.Definable.bcomp₂ (by definability) (by definability) + · apply HierarchySymbol.Definable.bcomp₁ (by definability) + case zero => intro _; simpa using ha + case succ x IH => + intro hx + have : P (a - x) := IH (le_of_add_le_left hx) + exact + (not_imp_not.mp <| nsucc (a - (x + 1))) + (by + rw [← Arithmetic.sub_sub, sub_add_self_of_le] + · exact this + · exact le_tsub_of_add_le_left hx) + case inst => infer_instance + have : P 0 := by simpa using this a (by rfl) + contradiction + +instance models_InductionScheme_alt : + V↓[ℒₒᵣ] ⊧* InductionScheme ℒₒᵣ (Arithmetic.Hierarchy Γ.alt s) := + by + suffices + ∀ (φ : ArithmeticSemiformula ℕ 1), + Hierarchy Γ.alt s φ → + ∀ (f : ℕ → V), + φ.Eval ![0] f → (∀ x, φ.Eval ![x] f → φ.Eval ![x + 1] f) → ∀ x, φ.Eval ![x] f + by + simp only [InductionScheme] + refine Semantics.ModelsSet.setOf_iff.mpr ?_ + rintro _ ⟨φ, hφ, rfl⟩ + simpa [models_iff, Semiformula.eval_univCl, succInd, Semiformula.eval_rew_q, + Semiformula.eval_substs, Function.comp, Matrix.constant_eq_singleton] using this φ hφ + intro φ hp v + simpa using + neg_succ_induction Γ s (P := fun x ↦ ¬φ.Eval ![x] v) + (.mkPolarity (∼(Rew.rewriteMap v ▹ φ)) (by simpa using hp) + (by intro x; simp [← Matrix.fun_eq_vec_one, Semiformula.eval_rewriteMap])) + +instance models_alt : V↓[ℒₒᵣ] ⊧* 𝐈𝐍𝐃 Γ.alt s := + by + have : V↓[ℒₒᵣ] ⊧* 𝐈𝐍𝐃 Γ s := inferInstance + have : V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory this + simp only [InductionOnHierarchy, Semantics.ModelsSet.union_iff]; + constructor <;> infer_instance + +lemma least_number {P : V → Prop} (hP : Γ-[s].DefinablePred P) {x} (h : P x) : + ∃ y, P y ∧ ∀ z < y, ¬P z := + by + have : V↓[ℒₒᵣ] ⊧* 𝐈𝐍𝐃 Γ s := inferInstance + have : V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory this + by_contra A + have A : ∀ z, P z → ∃ w < z, P w := by simpa using A + have : ∀ z, ∀ w < z, ¬P w := by + intro z + induction z using succ_induction + · exact Γ.alt + · exact s + · suffices Γ.alt-[s].DefinablePred fun z ↦ ∀ w < z, ¬P w by exact this + apply HierarchySymbol.Definable.ball_blt (by definability) + apply HierarchySymbol.Definable.not + apply HierarchySymbol.Definable.bcomp₁ (hP := by simpa using hP) (by definability) + case zero => simp + case succ x IH => + intro w hx hw + rcases le_iff_lt_or_eq.mp (lt_succ_iff_le.mp hx) with (hx | rfl) + · exact IH w hx hw + · have : ∃ v < w, P v := A w hw + rcases this with ⟨v, hvw, hv⟩ + exact IH v hvw hv + case inst => infer_instance + exact this (x + 1) x (by simp) h + +end + +section + +variable (Γ : SigmaPiDelta) (s : ℕ) [V↓[ℒₒᵣ] ⊧* 𝐈𝐍𝐃 Σ s] + +lemma succ_induction_sigma {P : V → Prop} (hP : Γ-[s].DefinablePred P) (zero : P 0) + (succ : ∀ x, P x → P (x + 1)) : ∀ x, P x := + match Γ with + | Σ => succ_induction Σ s hP zero succ + | Π => + haveI : V↓[ℒₒᵣ] ⊧* 𝐈𝐍𝐃 Π s := models_alt Σ s + succ_induction Π s hP zero succ + | ∆ => succ_induction Σ s hP.of_delta zero succ + +lemma order_induction_sigma {P : V → Prop} (hP : Γ-[s].DefinablePred P) + (ind : ∀ x, (∀ y < x, P y) → P x) : ∀ x, P x := + match Γ with + | Σ => order_induction Σ s hP ind + | Π => + haveI : V↓[ℒₒᵣ] ⊧* 𝐈𝐍𝐃 Π s := models_alt Σ s + order_induction Π s hP ind + | ∆ => order_induction Σ s hP.of_delta ind + +lemma least_number_sigma {P : V → Prop} (hP : Γ-[s].DefinablePred P) {x} (h : P x) : + ∃ y, P y ∧ ∀ z < y, ¬P z := + match Γ with + | Σ => least_number Σ s hP h + | Π => + haveI : V↓[ℒₒᵣ] ⊧* 𝐈𝐍𝐃 Π s := models_alt Σ s + least_number Π s hP h + | ∆ => least_number Σ s hP.of_delta h + +end + +instance [V↓[ℒₒᵣ] ⊧* 𝐈𝐍𝐃 Σ s] : V↓[ℒₒᵣ] ⊧* 𝐈𝐍𝐃 Γ s := + by + rcases Γ + · infer_instance + · exact models_alt Σ s + +instance [V↓[ℒₒᵣ] ⊧* 𝐈𝐍𝐃 Π s] : V↓[ℒₒᵣ] ⊧* 𝐈𝐍𝐃 Γ s := + by + rcases Γ + · exact models_alt Π s + · infer_instance + +lemma modISigmaOfLe {s₁ s₂} (h : s₁ ≤ s₂) [V↓[ℒₒᵣ] ⊧* 𝐈Σs₂] : V↓[ℒₒᵣ] ⊧* 𝐈Σs₁ := + models_of_ss inferInstance (ISigma_subset_mono h) + +instance [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] : V↓[ℒₒᵣ] ⊧* 𝐈Σ₀ := + modISigmaOfLe (show 0 ≤ 1 from by simp) + +instance [V↓[ℒₒᵣ] ⊧* 𝐈Σs] : V↓[ℒₒᵣ] ⊧* 𝐈Πs := + inferInstance + +instance [V↓[ℒₒᵣ] ⊧* 𝐈Πs] : V↓[ℒₒᵣ] ⊧* 𝐈Σs := + inferInstance + +lemma models_ISigma_iff_models_IPi {s} : V↓[ℒₒᵣ] ⊧* 𝐈Σs ↔ V↓[ℒₒᵣ] ⊧* 𝐈Πs := + ⟨fun _ ↦ inferInstance, fun _ ↦ inferInstance⟩ + +instance [V↓[ℒₒᵣ] ⊧* 𝐈Σs] : V↓[ℒₒᵣ] ⊧* 𝐈𝐍𝐃 Γ s := + match Γ with + | Σ => inferInstance + | Π => inferInstance + +end InductionOnHierarchy + +@[elab_as_elim] +lemma ISigma0.succ_induction [V↓[ℒₒᵣ] ⊧* 𝐈Σ₀] {P : V → Prop} (hP : Σ₀.DefinablePred P) + (zero : P 0) (succ : ∀ x, P x → P (x + 1)) : ∀ x, P x := + InductionOnHierarchy.succ_induction Σ 0 hP zero succ + +@[elab_as_elim] +lemma ISigma1.sigma1_succ_induction [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] {P : V → Prop} (hP : Σ₁-Predicate P) + (zero : P 0) (succ : ∀ x, P x → P (x + 1)) : ∀ x, P x := + InductionOnHierarchy.succ_induction Σ 1 hP zero succ + +@[elab_as_elim] +lemma ISigma1.pi1_succ_induction [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] {P : V → Prop} (hP : Π₁-Predicate P) + (zero : P 0) (succ : ∀ x, P x → P (x + 1)) : ∀ x, P x := + InductionOnHierarchy.succ_induction Π 1 hP zero succ + +@[elab_as_elim] +lemma ISigma0.order_induction [V↓[ℒₒᵣ] ⊧* 𝐈Σ₀] {P : V → Prop} (hP : Σ₀-Predicate P) + (ind : ∀ x, (∀ y < x, P y) → P x) : ∀ x, P x := + InductionOnHierarchy.order_induction Σ 0 hP ind + +@[elab_as_elim] +lemma ISigma1.sigma1_order_induction [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] {P : V → Prop} (hP : Σ₁-Predicate P) + (ind : ∀ x, (∀ y < x, P y) → P x) : ∀ x, P x := + InductionOnHierarchy.order_induction Σ 1 hP ind + +@[elab_as_elim] +lemma ISigma1.pi1_order_induction [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] {P : V → Prop} (hP : Π₁-Predicate P) + (ind : ∀ x, (∀ y < x, P y) → P x) : ∀ x, P x := + InductionOnHierarchy.order_induction Π 1 hP ind + +lemma ISigma0.least_number [V↓[ℒₒᵣ] ⊧* 𝐈Σ₀] {P : V → Prop} (hP : Σ₀-Predicate P) {x} (h : P x) : + ∃ y, P y ∧ ∀ z < y, ¬P z := + InductionOnHierarchy.least_number Σ 0 hP h + +@[elab_as_elim] +lemma ISigma1.succ_induction [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] (Γ) {P : V → Prop} (hP : Γ-[1]-Predicate P) + (zero : P 0) (succ : ∀ x, P x → P (x + 1)) : ∀ x, P x := + InductionOnHierarchy.succ_induction_sigma Γ 1 hP zero succ + +@[elab_as_elim] +lemma ISigma1.order_induction [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] (Γ) {P : V → Prop} (hP : Γ-[1]-Predicate P) + (ind : ∀ x, (∀ y < x, P y) → P x) : ∀ x, P x := + InductionOnHierarchy.order_induction_sigma Γ 1 hP ind + +instance [V↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] : V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := + have : V↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧 := inferInstance + models_of_subtheory this + +instance [V↓[ℒₒᵣ] ⊧* 𝐈Σ₀] : V↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧 := + have : V↓[ℒₒᵣ] ⊧* 𝐈Σ₀ := inferInstance + models_of_subtheory this + +instance [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] : V↓[ℒₒᵣ] ⊧* 𝐈Σ₀ := + inferInstance + +/-- The mod ISigma of le construction in `FFL.FirstOrder.Arithmetic`. -/ +abbrev modISigmaOfLe {s₁ s₂} (h : s₁ ≤ s₂) [V↓[ℒₒᵣ] ⊧* 𝐈Σs₂] : V↓[ℒₒᵣ] ⊧* 𝐈Σ s₁ := + models_of_ss inferInstance (ISigma_subset_mono h) + +-- This is stated as a `lemma`, not an `instance`, since `s` does not occur in the conclusion +-- `V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻`, so instance search cannot infer it. +lemma mod_paMinus_of_ISigma {s} [V↓[ℒₒᵣ] ⊧* 𝐈Σs] : V↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := + have : V↓[ℒₒᵣ] ⊧* 𝐈Σ₀ := modISigmaOfLe (Nat.zero_le s) + inferInstance + +instance [V↓[ℒₒᵣ] ⊧* 𝐏𝐀] : V↓[ℒₒᵣ] ⊧* 𝐈Σs := + have : V↓[ℒₒᵣ] ⊧* 𝐏𝐀 := inferInstance + models_of_subtheory this + +end models + +lemma models_succInd (φ : ArithmeticSemiformula ℕ 1) : ℕ↓[ℒₒᵣ] ⊧ (succInd φ).univCl := + by + suffices + ∀ f : ℕ → ℕ, φ.Eval ![0] f → (∀ x, φ.Eval ![x] f → φ.Eval ![x + 1] f) → ∀ x, φ.Eval ![x] f + by + simpa [Semiformula.eval_univCl, succInd, models_iff, Matrix.constant_eq_singleton, + Semiformula.eval_substs] + intro e hzero hsucc x + induction x with + | zero => exact hzero + | succ x ih => exact hsucc x ih + +instance models_ISigma (Γ s) : ℕ↓[ℒₒᵣ] ⊧* 𝐈𝐍𝐃 Γ s := + by + have : ∀ φ, ℕ↓[ℒₒᵣ] ⊧ (succInd φ).univCl := models_succInd + simp only [Semantics.ModelsSet.union_iff, PeanoMinus.instModelsSetStrucORingSentenceStrNat, + true_and, InductionScheme] + exact Semantics.ModelsSet.setOf_iff.mpr (fun ψ ⟨φ, _, hψ⟩ => hψ ▸ this φ) + +instance models_ISigmaZero : ℕ↓[ℒₒᵣ] ⊧* 𝐈Σ₀ := + inferInstance + +instance models_ISigmaOne : ℕ↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := + inferInstance + +instance models_Peano : ℕ↓[ℒₒᵣ] ⊧* 𝐏𝐀 := + by + have : ∀ φ, ℕ↓[ℒₒᵣ] ⊧ (succInd φ).univCl := models_succInd + simp only [Peano, Semantics.ModelsSet.union_iff, + PeanoMinus.instModelsSetStrucORingSentenceStrNat, true_and, InductionScheme] + exact Semantics.ModelsSet.setOf_iff.mpr (fun ψ ⟨φ, _, hψ⟩ => hψ ▸ this φ) + +instance sigmaOneSound_ISigmaOne : 𝐈Σ₁.SoundOnHierarchy Σ 1 := + inferInstance + +instance sigmaOneSound_Peano : 𝐏𝐀.SoundOnHierarchy Σ 1 := + inferInstance + +instance : Entailment.Consistent (𝐈𝐍𝐃 Γ s) := + (𝐈𝐍𝐃 Γ s).consistent_of_sound (Eq ⊥) rfl + +instance : Entailment.Consistent 𝐏𝐀 := + 𝐏𝐀.consistent_of_sound (Eq ⊥) rfl + +instance : 𝐏𝐀 ≼ 𝐓𝐀 := + inferInstance + +instance (T : ArithmeticTheory) [𝐏𝐀⁻ ≼ T] : 𝐑₀ ≼ T := + have : 𝐑₀ ≼ 𝐏𝐀⁻ := inferInstance + Entailment.WeakerThan.trans this inferInstance + +instance (T : ArithmeticTheory) [𝐈Σ₀ ≼ T] : 𝐏𝐀⁻ ≼ T := + have : 𝐏𝐀⁻ ≼ 𝐈Σ₀ := inferInstance + Entailment.WeakerThan.trans this inferInstance + +instance (T : ArithmeticTheory) [𝐈Σ₁ ≼ T] : 𝐏𝐀⁻ ≼ T := + have : 𝐏𝐀⁻ ≼ 𝐈Σ₁ := inferInstance + Entailment.WeakerThan.trans this inferInstance + +instance (T : ArithmeticTheory) [𝐏𝐀 ≼ T] : 𝐏𝐀⁻ ≼ T := + have : 𝐏𝐀⁻ ≼ 𝐏𝐀 := inferInstance + Entailment.WeakerThan.trans this inferInstance + +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/TA/Basic.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/TA/Basic.lean new file mode 100644 index 000000000..d9476963c --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/TA/Basic.lean @@ -0,0 +1,53 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Basic + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace FFL +namespace FirstOrder +namespace Arithmetic + +/-- The 𝐓𝐀 construction in `𝐓𝐀`. -/ +abbrev FirstOrderTrueArith : ArithmeticTheory := + Tarski.Structure.theory ℒₒᵣ ℕ + +/-- The «term𝐓𝐀» construction in `FFL.FirstOrder.Arithmetic`. -/ +notation "𝐓𝐀" => FirstOrderTrueArith + +namespace TA + +instance : ℕ↓[ℒₒᵣ] ⊧* 𝐓𝐀 := + models_theory_iff.mpr fun {φ} ↦ by simp + +lemma provable_iff {φ : ArithmeticSentence} : 𝐓𝐀 ⊢ φ ↔ ℕ↓[ℒₒᵣ] ⊧ φ := + ⟨fun h ↦ consequence_iff'.mp (Theory.Proof.sound h) ℕ, fun h ↦ Entailment.by_axm h⟩ + +instance (T : ArithmeticTheory) [ℕ↓[ℒₒᵣ] ⊧* T] : T ≼ 𝐓𝐀 := + ⟨by + rintro φ h + have : ℕ↓[ℒₒᵣ] ⊧ φ := consequence_iff'.mp (Theory.Proof.sound h) ℕ + exact provable_iff.mpr this⟩ + +end TA + +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Incompleteness/Consistency.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Incompleteness/Consistency.lean new file mode 100644 index 000000000..7fecbf97a --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Incompleteness/Consistency.lean @@ -0,0 +1,145 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Incompleteness.StandardProvability + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +/-! +# Consistency predicate +-/ + + + +namespace FFL +namespace FirstOrder +namespace Arithmetic +namespace Bootstrapping + +variable {V : Type*} [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +section WitnessComparisons + +variable {L : Language} [L.Encodable] [L.LORDefinable] + +section + +variable (T : Theory L) [T.Δ₁] (V) + +/-- The Consistent construction in `FFL.FirstOrder.Theory`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Theory.Consistent : Prop := + ¬Provable T (⌜(⊥ : Sentence L)⌝ : V) + +variable {V} + +/-- The Consistent With construction in `FFL.FirstOrder.Theory`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Theory.ConsistentWith (φ : V) : Prop := + ¬Provable T (neg L φ) + +lemma _root_.PointwiseComposition.FFL.FirstOrder.Theory.ConsistentWith.quote_iff + {σ : Sentence L} : T.ConsistentWith (⌜σ⌝ : V) ↔ ¬Provable T (⌜∼σ⌝ : V) := by + simp [Theory.ConsistentWith, Sentence.quote_def, Semiformula.quote_def] + +section + +/-- The consistent construction in `FFL.FirstOrder.Theory`. -/ +noncomputable def _root_.PointwiseComposition.FFL.FirstOrder.Theory.consistent : Π₁.Sentence := + .mkPi (∼provabilityPred T ⊥) + +@[simp] +lemma consistent.defined : + (T.consistent : ArithmeticSentence).Evalb (M := V) ![] ↔ T.Consistent V := by + simp [Theory.consistent, Theory.Consistent] + +/-- The consistent With construction in `FFL.FirstOrder.Theory`. -/ +noncomputable def _root_.PointwiseComposition.FFL.FirstOrder.Theory.consistentWith : + Π₁.Semisentence 1 := + .mkPi (“φ. ∀ nφ, !(negGraph L)nφ φ → ¬!(provable T)nφ”) + +instance consistentWith.defined : + Π₁-Predicate (T.ConsistentWith : V → Prop) via T.consistentWith := + .mk fun v ↦ by simp [Theory.ConsistentWith, Theory.consistentWith] + +instance consistentWith.definable : Π₁-Predicate (T.ConsistentWith : V → Prop) := + (consistentWith.defined T).to_definable + +/-- The consistent With Pred construction in `FFL.FirstOrder.Theory`. -/ +noncomputable abbrev _root_.PointwiseComposition.FFL.FirstOrder.Theory.consistentWithPred + (σ : Sentence L) : ArithmeticSentence := + T.consistentWith.val/[⌜σ⌝] + +/-- The consistent With Pred' construction in `FFL.FirstOrder.Theory`. -/ +noncomputable def _root_.PointwiseComposition.FFL.FirstOrder.Theory.consistentWithPred' + (σ : Sentence L) : Π₁.Sentence := + .mkPi (“!T.consistentWith !!(⌜σ⌝)”) + +variable {T} + +end + +/-- The Con construction in `FFL.FirstOrder.Theory`. -/ +abbrev _root_.PointwiseComposition.FFL.FirstOrder.Theory.Con : ArithmeticTheory := + { T.consistent.val } + +/-- The Incon construction in `FFL.FirstOrder.Theory`. -/ +abbrev _root_.PointwiseComposition.FFL.FirstOrder.Theory.Incon : ArithmeticTheory := + {∼T.consistent.val} + +noncomputable instance : T.Con.Δ₁ := + Theory.Δ₁.singleton _ + +noncomputable instance : T.Incon.Δ₁ := + Theory.Δ₁.singleton _ + +end + +variable (T : ArithmeticTheory) [T.Δ₁] (V) + +theorem consistent_eq : T.consistent = T.standardProvability.con := + rfl + +@[simp] +lemma standard_consistent : T.Consistent ℕ ↔ Entailment.Consistent T := by + simp [Theory.Consistent, Entailment.consistent_iff_unprovable_bot] + +end WitnessComparisons + +end Bootstrapping +end Arithmetic +end FirstOrder +end FFL + +namespace FFL +namespace FirstOrder +namespace Arithmetic + +open _root_.PointwiseComposition.FFL.FirstOrder.Entailment + +variable (T : ArithmeticTheory) [𝐈Σ₁ ≼ T] [T.Δ₁] + +instance [ℕ↓[ℒₒᵣ] ⊧* T] : ℕ↓[ℒₒᵣ] ⊧* T ∪ T.Con := + by + have : 𝐑₀ ≼ 𝐈Σ₁ := inferInstance + have : 𝐑₀ ≼ T := Entailment.WeakerThan.trans this inferInstance + have : Entailment.Consistent T := ArithmeticTheory.consistent_of_sound T (Eq ⊥) rfl + simp [models_iff, *] + +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Incompleteness/Definability.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Incompleteness/Definability.lean new file mode 100644 index 000000000..c0e15501c --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Incompleteness/Definability.lean @@ -0,0 +1,1343 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Incompleteness.First +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Incompleteness.Second + +/-! Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# Definability of arithmetical syntax + +This file constructs internal recognizers for arithmetical syntax and recursively enumerable +presentations of `𝐏𝐀` and `𝐈Σ₁`. +-/ + +@[expose] public section + +namespace FFL +namespace FirstOrder +namespace Arithmetic +namespace Bootstrapping + +/-! ## Internal iterated universal quantifier `qqAlls` -/ + +variable {V : Type*} [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +section qqAlls + +/-- The blueprint construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.qqAlls`. -/ +def qqAlls.blueprint : PR.Blueprint 1 where + zero := .mkSigma “y x. y = x” + succ := .mkSigma “y ih n x. !qqAllDef y ih” + +/-- The construction construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.qqAlls`. -/ +noncomputable def qqAlls.construction : PR.Construction V qqAlls.blueprint + where + zero := fun x ↦ x 0 + succ := fun _ _ ih ↦ ^∀ ih + zero_defined := .mk fun v ↦ by simp [blueprint] + succ_defined := .mk fun v ↦ by simp [blueprint, qqAll] + +/-- `qqAlls p k = ^∀ ^∀ ... ^∀ p` (`k` universal quantifiers). -/ +noncomputable def qqAlls (p k : V) : V := + qqAlls.construction.result ![p] k + +@[simp] +lemma qqAlls_zero (p : V) : qqAlls p 0 = p := by simp [qqAlls, qqAlls.construction] + +@[simp] +lemma qqAlls_succ (p k : V) : qqAlls p (k + 1) = ^∀ (qqAlls p k) := by + simp [qqAlls, qqAlls.construction] + +section + +/-- The qq Alls Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.qqAllsDef : Σ₁.Semisentence 3 := + qqAlls.blueprint.resultDef |>.rew (Rew.subst ![#0, #2, #1]) + +instance qqAlls_defined : Σ₁-Function₂ (qqAlls : V → V → V) via qqAllsDef := + .mk fun v ↦ by simp [qqAlls.construction.result_defined_iff, qqAllsDef]; rfl + +instance qqAlls_definable : Σ₁-Function₂ (qqAlls : V → V → V) := + qqAlls_defined.to_definable + +instance qqAlls_definable' (Γ) : Γ-[m + 1]-Function₂ (qqAlls : V → V → V) := + qqAlls_definable.of_sigmaOne + +end + +variable {L : Language} [L.Encodable] [L.LORDefinable] + +lemma le_qqAll (p : V) : p ≤ ^∀ p := by + simp only [qqAll]; exact le_trans (le_pair_right _ _) le_self_add + +lemma qqAlls_all (p k : V) : qqAlls (^∀ p) k = ^∀ (qqAlls p k) := + by + induction k using ISigma1.sigma1_succ_induction + · definability + case zero => simp + case succ k ih => rw [qqAlls_succ, ih, qqAlls_succ] + +lemma qqAlls_succ' (p k : V) : qqAlls p (k + 1) = qqAlls (^∀ p) k := by + rw [qqAlls_succ, qqAlls_all] + +@[simp] +lemma le_qqAlls (p k : V) : p ≤ qqAlls p k := + by + induction k using ISigma1.sigma1_succ_induction + · definability + case zero => simp + case succ k ih => + refine le_trans ih ?_ + rw [qqAlls_succ] + exact le_qqAll _ + +lemma succ_le_qqAll (p : V) : p + 1 ≤ ^∀ p := by + simp only [qqAll]; exact add_le_add (le_pair_right _ _) (le_refl 1) + +@[simp] +lemma index_le_qqAlls (p k : V) : k ≤ qqAlls p k := + by + induction k using ISigma1.sigma1_succ_induction + · definability + case zero => simp + case succ k ih => + rw [qqAlls_succ] + exact le_trans (add_le_add ih (le_refl 1)) (succ_le_qqAll _) + +@[simp] +lemma isUFormula_qqAlls {p k : V} : IsUFormula L (qqAlls p k) ↔ IsUFormula L p := + by + induction k using ISigma1.sigma1_succ_induction + · definability + case zero => simp + case succ k ih => rw [qqAlls_succ, IsUFormula.all, ih] + +lemma bv_qqAlls {p k : V} (hp : IsUFormula L p) : bv L (qqAlls p k) = bv L p - k := + by + induction k using ISigma1.sigma1_succ_induction + · definability + case zero => simp + case succ k ih => rw [qqAlls_succ, bv_all (isUFormula_qqAlls.mpr hp), ih, Arithmetic.sub_sub] + +lemma IsSemiformula.qqAlls {n k p : V} (h : IsSemiformula L (n + k) p) : + IsSemiformula L n (qqAlls p k) := + by + rw [isSemiformula_iff] at h ⊢ + obtain ⟨hu, hbv⟩ := h + refine ⟨isUFormula_qqAlls.mpr hu, ?_⟩ + rw [bv_qqAlls hu, tsub_le_iff_right] + exact hbv + +lemma quote_allClosure {n : ℕ} (φ : Semiproposition L n) : + (⌜(∀¹* φ : Semiproposition L 0)⌝ : V) = qqAlls (⌜φ⌝ : V) (n : V) := + by + induction n + case zero => simp + case succ n ih => + rw [show (∀¹* φ : Semiproposition L 0) = ∀¹* (∀¹ φ) from rfl] + have := ih (∀¹ φ) + rw [Semiformula.quote_all] at this + rw [this, Nat.cast_succ, qqAlls_succ'] + +lemma quote_univCl' (ψ : Semiproposition L 0) : + (⌜Semiformula.univCl' ψ⌝ : V) = + qqAlls (⌜(Rew.fixitr 0 ψ.fvSup ▹ ψ : Semiproposition L (0 + ψ.fvSup))⌝ : V) + ((0 + ψ.fvSup : ℕ) : V) := + by rw [Semiformula.univCl']; exact quote_allClosure _ + +lemma quote_subst_fvar_fixitr (φ : Semiproposition L 0) : + (⌜(Rew.fixitr 0 φ.fvSup ▹ φ : Semiproposition L (0 + φ.fvSup)) ↜ + (fun x : Fin (0 + φ.fvSup) ↦ (&↑x : SyntacticTerm L))⌝ : + V) = + ⌜φ⌝ := + by + rw [show + (Rew.fixitr 0 φ.fvSup ▹ φ : Semiproposition L (0 + φ.fvSup)) ↜ + (fun x : Fin (0 + φ.fvSup) ↦ (&↑x : SyntacticTerm L)) = + φ + from by + have := Semiformula.subst_comp_fixitr (L := L) φ + convert this using 2] + +end qqAlls + +lemma _root_.PointwiseComposition.FFL.FirstOrder.Semiformula.hasFreeVariable_fvSup_pred + {L : Language} {n : ℕ} (φ : Semiproposition L n) (h : 0 < φ.fvSup) : + φ.HasFreeVariable (φ.fvSup - 1) := + by + by_cases he : φ.freeVariables = ∅ + · simp [Semiformula.fvSup, he] at h + · obtain ⟨k, hk⟩ := Finset.max_of_nonempty (Finset.nonempty_iff_ne_empty.mpr he) + rw [show φ.fvSup = k + 1 from by simp [Semiformula.fvSup, hk]] + simpa using Finset.mem_of_max hk + +/-! ## `castLE`-invariance of the Gödel code and free variables -/ + +section castLE + +variable {L : Language} [L.Encodable] [L.LORDefinable] + +private lemma semitermVec_val_congr {k m m' : ℕ} (g : Fin k → Bootstrapping.Semiterm V L m) + (g' : Fin k → Bootstrapping.Semiterm V L m') (h : ∀ i, (g i).val = (g' i).val) : + Bootstrapping.SemitermVec.val g = Bootstrapping.SemitermVec.val g' := + by + unfold Bootstrapping.SemitermVec.val + congr 1 + funext i + exact h i + +lemma _root_.PointwiseComposition.FFL.FirstOrder.Semiterm.quote_castLE {n : ℕ} + (t : SyntacticSemiterm L n) : + ∀ {n' : ℕ} (h : n ≤ n'), (⌜(Rew.castLE h t : SyntacticSemiterm L n')⌝ : V) = ⌜t⌝ := by + induction t with + | bvar x => intro n' h; simp + | fvar x => intro n' h; simp + | func f v ih => + intro n' h + simp only [Rew.func, Semiterm.quote_func, Function.comp_apply] + rw [semitermVec_val_congr (fun i ↦ ⌜Rew.castLE h (v i)⌝) (fun i ↦ ⌜v i⌝) + (fun i ↦ by rw [← Semiterm.quote_def, ← Semiterm.quote_def]; exact ih i h)] + +omit [L.Encodable] [L.LORDefinable] in +lemma _root_.PointwiseComposition.FFL.FirstOrder.Semiterm.freeVariables_castLE {n : ℕ} + (t : SyntacticSemiterm L n) : + ∀ {n' : ℕ} (h : n ≤ n'), + (Rew.castLE h t : SyntacticSemiterm L n').freeVariables = t.freeVariables := + by + induction t with + | bvar x => intro n' h; simp + | fvar x => intro n' h; simp + | func f v ih => + intro n' h + simp only [Rew.func, Semiterm.freeVariables_func] + apply Finset.biUnion_congr rfl + intro i _; exact ih i h + +lemma _root_.PointwiseComposition.FFL.FirstOrder.Semiformula.quote_castLE {n : ℕ} + (φ : Semiproposition L n) : + ∀ {n' : ℕ} (h : n ≤ n'), (⌜(Rew.castLE h ▹ φ : Semiproposition L n')⌝ : V) = ⌜φ⌝ := by + induction φ using Semiformula.rec' with + | hverum => intro n' h; simp + | hfalsum => intro n' h; simp + | hrel r v => + intro n' h + simp only [Semiformula.rew_rel, Semiformula.quote_rel] + rw [semitermVec_val_congr (fun i ↦ ⌜Rew.castLE h (v i)⌝) (fun i ↦ ⌜v i⌝) + (fun i ↦ by + rw [← Semiterm.quote_def, ← Semiterm.quote_def] + exact Semiterm.quote_castLE _ h)] + | hnrel r v => + intro n' h + simp only [Semiformula.rew_nrel, Semiformula.quote_nrel] + rw [semitermVec_val_congr (fun i ↦ ⌜Rew.castLE h (v i)⌝) (fun i ↦ ⌜v i⌝) + (fun i ↦ by + rw [← Semiterm.quote_def, ← Semiterm.quote_def] + exact Semiterm.quote_castLE _ h)] + | hand φ ψ ihp ihq => + intro n' h + simp only [LogicalConnective.HomClass.map_and, Semiformula.quote_and, ihp h, ihq h] + | hor φ ψ ihp ihq => + intro n' h + simp only [LogicalConnective.HomClass.map_or, Semiformula.quote_or, ihp h, ihq h] + | hall φ ih => + intro n' h + rw [Rewriting.app_all, Semiformula.quote_all, Rew.q_castLE, ih, Semiformula.quote_all] + | hexs φ ih => + intro n' h + rw [Rewriting.app_exs, Semiformula.quote_ex, Rew.q_castLE, ih, Semiformula.quote_ex] + +omit [L.Encodable] [L.LORDefinable] in +lemma _root_.PointwiseComposition.FFL.FirstOrder.Semiformula.freeVariables_castLE {n : ℕ} (φ : + Semiproposition L n) : + ∀ {n' : ℕ} (h : n ≤ n'), (Rew.castLE h ▹ φ : Semiproposition L n').freeVariables = + φ.freeVariables := by + induction φ using Semiformula.rec' with + | hverum => intro n' h; simp + | hfalsum => intro n' h; simp + | hrel r v => + intro n' h + simp only [Semiformula.rew_rel, Semiformula.freeVariables_rel] + apply Finset.biUnion_congr rfl; intro i _; exact Semiterm.freeVariables_castLE _ h + | hnrel r v => + intro n' h + simp only [Semiformula.rew_nrel, Semiformula.freeVariables_nrel] + apply Finset.biUnion_congr rfl; intro i _; exact Semiterm.freeVariables_castLE _ h + | hand φ ψ ihp ihq => intro n' h; simp only [LogicalConnective.HomClass.map_and, + Semiformula.freeVariables_and, ihp h, ihq h] + | hor φ ψ ihp ihq => intro n' h; simp only [LogicalConnective.HomClass.map_or, + Semiformula.freeVariables_or, ihp h, ihq h] + | hall φ ih => intro n' h; simp only [Rewriting.app_all, Semiformula.freeVariables_all, + Rew.q_castLE, ih] + | hexs φ ih => intro n' h; simp only [Rewriting.app_exs, Semiformula.freeVariables_exs, + Rew.q_castLE, ih] + +end castLE + +/-! ## The `bv`-pin bridge -/ + +section bvPin + +variable {L : Language} [L.Encodable] [L.LORDefinable] + +-- Only needs `GoedelQuote`/`Rewriting` structure on `L`, not `Encodable`/`LORDefinable`. +omit [L.Encodable] [L.LORDefinable] in +lemma not_hasFreeVariable_fixitr (χ : Semiproposition L 0) (x : ℕ) : + ¬(Rew.fixitr 0 χ.fvSup ▹ χ : Semiproposition L (0 + χ.fvSup)).HasFreeVariable x := + by + rw [Rew.eq_bind (Rew.fixitr 0 χ.fvSup)] + simp only [Function.comp_def, Rew.fixitr_bvar, Rew.fixitr_fvar, Fin.natAdd_mk, zero_add] + intro hh + rcases Semiformula.hasFreeVariable_rew hh with (⟨z, hz⟩ | ⟨z, hz, hx⟩) + · simp at hz + · have : z < χ.fvSup := Semiformula.lt_fvSup_of_hasFreeVariable hz + simp [this] at hx + +lemma quote_shift_fixitr (χ : Semiproposition L 0) : + Bootstrapping.shift (V := ℕ) L + (⌜(Rew.fixitr 0 χ.fvSup ▹ χ : Semiproposition L (0 + χ.fvSup))⌝ : ℕ) = + ⌜(Rew.fixitr 0 χ.fvSup ▹ χ : Semiproposition L (0 + χ.fvSup))⌝ := + by + have hshift : + Rewriting.shift (Rew.fixitr 0 χ.fvSup ▹ χ : Semiproposition L (0 + χ.fvSup)) = + (Rew.fixitr 0 χ.fvSup ▹ χ : Semiproposition L (0 + χ.fvSup)) := + Semiformula.rew_eq_self_of (by simp) (fun x hx ↦ absurd hx (not_hasFreeVariable_fixitr χ x)) + rw [← Semiformula.quote_shift (V := ℕ) (Rew.fixitr 0 χ.fvSup ▹ χ), hshift] + +/-- +Pins the number of leading universals `m` recognized by the induction-scheme code to `fvSup χ`. -/ +lemma bv_quote_fixitr (χ : Semiproposition L 0) : + bv (V := ℕ) L (⌜(Rew.fixitr 0 χ.fvSup ▹ χ : Semiproposition L (0 + χ.fvSup))⌝ : ℕ) = + χ.fvSup := + by + have hbsemi := + Semiformula.quote_isSemiformula (V := ℕ) + (Rew.fixitr 0 χ.fvSup ▹ χ : Semiproposition L (0 + χ.fvSup)) + have hbU : + IsUFormula L (⌜(Rew.fixitr 0 χ.fvSup ▹ χ : Semiproposition L (0 + χ.fvSup))⌝ : ℕ) := + hbsemi.isUFormula + have hle := hbsemi.bv_le + simp only [Nat.zero_add, natCast_nat] at hle + rcases + (hle : + bv (V := ℕ) L (⌜(Rew.fixitr 0 χ.fvSup ▹ χ : Semiproposition L (0 + χ.fvSup))⌝ : ℕ) = + χ.fvSup ∨ + bv (V := ℕ) L (⌜(Rew.fixitr 0 χ.fvSup ▹ χ : Semiproposition L (0 + χ.fvSup))⌝ : ℕ) < + χ.fvSup) with + heq | hlt + · exact heq + exfalso + set j := + bv (V := ℕ) L (⌜(Rew.fixitr 0 χ.fvSup ▹ χ : Semiproposition L (0 + χ.fvSup))⌝ : ℕ) with hj + have hpos : 0 < χ.fvSup := by omega + have hsemi : + IsSemiformula L j (⌜(Rew.fixitr 0 χ.fvSup ▹ χ : Semiproposition L (0 + χ.fvSup))⌝ : ℕ) := by + have := IsUFormula.isSemiformula hbU; rwa [← hj] at this + obtain ⟨γ, hγ⟩ := IsSemiformula.sound hsemi + have hjle : j ≤ 0 + χ.fvSup := by omega + have hcast : + (Rew.castLE hjle ▹ γ : Semiproposition L (0 + χ.fvSup)) = + (Rew.fixitr 0 χ.fvSup ▹ χ : Semiproposition L (0 + χ.fvSup)) := + by + apply (Semiformula.quote_inj_iff (V := ℕ)).mp + rw [Semiformula.quote_castLE, hγ] + have hγfree : γ.freeVariables = ∅ := + by + have hb : (Rew.fixitr 0 χ.fvSup ▹ χ : Semiproposition L (0 + χ.fvSup)).freeVariables = ∅ := + Finset.eq_empty_of_forall_notMem fun x hx ↦ not_hasFreeVariable_fixitr χ x hx + have := Semiformula.freeVariables_castLE γ hjle + rw [hcast, hb] at this; exact this.symm + have hχeq : χ = γ ↜ (fun i : Fin j ↦ (&↑i : SyntacticTerm L)) := + by + have e1 : + (Rew.fixitr 0 χ.fvSup ▹ χ : Semiproposition L (0 + χ.fvSup)) ↜ + (fun x : Fin (0 + χ.fvSup) ↦ (&↑x : SyntacticTerm L)) = + χ := + Semiformula.subst_comp_fixitr χ + have hRewEq : + (Rew.subst (fun x : Fin (0 + χ.fvSup) ↦ (&↑x : SyntacticTerm L))).comp (Rew.castLE hjle) = + Rew.subst (fun i : Fin j ↦ (&↑i : SyntacticTerm L)) := + by ext x <;> simp [Rew.comp_app] + symm + rw [← e1, ← hcast] + unfold Rewriting.subst + rw [← TransitiveRewriting.comp_app, hRewEq] + have hfv : (γ ↜ (fun i : Fin j ↦ (&↑i : SyntacticTerm L))).HasFreeVariable (χ.fvSup - 1) := by + rw [← hχeq]; exact Semiformula.hasFreeVariable_fvSup_pred χ hpos + unfold Rewriting.subst at hfv + rcases Semiformula.hasFreeVariable_rew hfv with (⟨i, hi⟩ | ⟨z, hz, _⟩) + · have hib : χ.fvSup - 1 = (i : ℕ) := by + simpa [Rew.subst_bvar, Semiterm.HasFreeVariable, Semiterm.freeVariables_fvar] using hi + have hij := i.isLt + omega + · simp [Semiformula.HasFreeVariable, hγfree] at hz + +end bvPin + +/-! ## Internal free-variable vector `fvarVec` -/ + +section fvarVec + +/-- The blueprint construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.fvarVec`. -/ +def fvarVec.blueprint : PR.Blueprint 0 where + zero := .mkSigma “y. y = 0” + succ := .mkSigma “y ih n. ∃ f, !qqFvarDef f n ∧ !concatDef y ih f” + +/-- The construction construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.fvarVec`. -/ +noncomputable def fvarVec.construction : PR.Construction V fvarVec.blueprint + where + zero := fun _ ↦ 0 + succ := fun _ n ih ↦ concat ih (^&n) + zero_defined := .mk fun v ↦ by simp [blueprint] + succ_defined := .mk fun v ↦ by simp [blueprint] + +/-- `fvarVec k = ⟨^&0, …, ^&(k-1)⟩`. -/ +noncomputable def fvarVec (k : V) : V := + fvarVec.construction.result ![] k + +@[simp] +lemma fvarVec_zero : fvarVec (0 : V) = 0 := by simp [fvarVec, fvarVec.construction] + +@[simp] +lemma fvarVec_succ (k : V) : fvarVec (k + 1) = concat (fvarVec k) (^&k) := by + simp [fvarVec, fvarVec.construction] + +/-- The fvar Vec Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.fvarVecDef : Σ₁.Semisentence 2 := + fvarVec.blueprint.resultDef + +instance fvarVec_defined : Σ₁-Function₁ (fvarVec : V → V) via fvarVecDef := + .mk fun v ↦ by simp [fvarVec.construction.result_defined_iff, fvarVecDef]; rfl + +instance fvarVec_definable : Σ₁-Function₁ (fvarVec : V → V) := + fvarVec_defined.to_definable + +instance fvarVec_definable' (Γ) : Γ-[m + 1]-Function₁ (fvarVec : V → V) := + fvarVec_definable.of_sigmaOne + +@[simp] +lemma len_fvarVec (k : V) : len (fvarVec k) = k := + by + induction k using ISigma1.sigma1_succ_induction + · definability + case zero => simp + case succ k ih => simp [ih] + +lemma nth_fvarVec (k : V) : ∀ i < k, (fvarVec k).[i] = ^&i := + by + induction k using ISigma1.sigma1_succ_induction + · definability + case zero => simp + case succ k ih => + intro i hi + rcases (lt_succ_iff_le.mp hi).lt_or_eq with hlt | rfl + · rw [fvarVec_succ, concat_nth_lt _ _ (by simpa using hlt)]; exact ih i hlt + · rw [fvarVec_succ, concat_nth_len' _ _ (by simp)] + +lemma fvarVec_val_eq (m : ℕ) : + fvarVec ((m : ℕ) : V) = + SemitermVec.val + (fun i : Fin m ↦ (Semiterm.fvar (↑(i : ℕ)) : Bootstrapping.Semiterm V ℒₒᵣ 0)) := + by + apply nth_ext (by simp) + intro i hi + rw [len_fvarVec] at hi + obtain ⟨j, rfl⟩ := eq_nat_of_lt_nat hi + have hj : j < m := by exact_mod_cast hi + rw [nth_fvarVec _ _ hi, show ((j : ℕ) : V) = ((⟨j, hj⟩ : Fin m) : ℕ) from rfl] + rw [SemitermVec.val_nth_eq + (fun i : Fin m ↦ (Semiterm.fvar (↑(i : ℕ)) : Bootstrapping.Semiterm V ℒₒᵣ 0)) ⟨j, hj⟩] + simp + +lemma subst_fvarVec_quote' {m : ℕ} (β : ArithmeticSemiproposition m) : + Bootstrapping.subst ℒₒᵣ (fvarVec ((m : ℕ) : V)) (⌜β⌝ : V) = + (⌜(β ↜ (fun i : Fin m ↦ (&↑i : SyntacticTerm ℒₒᵣ)))⌝ : V) := + by + set Kt : Bootstrapping.Semiformula V ℒₒᵣ m := ⌜β⌝ with hKt + set w : SemitermVec V ℒₒᵣ m 0 := + (fun i : Fin m ↦ (Semiterm.fvar (↑(i : ℕ)) : Bootstrapping.Semiterm V ℒₒᵣ 0)) with hw + rw [fvarVec_val_eq, show (⌜β⌝ : V) = Kt.val from rfl, + show Bootstrapping.subst ℒₒᵣ w.val Kt.val = (Kt.subst w).val from rfl] + rw [show + (⌜(β ↜ (fun i : Fin m ↦ (&↑i : SyntacticTerm ℒₒᵣ)))⌝ : V) = + (⌜(β ↜ (fun i : Fin m ↦ (&↑i : SyntacticTerm ℒₒᵣ)))⌝ : + Bootstrapping.Semiformula V ℒₒᵣ 0).val + from rfl] + congr 1 + rw [hKt] + simp only [FirstOrder.Semiformula.typed_quote_substs, hw, Semiterm.typed_quote_fvar] + +end fvarVec + +/-! ## Σ₁ side condition: internal `IsSigma1` predicate (for `C = Hierarchy Σ 1`) -/ + +section isSigma1 + +variable {L : Language} [L.Encodable] [L.LORDefinable] + +lemma le_termBShift {t : V} (ht : IsUTerm L t) : t ≤ termBShift L t := + by + refine IsUTerm.induction Σ (P := fun t ↦ t ≤ termBShift L t) ?_ ?_ ?_ ?_ t ht + · definability + · intro z + rw [termBShift_bvar] + simp only [qqBvar] + exact add_le_add (pair_le_pair_right (0 : V) le_self_add) (le_refl 1) + · intro x; simp + · intro k f v hf hv ih + rw [termBShift_func hf hv] + have hvle : v ≤ termBShiftVec L k v := + by + refine le_of_nth_le_nth ?_ ?_ + · rw [len_termBShiftVec hv]; exact hv.1.symm + · intro i hi + rw [← hv.1] at hi + rw [nth_termBShiftVec hv hi] + exact ih i hi + simp only [qqFunc] + exact + add_le_add (pair_le_pair_right 2 (pair_le_pair_right k (pair_le_pair_right f hvle))) + (le_refl 1) + +lemma IsUTerm.termBShift {t : V} (ht : IsUTerm L t) : IsUTerm L (termBShift L t) := + (ht.isSemiterm.termBShift).isUTerm + +lemma IsUTermVec.termBShiftVec {k v : V} (hv : IsUTermVec L k v) : + IsUTermVec L k (termBShiftVec L k v) := + ⟨(len_termBShiftVec hv).symm, fun i hi => by + rw [nth_termBShiftVec hv hi]; exact (hv.nth hi).termBShift⟩ + +lemma termBV_termBShift_le {t : V} (ht : IsUTerm L t) (m : V) : + termBV L (termBShift L t) ≤ m + 1 ↔ termBV L t ≤ m := + by + refine + IsUTerm.induction Σ (P := fun t ↦ termBV L (termBShift L t) ≤ m + 1 ↔ termBV L t ≤ m) ?_ ?_ + ?_ ?_ t ht + · definability + · intro z; simp only [termBShift_bvar, termBV_bvar]; exact add_le_add_iff_right 1 + · intro x; simp only [termBShift_fvar, termBV_fvar]; exact iff_of_true zero_le zero_le + · intro k f v hf hv ih + rw [termBShift_func hf hv, termBV_func hf hv.termBShiftVec, termBV_func hf hv, + listMaxss_le_iff, listMaxss_le_iff] + constructor + · intro H i hi + rw [len_termBVVec hv] at hi + rw [nth_termBVVec hv hi, ← ih i hi] + have := H i (by rw [len_termBVVec hv.termBShiftVec]; exact hi) + rwa [nth_termBVVec hv.termBShiftVec hi, nth_termBShiftVec hv hi] at this + · intro H i hi + rw [len_termBVVec hv.termBShiftVec] at hi + rw [nth_termBVVec hv.termBShiftVec hi, nth_termBShiftVec hv hi, ih i hi] + have := H i (by rw [len_termBVVec hv]; exact hi) + rwa [nth_termBVVec hv hi] at this + +/-- `qqBall u q = ^∀ ((^#0 ^≮ u) ^⋎ q)`, the code of `∀¹[“#0 < u”] q`. -/ +noncomputable def qqBall (u q : V) : V := + qqAll (qqOr (ObjectArithmetic.qqNLT (qqBvar 0) u) q) + +@[simp] +lemma lt_q_qqBall (u q : V) : q < qqBall u q := + lt_trans (lt_or_right _ _) (lt_forall _) + +@[simp] +lemma lt_u_qqBall (u q : V) : u < qqBall u q := + lt_trans (ObjectArithmetic.lt_qqNLT_right _ _) (lt_trans (lt_or_left _ _) (lt_forall _)) + +/-- The qq Ball Def construction in `FFL.FirstOrder.Arithmetic`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Arithmetic.qqBallDef : Σ₁.Semisentence 3 := .mkSigma + “p u q. ∃ bv, !qqBvarDef bv 0 ∧ ∃ nlt, !qqNLTDef nlt bv u ∧ ∃ g, !qqOrDef g nlt q ∧ !qqAllDef p g” + +instance qqBall_defined : Σ₁-Function₂ (qqBall : V → V → V) via Arithmetic.qqBallDef := + .mk fun v ↦ by + simp [Arithmetic.qqBallDef, qqBall, (ObjectArithmetic.qqNLT_defined (V := V)).df] + +instance qqBall_definable (Γ m) : Γ-[m + 1]-Function₂ (qqBall : V → V → V) := + .of_sigmaOne qqBall_defined.to_definable + +namespace IsSigma1F + +/-- Single-step operator: `p` is `Σ₁` given that its immediate subformulas in `C` are. -/ +def Phi (C : Set V) (p : V) : Prop := + (p = ^⊤) ∨ + (p = ^⊥) ∨ + (∃ k r v, p = ^rel k r v) ∨ + (∃ k r v, p = ^nrel k r v) ∨ + (∃ p₁ p₂, p₁ ∈ C ∧ p₂ ∈ C ∧ p = p₁ ^⋏ p₂) ∨ + (∃ p₁ p₂, p₁ ∈ C ∧ p₂ ∈ C ∧ p = p₁ ^⋎ p₂) ∨ + (∃ p₁, p₁ ∈ C ∧ p = ^∃ p₁) ∨ + (∃ u q, (∃ t, IsUTerm ℒₒᵣ t ∧ u = termBShift ℒₒᵣ t) ∧ q ∈ C ∧ p = qqBall u q) + +private lemma phi_iff (C p : V) : + Phi {x | x ∈ C} p ↔ + (p = ^⊤) ∨ + (p = ^⊥) ∨ + (∃ k < p, ∃ r < p, ∃ v < p, p = ^rel k r v) ∨ + (∃ k < p, ∃ r < p, ∃ v < p, p = ^nrel k r v) ∨ + (∃ p₁ < p, ∃ p₂ < p, p₁ ∈ C ∧ p₂ ∈ C ∧ p = p₁ ^⋏ p₂) ∨ + (∃ p₁ < p, ∃ p₂ < p, p₁ ∈ C ∧ p₂ ∈ C ∧ p = p₁ ^⋎ p₂) ∨ + (∃ p₁ < p, p₁ ∈ C ∧ p = ^∃ p₁) ∨ + (∃ u < p, + ∃ q < p, + (∃ t < p, IsUTerm ℒₒᵣ t ∧ u = termBShift ℒₒᵣ t) ∧ + q ∈ C ∧ p = qqBall u q) + where + mp := + by + rintro + (rfl | rfl | ⟨k, r, v, rfl⟩ | ⟨k, r, v, rfl⟩ | ⟨p₁, p₂, hp, hq, rfl⟩ | + ⟨p₁, p₂, hp, hq, rfl⟩ | ⟨p₁, hp, rfl⟩ | ⟨u, q, ⟨t, ht, rfl⟩, hq, rfl⟩) + · tauto + · tauto + · exact Or.inr (Or.inr (Or.inl ⟨k, by simp, r, by simp, v, by simp, rfl⟩)) + · exact Or.inr (Or.inr (Or.inr (Or.inl ⟨k, by simp, r, by simp, v, by simp, rfl⟩))) + · exact Or.inr (Or.inr (Or.inr (Or.inr (Or.inl ⟨p₁, by simp, p₂, by simp, hp, hq, rfl⟩)))) + · exact + Or.inr + (Or.inr (Or.inr (Or.inr (Or.inr (Or.inl ⟨p₁, by simp, p₂, by simp, hp, hq, rfl⟩))))) + · exact Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inl ⟨p₁, by simp, hp, rfl⟩)))))) + · exact + Or.inr + (Or.inr + (Or.inr + (Or.inr + (Or.inr + (Or.inr + (Or.inr + ⟨termBShift ℒₒᵣ t, lt_u_qqBall _ _, q, lt_q_qqBall _ _, + ⟨t, lt_of_le_of_lt (le_termBShift ht) (lt_u_qqBall _ _), ht, rfl⟩, hq, + rfl⟩)))))) + mpr := by + unfold Phi + rintro + (rfl | rfl | ⟨k, _, r, _, v, _, rfl⟩ | ⟨k, _, r, _, v, _, rfl⟩ | + ⟨p₁, _, p₂, _, hp, hq, rfl⟩ | ⟨p₁, _, p₂, _, hp, hq, rfl⟩ | ⟨p₁, _, hp, rfl⟩ | + ⟨u, _, q, _, ⟨t, _, ht, rfl⟩, hq, rfl⟩) <;> + grind + +/-- The blueprint construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.IsSigma1F`. -/ +noncomputable def blueprint : Fixpoint.Blueprint 0 := ⟨.mkDelta + (.mkSigma “p C. + !qqVerumDef p ∨ !qqFalsumDef p ∨ + (∃ k < p, ∃ r < p, ∃ v < p, !qqRelDef p k r v) ∨ + (∃ k < p, ∃ r < p, ∃ v < p, !qqNRelDef p k r v) ∨ + (∃ p₁ < p, ∃ p₂ < p, p₁ ∈ C ∧ p₂ ∈ C ∧ !qqAndDef p p₁ p₂) ∨ + (∃ p₁ < p, ∃ p₂ < p, p₁ ∈ C ∧ p₂ ∈ C ∧ !qqOrDef p p₁ p₂) ∨ + (∃ p₁ < p, p₁ ∈ C ∧ !qqExsDef p p₁) ∨ + (∃ u < p, ∃ q < p, + (∃ t < p, !(isUTerm ℒₒᵣ).sigma t ∧ !(termBShiftGraph ℒₒᵣ) u t) ∧ q ∈ C + ∧ !qqBallDef p u q)”) + (.mkPi “p C. + !qqVerumDef p ∨ !qqFalsumDef p ∨ + (∃ k < p, ∃ r < p, ∃ v < p, !qqRelDef p k r v) ∨ + (∃ k < p, ∃ r < p, ∃ v < p, !qqNRelDef p k r v) ∨ + (∃ p₁ < p, ∃ p₂ < p, p₁ ∈ C ∧ p₂ ∈ C ∧ !qqAndDef p p₁ p₂) ∨ + (∃ p₁ < p, ∃ p₂ < p, p₁ ∈ C ∧ p₂ ∈ C ∧ !qqOrDef p p₁ p₂) ∨ + (∃ p₁ < p, p₁ ∈ C ∧ !qqExsDef p p₁) ∨ + (∃ u < p, ∃ q < p, + (∃ t < p, !(isUTerm ℒₒᵣ).pi t ∧ ∀ u', !(termBShiftGraph ℒₒᵣ) u' t → u = u') ∧ q ∈ C + ∧ ∀ p', !qqBallDef p' u q → p = p')”)⟩ + +/-- The construction construction in `FFL.FirstOrder.Arithmetic.Bootstrapping.IsSigma1F`. -/ +def construction : Fixpoint.Construction V blueprint + where + Φ := fun _ ↦ Phi + defined := + .mk <| by + constructor + · intro v + simp [blueprint, HierarchySymbol.Semiformula.val_sigma, eq_comm, + (termBShift.defined (L := ℒₒᵣ) (V := V)).df, (qqBall_defined (V := V)).df] + · intro v + symm + simpa [blueprint, HierarchySymbol.Semiformula.val_sigma, eq_comm, + (termBShift.defined (L := ℒₒᵣ) (V := V)).df, (qqBall_defined (V := V)).df] using + phi_iff (V := V) _ _ + monotone := by + unfold Phi + rintro C C' hC _ x + (h | h | h | h | ⟨p₁, p₂, hp, hq, rfl⟩ | ⟨p₁, p₂, hp, hq, rfl⟩ | ⟨p₁, hp, rfl⟩ | + ⟨u, q, ht, hq, rfl⟩) <;> + grind + +instance : construction.StrongFinite V where + strong_finite := by + unfold construction Phi + rintro C _ x + (h | h | h | h | ⟨p₁, p₂, hp, hq, rfl⟩ | ⟨p₁, p₂, hp, hq, rfl⟩ | ⟨p₁, hp, rfl⟩ | + ⟨u, q, ht, hq, rfl⟩) + · exact Or.inl h + · exact Or.inr (Or.inl h) + · exact Or.inr (Or.inr (Or.inl h)) + · exact Or.inr (Or.inr (Or.inr (Or.inl h))) + · exact + Or.inr (Or.inr (Or.inr (Or.inr (Or.inl ⟨p₁, p₂, ⟨hp, by simp⟩, ⟨hq, by simp⟩, rfl⟩)))) + · exact + Or.inr + (Or.inr + (Or.inr (Or.inr (Or.inr (Or.inl ⟨p₁, p₂, ⟨hp, by simp⟩, ⟨hq, by simp⟩, rfl⟩))))) + · exact + Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inl ⟨p₁, ⟨hp, by simp⟩, rfl⟩)))))) + · refine + Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inr (Or.inr ⟨u, q, ht, ⟨hq, ?_⟩, rfl⟩)))))) + exact lt_q_qqBall _ _ + +end IsSigma1F + +/-- `IsSigma1 p`: `p` codes a `Σ₁` formula over `ℒₒᵣ` (assuming `p` is a semiformula). -/ +def IsSigma1 (p : V) : Prop := + IsSigma1F.construction.IsFixedPoint ![] p + +/-- Concrete `∆₁`-recognizer for `IsSigma1`. -/ +noncomputable def isSigma1 : ∆₁.Semisentence 1 := + IsSigma1F.blueprint.fixpointDefΔ₁ + +instance IsSigma1.defined : ∆₁-Predicate (IsSigma1 (V := V)) via isSigma1 := + IsSigma1F.construction.fixpoint_definedΔ₁ + +lemma IsSigma1.case_iff {p : V} : + IsSigma1 p ↔ + (p = ^⊤) ∨ + (p = ^⊥) ∨ + (∃ k r v, p = ^rel k r v) ∨ + (∃ k r v, p = ^nrel k r v) ∨ + (∃ p₁ p₂, IsSigma1 p₁ ∧ IsSigma1 p₂ ∧ p = p₁ ^⋏ p₂) ∨ + (∃ p₁ p₂, IsSigma1 p₁ ∧ IsSigma1 p₂ ∧ p = p₁ ^⋎ p₂) ∨ + (∃ p₁, IsSigma1 p₁ ∧ p = ^∃ p₁) ∨ + (∃ u q, + (∃ t, IsUTerm ℒₒᵣ t ∧ u = termBShift ℒₒᵣ t) ∧ + IsSigma1 q ∧ p = qqBall u q) := + IsSigma1F.construction.case + +alias ⟨IsSigma1.case, IsSigma1.mk⟩ := IsSigma1.case_iff + +@[simp] +lemma IsSigma1.verum : IsSigma1 (V := V) (^⊤) := + IsSigma1.mk <| by grind; +@[simp] +lemma IsSigma1.falsum : IsSigma1 (V := V) (^⊥) := + IsSigma1.mk <| by grind; +@[simp] +lemma IsSigma1.rel {k r v : V} : IsSigma1 (^rel k r v) := + IsSigma1.mk <| by grind; +@[simp] +lemma IsSigma1.nrel {k r v : V} : IsSigma1 (^nrel k r v) := + IsSigma1.mk <| by grind; + +@[simp] +lemma IsSigma1.and_iff {p q : V} : IsSigma1 (p ^⋏ q) ↔ IsSigma1 p ∧ IsSigma1 q := + by + constructor; + · intro h + rcases h.case with + (h | h | ⟨_, _, _, h⟩ | ⟨_, _, _, h⟩ | ⟨p₁, p₂, hp, hq, h⟩ | ⟨_, _, _, _, h⟩ | + ⟨_, _, h⟩ | ⟨u, q', _, _, h⟩) <;> + simp only [qqAnd, qqVerum, qqFalsum, qqRel, qqNRel, qqOr, qqExs, qqBall, qqAll, + add_left_inj, pair_ext_iff, OfNat.ofNat_eq_ofNat, Nat.reduceEqDiff, OfNat.ofNat_ne_zero, + OfNat.ofNat_ne_one, Nat.succ_ne_self, false_and, true_and] at h + · obtain ⟨rfl, rfl⟩ := h; exact ⟨hp, hq⟩ + · rintro ⟨hp, hq⟩ + exact IsSigma1.mk <| by grind; + +@[simp] +lemma IsSigma1.or_iff {p q : V} : IsSigma1 (p ^⋎ q) ↔ IsSigma1 p ∧ IsSigma1 q := + by + constructor + · intro h + rcases h.case with + (h | h | ⟨_, _, _, h⟩ | ⟨_, _, _, h⟩ | ⟨_, _, _, _, h⟩ | ⟨p₁, p₂, hp, hq, h⟩ | + ⟨_, _, h⟩ | ⟨u, q', _, _, h⟩) <;> + simp only [qqOr, qqVerum, qqFalsum, qqRel, qqNRel, qqAnd, qqExs, qqBall, qqAll, + add_left_inj, pair_ext_iff, OfNat.ofNat_eq_ofNat, Nat.reduceEqDiff, OfNat.ofNat_ne_zero, + OfNat.ofNat_ne_one, Nat.succ_ne_self, false_and, true_and] at h + · obtain ⟨rfl, rfl⟩ := h; exact ⟨hp, hq⟩ + · rintro ⟨hp, hq⟩ + exact IsSigma1.mk <| by grind; + +@[simp] +lemma IsSigma1.ex_iff {p : V} : IsSigma1 (^∃ p) ↔ IsSigma1 p := + by + constructor + · intro h + rcases h.case with + (h | h | ⟨_, _, _, h⟩ | ⟨_, _, _, h⟩ | ⟨_, _, _, _, h⟩ | ⟨_, _, _, _, h⟩ | ⟨p₁, hp, h⟩ | + ⟨u, q', _, _, h⟩) <;> + simp only [qqExs, qqVerum, qqFalsum, qqRel, qqNRel, qqAnd, qqOr, qqBall, qqAll, + add_left_inj, pair_ext_iff, OfNat.ofNat_eq_ofNat, Nat.reduceEqDiff, OfNat.ofNat_ne_zero, + OfNat.ofNat_ne_one, Nat.succ_ne_self, false_and, true_and] at h + · obtain rfl := h; exact hp + · rintro hp + exact IsSigma1.mk <| by grind; + +lemma IsSigma1.of_all {p : V} (h : IsSigma1 (^∀ p)) : + ∃ u q, + (∃ t, IsUTerm ℒₒᵣ t ∧ u = termBShift ℒₒᵣ t) ∧ + IsSigma1 q ∧ p = qqOr (ObjectArithmetic.qqNLT (qqBvar 0) u) q := + by + rcases h.case with + (h | h | ⟨_, _, _, h⟩ | ⟨_, _, _, h⟩ | ⟨_, _, _, _, h⟩ | ⟨_, _, _, _, h⟩ | ⟨_, _, h⟩ | + ⟨u, q, hguard, hq, h⟩) <;> + first + | ( simp [qqAll, qqVerum, qqFalsum, qqRel, qqNRel, qqAnd, qqOr, qqExs] at h + done) + | ( rw [show qqBall u q = ^∀ (qqOr (ObjectArithmetic.qqNLT (qqBvar 0) u) q) from rfl, + qqAll_inj] at h + exact ⟨u, q, hguard, hq, h⟩) + +end isSigma1 + +end Bootstrapping +end Arithmetic +end FirstOrder +end FFL + +namespace FFL +namespace FirstOrder +namespace Arithmetic + +open FFL.FirstOrder.Theory + +/-! ## `𝐏𝐀⁻` is `Δ₁` -/ + +noncomputable instance PeanoMinus.delta1 : (𝐏𝐀⁻ : ArithmeticTheory).Δ₁ := + Theory.Δ₁.ofFinite _ PeanoMinus.finite + +/-! ## Typed decomposition of `succInd` -/ + +section succInd + +variable {V : Type*} [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +lemma succInd_eq (φ : ArithmeticSemiproposition 1) : + succInd φ = + ((φ ↜ (![‘0’] : Fin 1 → ArithmeticSemiterm ℕ 0)) ⇒ₗ + ((∀¹ (φ ⇒ₗ (φ ↜ (![‘#0 + 1’] : Fin 1 → ArithmeticSemiterm ℕ 1)))) ⇒ₗ ∀¹ φ)) := + by unfold succInd; simp + +lemma typed_quote_succInd (φ : ArithmeticSemiproposition 1) : + (⌜succInd φ⌝ : Bootstrapping.Semiformula V ℒₒᵣ 0) = + (⌜φ ↜ (![‘0’] : Fin 1 → ArithmeticSemiterm ℕ 0)⌝) ⇒ₗ + ((∀¹ (⌜φ⌝ ⇒ₗ ⌜φ ↜ (![‘#0 + 1’] : Fin 1 → ArithmeticSemiterm ℕ 1)⌝)) ⇒ₗ ∀¹ ⌜φ⌝) := + by + unfold succInd + rw [show φ ↜ (![#0] : Fin 1 → ArithmeticSemiterm ℕ 1) = φ from by simp] + simp + +/-- The typed `succInd` shape as a function of the (typed) core code `K = ⌜ψ⌝`. -/ +noncomputable def indBody (K : Bootstrapping.Semiformula V ℒₒᵣ 1) : + Bootstrapping.Semiformula V ℒₒᵣ 0 := + (K.subst ![⌜(‘0’ : ArithmeticSemiterm ℕ 0)⌝]) ⇒ₗ + ((∀¹ (K ⇒ₗ K.subst ![⌜(‘#0 + 1’ : ArithmeticSemiterm ℕ 1)⌝])) ⇒ₗ ∀¹ K) + +lemma indBody_quote (φ : ArithmeticSemiproposition 1) : + indBody (⌜φ⌝ : Bootstrapping.Semiformula V ℒₒᵣ 1) = ⌜succInd φ⌝ := by + rw [typed_quote_succInd]; unfold indBody; simp [Matrix.constant_eq_singleton] + +/-- The raw `V → V` form of `(indBody ·).val`. -/ +noncomputable def indBodyVal (k : V) : V := + Bootstrapping.imp ℒₒᵣ + (Bootstrapping.subst ℒₒᵣ + (Bootstrapping.SemitermVec.val + (![⌜(‘0’ : ArithmeticSemiterm ℕ 0)⌝] : Bootstrapping.SemitermVec V ℒₒᵣ 1 0)) + k) + (Bootstrapping.imp ℒₒᵣ + (Bootstrapping.qqAll + (Bootstrapping.imp ℒₒᵣ k + (Bootstrapping.subst ℒₒᵣ + (Bootstrapping.SemitermVec.val + (![⌜(‘#0 + 1’ : ArithmeticSemiterm ℕ 1)⌝] : Bootstrapping.SemitermVec V ℒₒᵣ 1 1)) + k))) + (Bootstrapping.qqAll k)) + +lemma indBodyVal_eq (K : Bootstrapping.Semiformula V ℒₒᵣ 1) : + indBodyVal K.val = (indBody K).val := by + simp only [indBodyVal, indBody, Bootstrapping.Semiformula.val_imp, + Bootstrapping.Semiformula.val_all, Bootstrapping.Semiformula.val_substs] + +lemma le_indBodyVal (k : V) : k ≤ indBodyVal k := + by + unfold indBodyVal Bootstrapping.imp + exact + (Bootstrapping.le_qqAll _).trans + (le_of_lt ((Bootstrapping.lt_or_right _ _).trans (Bootstrapping.lt_or_right _ _))) + +lemma indBodyVal_quote (γ : ArithmeticSemiproposition 1) : + indBodyVal (⌜γ⌝ : ℕ) = (⌜succInd γ⌝ : ℕ) := + by + rw [show (⌜γ⌝ : ℕ) = (⌜γ⌝ : Bootstrapping.Semiformula ℕ ℒₒᵣ 1).val from rfl, indBodyVal_eq, + indBody_quote] + rfl + +instance indBodyVal_definable : Σ₁-Function₁ (indBodyVal : V → V) := + by + unfold indBodyVal + definability + +/-! ### A concrete `Σ₁`-graph for `indBodyVal` -/ + +/-- Standard `ℕ`-code of the substitution vector `![⌜‘0’⌝]` (the `ψ(0)` instance). -/ +def indSubstConst0 : ℕ := + Matrix.vecToNat fun i : Fin 1 ↦ Encodable.encode ((![(‘0’ : ArithmeticSemiterm ℕ 0)]) i) + +/-- Standard `ℕ`-code of the substitution vector `![⌜‘#0+1’⌝]` (the `ψ(x+1)` instance). -/ +def indSubstConst1 : ℕ := + Matrix.vecToNat fun i : Fin 1 ↦ Encodable.encode ((![(‘#0 + 1’ : ArithmeticSemiterm ℕ 1)]) i) + +lemma val_indSubstConst0 : + (↑indSubstConst0 : V) = + Bootstrapping.SemitermVec.val + (![⌜(‘0’ : ArithmeticSemiterm ℕ 0)⌝] : Bootstrapping.SemitermVec V ℒₒᵣ 1 0) := + by + rw [indSubstConst0, ← + FFL.FirstOrder.Semiterm.quote_eq_encode' (V := V) (![(‘0’ : ArithmeticSemiterm ℕ 0)])] + congr 1; funext i; simp [Matrix.cons_val_fin_one] + +lemma val_indSubstConst1 : + (↑indSubstConst1 : V) = + Bootstrapping.SemitermVec.val + (![⌜(‘#0 + 1’ : ArithmeticSemiterm ℕ 1)⌝] : Bootstrapping.SemitermVec V ℒₒᵣ 1 1) := + by + rw [indSubstConst1, ← + FFL.FirstOrder.Semiterm.quote_eq_encode' (V := V) (![(‘#0 + 1’ : ArithmeticSemiterm ℕ 1)])] + congr 1; funext i; simp [Matrix.cons_val_fin_one] + +/-- Concrete `Σ₁`-graph of `indBodyVal`, a chain of the `subst`/`imp`/`qqAll` graphs. -/ +noncomputable def indBodyValGraph : Σ₁.Semisentence 2 := .mkSigma + “y k. + ∃ a, !(Bootstrapping.substsGraph ℒₒᵣ) a ↑indSubstConst0 k ∧ + ∃ s1, !(Bootstrapping.substsGraph ℒₒᵣ) s1 ↑indSubstConst1 k ∧ + ∃ i1, !(Bootstrapping.impGraph ℒₒᵣ) i1 k s1 ∧ + ∃ qa1, !qqAllDef qa1 i1 ∧ + ∃ qak, !qqAllDef qak k ∧ + ∃ i2, !(Bootstrapping.impGraph ℒₒᵣ) i2 qa1 qak ∧ + !(Bootstrapping.impGraph ℒₒᵣ) y a i2” + +instance indBodyVal.defined : Σ₁-Function₁ (indBodyVal : V → V) via indBodyValGraph := + .mk fun v ↦ by + simp [indBodyValGraph, numeral_eq_natCast, val_indSubstConst0, val_indSubstConst1, + indBodyVal] + +end succInd + +/-! ## The induction schema is `Δ₁` -/ + +section ch + +variable {V : Type*} [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +open Bootstrapping + +/-- +The recognizer predicate for `InductionScheme ℒₒᵣ C` over a model `V`, parameterized by a side +condition `S` on the recovered core. -/ +def InductionR (S : V → Prop) (p : V) : Prop := + ∃ m ≤ p, + ∃ b ≤ p, + p = qqAlls b m ∧ + IsUFormula ℒₒᵣ b ∧ + shift ℒₒᵣ b = b ∧ + bv ℒₒᵣ b = m ∧ + ∃ K ≤ subst ℒₒᵣ (fvarVec m) b, + IsSemiformula ℒₒᵣ 1 K ∧ S K ∧ subst ℒₒᵣ (fvarVec m) b = indBodyVal K + +end ch + +/-- Concrete `∆₁.Semisentence 1` recognizer for `InductionR cond`. -/ +noncomputable def chInd (cond : ∆₁.Semisentence 1) : ∆₁.Semisentence 1 := .mkDelta + (.mkSigma “p. + ∃ m < p + 1, ∃ b < p + 1, + !qqAllsDef p b m ∧ !(Bootstrapping.isUFormula ℒₒᵣ).sigma b + ∧ !(Bootstrapping.shiftGraph ℒₒᵣ) b b ∧ !(Bootstrapping.bvGraph ℒₒᵣ) m b + ∧ ∃ fv, !fvarVecDef fv m ∧ ∃ s, !(Bootstrapping.substsGraph ℒₒᵣ) s fv b + ∧ ∃ K < s + 1, !(Bootstrapping.isSemiformula ℒₒᵣ).sigma 1 K + ∧ !cond.sigma K ∧ !indBodyValGraph s K”) + (.mkPi “p. + ∃ m < p + 1, ∃ b < p + 1, + (∀ y, !qqAllsDef y b m → y = p) ∧ !(Bootstrapping.isUFormula ℒₒᵣ).pi b + ∧ (∀ y, !(Bootstrapping.shiftGraph ℒₒᵣ) y b → y = b) ∧ (∀ y, !(Bootstrapping.bvGraph ℒₒᵣ) + y b → y = m) + ∧ ∀ fv, !fvarVecDef fv m → ∀ s, !(Bootstrapping.substsGraph ℒₒᵣ) s fv b + → ∃ K < s + 1, !(Bootstrapping.isSemiformula ℒₒᵣ).pi 1 K + ∧ !cond.pi K ∧ ∀ ib, !indBodyValGraph ib K → s = ib”) + + + +/-- The ch Univ construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def chUniv : ∆₁.Semisentence 1 := + chInd ⊤ + +/-- The ch Sigma1 construction in `FFL.FirstOrder.Arithmetic`. -/ +noncomputable def chSigma1 : ∆₁.Semisentence 1 := + chInd Bootstrapping.isSigma1 + +section chDefined + +variable {V : Type*} [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +open Bootstrapping + +instance InductionR.defined {S : V → Prop} {cond : ∆₁.Semisentence 1} + [hcond : ∆₁-Predicate[V] S via cond] : + ∆₁-Predicate[V] (InductionR S : V → Prop) via chInd cond := + .mk <| by + constructor + · intro v; simp [chInd, HierarchySymbol.Semiformula.val_sigma, eq_comm] + · intro v + simp [chInd, HierarchySymbol.Semiformula.val_sigma, InductionR, lt_succ_iff_le, eq_comm] + +noncomputable instance InductionR.univ_defined : + ∆₁-Predicate[V] (InductionR (fun _ ↦ True) : V → Prop) via chUniv := + InductionR.defined (hcond := ⟨by simp, by intro v; simp⟩) + +noncomputable instance InductionR.sigma1_defined : + ∆₁-Predicate[V] (InductionR IsSigma1 : V → Prop) via chSigma1 := + InductionR.defined + +end chDefined + +lemma mem_inductionScheme_iff {C : ArithmeticSemiproposition 1 → Prop} + (φ : ArithmeticSemiproposition 0) : + (∃ σ ∈ InductionScheme ℒₒᵣ C, φ = (σ : ArithmeticSemiproposition 0)) ↔ + ∃ ψ : ArithmeticSemiproposition 1, C ψ ∧ φ = (succInd ψ).univCl' := + by + simp only [InductionScheme, Set.mem_ofPred_eq] + constructor + · rintro ⟨σ, ⟨ψ, hψ, rfl⟩, rfl⟩ + exact ⟨ψ, hψ, by simp [Semiformula.coe_univCl_eq_univCl']⟩ + · rintro ⟨ψ, hψ, rfl⟩ + exact + ⟨Semiformula.univCl (succInd ψ), ⟨ψ, hψ, rfl⟩, by + simp [Semiformula.coe_univCl_eq_univCl']⟩ + +/-- A freevar-free, `bv`-pinned formula `β` that substitutes back to `succInd γ` is exactly the +`fixitr`-image, so its `m`-fold closure equals `(succInd γ).univCl'`. -/ +theorem closure_inversion {m : ℕ} (β : ArithmeticSemiproposition m) + (γ : ArithmeticSemiproposition 1) (hfree : β.freeVariables = ∅) + (hbv : Bootstrapping.bv (V := ℕ) ℒₒᵣ (⌜β⌝ : ℕ) = m) + (hβγ : β ↜ (fun i : Fin m ↦ (&↑i : SyntacticTerm ℒₒᵣ)) = succInd γ) : + (∀¹* β : ArithmeticSemiproposition 0) = (succInd γ).univCl' := + by + set χ : ArithmeticSemiproposition 0 := succInd γ with hχ + have hcodeβ : (⌜(Rew.fixitr 0 m ▹ χ : ArithmeticSemiproposition (0 + m))⌝ : ℕ) = ⌜β⌝ := + by + have hcompcast : + ((Rew.fixitr 0 m).comp (Rew.subst (fun i : Fin m ↦ (&↑i : SyntacticTerm ℒₒᵣ)))) ▹ β = + (Rew.castLE (Nat.le_add_left m 0) ▹ β : ArithmeticSemiproposition (0 + m)) := + by + apply Semiformula.rew_eq_of_funEqOn + · intro x; simp [Rew.comp_app, Rew.fixitr_fvar, Fin.ext_iff] + · intro x hx; rw [Semiformula.HasFreeVariable, hfree] at hx; simp at hx + have heq : + (Rew.fixitr 0 m ▹ χ : ArithmeticSemiproposition (0 + m)) = + (Rew.castLE (Nat.le_add_left m 0) ▹ β : ArithmeticSemiproposition (0 + m)) := + by + rw [← hcompcast, TransitiveRewriting.comp_app, + show (Rew.subst (fun i : Fin m ↦ (&↑i : SyntacticTerm ℒₒᵣ)) ▹ β) = χ from hβγ] + rw [heq, Semiformula.quote_castLE (V := ℕ) β (Nat.le_add_left m 0)] + have hfvbound : ∀ x, χ.HasFreeVariable x → x < m := + by + intro x hx + rw [show χ = β ↜ (fun i : Fin m ↦ (&↑i : SyntacticTerm ℒₒᵣ)) from hβγ.symm] at hx + rcases Semiformula.hasFreeVariable_rew hx with (⟨i, hi⟩ | ⟨z, hz, _⟩) + · have : x = (↑i : ℕ) := by + simpa [Rew.subst_bvar, Semiterm.HasFreeVariable, Semiterm.freeVariables_fvar] using hi + rw [this]; exact i.isLt + · rw [Semiformula.HasFreeVariable, hfree] at hz; simp at hz + have hfvle : χ.fvSup ≤ m := + by + rcases Nat.eq_zero_or_pos χ.fvSup with h0 | hpos + · omega + · have := hfvbound (χ.fvSup - 1) (Semiformula.hasFreeVariable_fvSup_pred χ hpos); omega + have hcast_eq : + (Rew.fixitr 0 m ▹ χ : ArithmeticSemiproposition (0 + m)) = + (Rew.castLE (by omega : (0 + χ.fvSup) ≤ (0 + m)) ▹ + (Rew.fixitr 0 χ.fvSup ▹ χ : ArithmeticSemiproposition (0 + χ.fvSup))) := + by + rw [← TransitiveRewriting.comp_app] + apply Semiformula.rew_eq_of_funEqOn₀ + intro x hx + have hxlt : x < χ.fvSup := Semiformula.lt_fvSup_of_hasFreeVariable hx + simp [Rew.comp_app, Rew.fixitr_fvar, hxlt, show x < m from by omega] + have hcode : + (⌜(Rew.fixitr 0 m ▹ χ : ArithmeticSemiproposition (0 + m))⌝ : ℕ) = + ⌜(Rew.fixitr 0 χ.fvSup ▹ χ : ArithmeticSemiproposition (0 + χ.fvSup))⌝ := + by + rw [hcast_eq, + Semiformula.quote_castLE (V := ℕ) + (Rew.fixitr 0 χ.fvSup ▹ χ : ArithmeticSemiproposition (0 + χ.fvSup)) (by omega)] + have hm : m = χ.fvSup := by rw [← hbv, ← hcodeβ, hcode]; exact Bootstrapping.bv_quote_fixitr χ + apply (Semiformula.quote_inj_iff (L := ℒₒᵣ) (V := ℕ)).mp + rw [Bootstrapping.quote_allClosure (V := ℕ) β, Semiformula.univCl', + Bootstrapping.quote_allClosure (V := ℕ) (Rew.fixitr 0 χ.fvSup ▹ χ), ← hcodeβ, hcode, hm] + simp + +private lemma freeVariables_eq_empty_of_shift_quote_fixed {m : ℕ} + (β : ArithmeticSemiproposition m) (hsh : Bootstrapping.shift (V := ℕ) ℒₒᵣ (⌜β⌝ : ℕ) = ⌜β⌝) : + β.freeVariables = ∅ := + by + have hsβ : Rewriting.shift β = β := + (Semiformula.quote_inj_iff (L := ℒₒᵣ) (V := ℕ)).mp + (by rw [Semiformula.quote_shift (V := ℕ) β]; exact hsh) + have step : ∀ x, β.HasFreeVariable x → 1 ≤ x ∧ β.HasFreeVariable (x - 1) := + by + intro x hx + rw [← hsβ] at hx + rcases Semiformula.hasFreeVariable_rew hx with (⟨i, hi⟩ | ⟨z, hz, hi⟩) + · simp [Rew.shift_bvar, Semiterm.HasFreeVariable] at hi + · have hxz : x = z + 1 := by + simpa [Rew.shift_fvar, Semiterm.HasFreeVariable, Semiterm.freeVariables_fvar] using hi + exact ⟨by omega, by rw [hxz]; simpa using hz⟩ + by_contra hne + classical + have hnem := Finset.nonempty_of_ne_empty hne + obtain ⟨hge, hpred⟩ := step (β.freeVariables.min' hnem) (β.freeVariables.min'_mem hnem) + exact absurd (β.freeVariables.min'_le _ hpred) (by omega) + +/-- +`InductionR S` fires exactly on codes of universal closures of `succInd ψ` for `ψ` with `C ψ`, +given that `S` correctly recognizes the codes of `C`-formulas. -/ +theorem inductionR_quote_iff {S : ℕ → Prop} {C : ArithmeticSemiproposition 1 → Prop} + (hS : ∀ γ, S (⌜γ⌝ : ℕ) ↔ C γ) (φ : ArithmeticSemiproposition 0) : + InductionR S (⌜φ⌝ : ℕ) ↔ ∃ ψ, C ψ ∧ φ = (succInd ψ).univCl' := + by + constructor + · rintro ⟨m, -, b, -, hp, hU, hsh, hbv, K, -, hKsemi, hKS, hsubst⟩ + obtain ⟨γ, rfl⟩ := Bootstrapping.IsSemiformula.sound hKsemi + have hbsemi : Bootstrapping.IsSemiformula ℒₒᵣ m b := hbv ▸ hU.isSemiformula + obtain ⟨β, rfl⟩ := Bootstrapping.IsSemiformula.sound hbsemi + refine ⟨γ, (hS γ).mp hKS, ?_⟩ + have hβγ : β ↜ (fun i : Fin m ↦ (&↑i : SyntacticTerm ℒₒᵣ)) = succInd γ := + by + apply (Semiformula.quote_inj_iff (L := ℒₒᵣ) (V := ℕ)).mp + have e := Bootstrapping.subst_fvarVec_quote' (V := ℕ) β + simp only [natCast_nat] at e + rw [← e, hsubst, indBodyVal_quote] + have hβfree : β.freeVariables = ∅ := freeVariables_eq_empty_of_shift_quote_fixed β hsh + have hφ : φ = (∀¹* β : ArithmeticSemiproposition 0) := + by + apply (Semiformula.quote_inj_iff (L := ℒₒᵣ) (V := ℕ)).mp + rw [hp, Bootstrapping.quote_allClosure (V := ℕ) β]; simp + rw [hφ] + exact closure_inversion β γ hβfree hbv hβγ + · rintro ⟨ψ, hψ, rfl⟩ + set χ : ArithmeticSemiproposition 0 := succInd ψ with hχ + set b : ℕ := + (⌜(Rew.fixitr 0 χ.fvSup ▹ χ : ArithmeticSemiproposition (0 + χ.fvSup))⌝ : ℕ) with hb + have hcode : (⌜χ.univCl'⌝ : ℕ) = Bootstrapping.qqAlls b ((0 + χ.fvSup : ℕ)) := by + rw [hb, Bootstrapping.quote_univCl' (V := ℕ) χ]; simp + have hs : + Bootstrapping.subst ℒₒᵣ (Bootstrapping.fvarVec (0 + χ.fvSup : ℕ)) b = + indBodyVal (⌜ψ⌝ : ℕ) := + by + rw [hb] + have hsub := + Bootstrapping.subst_fvarVec_quote' (V := ℕ) + (Rew.fixitr 0 χ.fvSup ▹ χ : ArithmeticSemiproposition (0 + χ.fvSup)) + simp only [natCast_nat] at hsub + rw [hsub, Bootstrapping.quote_subst_fvar_fixitr χ, + show (⌜ψ⌝ : ℕ) = (⌜ψ⌝ : Bootstrapping.Semiformula ℕ ℒₒᵣ 1).val from rfl, indBodyVal_eq, + indBody_quote, hχ] + rfl + refine ⟨(0 + χ.fvSup : ℕ), ?_, b, ?_, ?_, ?_, ?_, ?_, (⌜ψ⌝ : ℕ), ?_, ?_, ?_, ?_⟩ + · rw [hcode]; exact Bootstrapping.index_le_qqAlls _ _ + · rw [hcode]; exact Bootstrapping.le_qqAlls _ _ + · exact hcode + · rw [hb] + exact + (Semiformula.quote_isSemiformula (V := ℕ) + (Rew.fixitr 0 χ.fvSup ▹ χ : ArithmeticSemiproposition (0 + χ.fvSup))).isUFormula + · rw [hb]; exact Bootstrapping.quote_shift_fixitr χ + · rw [hb]; exact (Bootstrapping.bv_quote_fixitr χ).trans (zero_add _).symm + · rw [hs]; exact le_indBodyVal _ + · simp + · exact (hS ψ).mpr hψ + · exact hs + +/-- The induction schema `InductionScheme ℒₒᵣ Set.univ` is `Δ₁`, via the recognizer `chUniv`. -/ +noncomputable instance InductionScheme.delta1Univ : (InductionScheme ℒₒᵣ Set.univ).Δ₁ + where + ch := chUniv + mem_iff + φ := + by + have h : (ℕ ⊧/![(⌜φ⌝ : ℕ)] chUniv.val) ↔ InductionR (fun _ ↦ True) (⌜φ⌝ : ℕ) := by simp + rw [h] + exact + (inductionR_quote_iff (C := Set.univ) (fun _ ↦ Iff.rfl) φ).trans + (mem_inductionScheme_iff φ).symm + isDelta1 := + HierarchySymbol.Semiformula.ProvablyProperOn.ofProperOn.{0} _ fun V _ _ ↦ by + have := InductionR.univ_defined (V := V); simp + +/-! ## Correctness of `IsSigma1`: `IsSigma1 ⌜ψ⌝ ↔ Hierarchy Σ 1 ψ` -/ + +open Bootstrapping in +lemma quote_ball {n : ℕ} (t : SyntacticSemiterm ℒₒᵣ n) (φ : ArithmeticSemiproposition (n + 1)) : + (⌜(∀¹[“#0 < !!(Rew.bShift t)”] φ : ArithmeticSemiproposition n)⌝ : ℕ) = + qqBall (termBShift ℒₒᵣ (⌜t⌝ : ℕ)) (⌜φ⌝ : ℕ) := + by + rw [Semiformula.ball_eq, Semiformula.imp_eq] + simp only [Semiformula.Operator.lt_def, Semiformula.neg_rel, Semiformula.quote_all, + Semiformula.quote_or, qqBall, qqAll_inj, qqOr_inj, and_true] + simp [Semiformula.quote_nrel, ObjectArithmetic.qqNLT, ObjectArithmetic.ltIndex, + Semiterm.quote_def, Matrix.vecHead, Matrix.vecTail, Matrix.cons_val_zero, + Matrix.cons_val_one] + rfl + +open Bootstrapping in +lemma termBShift_quote {n : ℕ} (s : SyntacticSemiterm ℒₒᵣ n) : + (⌜Rew.bShift s⌝ : ℕ) = termBShift ℒₒᵣ (⌜s⌝ : ℕ) := by + simp [Semiterm.quote_def, Semiterm.typed_quote_bShift] + +open Bootstrapping in +lemma isSigma1_of_hierarchy {n : ℕ} {ψ : ArithmeticSemiproposition n} (h : Hierarchy Σ 1 ψ) : + IsSigma1 (⌜ψ⌝ : ℕ) := + by + apply sigma₁_induction' h (P := fun n φ => IsSigma1 (⌜φ⌝ : ℕ)); · intro n; simp + · intro n; simp + · intro n t₁ t₂; simp [Semiformula.quote_rel] + · intro n t₁ t₂; simp [Semiformula.quote_nrel] + · intro n t₁ t₂; simp [Semiformula.quote_rel] + · intro n t₁ t₂; simp [Semiformula.quote_nrel] + · intro n φ ψ hφ hψ ihφ ihψ; simpa [Semiformula.quote_and] using ⟨ihφ, ihψ⟩ + · intro n φ ψ hφ hψ ihφ ihψ; simpa [Semiformula.quote_or] using ⟨ihφ, ihψ⟩ + · intro n t φ hφ ihφ + rw [quote_ball] + refine + IsSigma1.mk + (Or.inr + (Or.inr + (Or.inr + (Or.inr + (Or.inr + (Or.inr + (Or.inr + ⟨termBShift ℒₒᵣ (⌜t⌝ : ℕ), (⌜φ⌝ : ℕ), ⟨(⌜t⌝ : ℕ), ?_, rfl⟩, ihφ, + rfl⟩))))))) + simp [Semiterm.quote_def] + · intro n φ hφ ihφ; simpa [Semiformula.quote_ex] using ihφ + +open Bootstrapping in +lemma hierarchy_of_isSigma1 {n : ℕ} (ψ : ArithmeticSemiproposition n) : IsSigma1 (⌜ψ⌝ : ℕ) → + Hierarchy Σ 1 ψ := by + induction ψ using Semiformula.rec' with + | hverum => intro _; simp + | hfalsum => intro _; simp + | hrel R v => intro _; exact Hierarchy.rel _ _ _ _ + | hnrel R v => intro _; exact Hierarchy.nrel _ _ _ _ + | hand φ ψ ihφ ihψ => + intro h; rw [Semiformula.quote_and (V := ℕ) φ ψ, IsSigma1.and_iff] at h + exact Hierarchy.and (ihφ h.1) (ihψ h.2) + | hor φ ψ ihφ ihψ => + intro h; rw [Semiformula.quote_or (V := ℕ) φ ψ, IsSigma1.or_iff] at h + exact Hierarchy.or (ihφ h.1) (ihψ h.2) + | hall φ ihφ => + intro h + rw [Semiformula.quote_all (V := ℕ) φ] at h + obtain ⟨u, q, ⟨t, ht, rfl⟩, hq, hφeq⟩ := IsSigma1.of_all h + have hsf := Semiformula.quote_isSemiformula (V := ℕ) φ + simp only [natCast_nat] at hsf + rw [hφeq, ObjectArithmetic.qqNLT] at hsf + simp only [IsSemiformula.or, IsSemiformula.nrel] at hsf + obtain ⟨⟨_, hvec⟩, hqsf⟩ := hsf + obtain ⟨φ₂, hφ₂⟩ := Bootstrapping.IsSemiformula.sound hqsf + have htmsf := hvec.nth (i := 1) (show (1 : ℕ) < 2 by simp) + simp only [nth_adjoin_one, nth_adjoin_zero] at htmsf + obtain ⟨s, hs⟩ := Bootstrapping.IsSemiterm.sound + ((IsSemiterm.def (L := ℒₒᵣ)).mpr ⟨ht, + (termBV_termBShift_le (L := ℒₒᵣ) ht _).mp ((IsSemiterm.def (L := ℒₒᵣ)).mp htmsf).2⟩) + have heq : (∀¹ φ) = ∀¹[“#0 < !!(Rew.bShift s)”] φ₂ := by + apply (Semiformula.quote_inj_iff (L := ℒₒᵣ) (V := ℕ)).mp + rw [Semiformula.quote_all (V := ℕ) φ, hφeq, quote_ball, hs, hφ₂] + rfl + have hφ : Hierarchy Σ 1 φ := ihφ (by rw [hφeq]; simp [IsSigma1.or_iff, hq, + ObjectArithmetic.qqNLT]) + have hφ2 : Hierarchy Σ 1 φ₂ := by + have hform : φ = (“#0 < !!(Rew.bShift s)” ⇒ₗ φ₂) := + (Semiformula.all_inj _ _).mp (by rw [← Semiformula.ball_eq]; exact heq) + rw [hform, Semiformula.imp_eq, Hierarchy.or_iff] at hφ + exact hφ.2 + rw [heq] + exact Hierarchy.ball (Rew.positive_iff.mpr ⟨s, rfl⟩) hφ2 + | hexs φ ihφ => + intro h; rw [Semiformula.quote_ex (V := ℕ) φ, IsSigma1.ex_iff] at h + exact Hierarchy.exs (ihφ h) + +/-- Correctness of the `Σ₁`-code recognizer. -/ +lemma isSigma1_iff_hierarchy {n : ℕ} (ψ : ArithmeticSemiproposition n) : + Bootstrapping.IsSigma1 (⌜ψ⌝ : ℕ) ↔ Hierarchy Σ 1 ψ := + ⟨hierarchy_of_isSigma1 ψ, isSigma1_of_hierarchy⟩ + +/-- The induction schema `InductionScheme ℒₒᵣ (Hierarchy Σ 1)` is `Δ₁`, via `chSigma1`. -/ +noncomputable instance InductionScheme.delta1Sigma1 : + (InductionScheme ℒₒᵣ (Arithmetic.Hierarchy Σ 1)).Δ₁ + where + ch := chSigma1 + mem_iff + φ := + by + have h : (ℕ ⊧/![(⌜φ⌝ : ℕ)] chSigma1.val) ↔ InductionR Bootstrapping.IsSigma1 (⌜φ⌝ : ℕ) := by + simp + rw [h] + exact (inductionR_quote_iff isSigma1_iff_hierarchy φ).trans (mem_inductionScheme_iff φ).symm + isDelta1 := + HierarchySymbol.Semiformula.ProvablyProperOn.ofProperOn.{0} _ fun V _ _ ↦ by + have := InductionR.sigma1_defined (V := V); simp + +/-! ## `𝐏𝐀` and `𝐈Σ₁` are recursively enumerable -/ + +lemma inductionScheme_re_univ : REPred (· ∈ InductionScheme ℒₒᵣ Set.univ) := + by + have hR : REPred (InductionR fun _ : ℕ ↦ True) := rePred_iff_sigma1.mpr (by definability) + refine REPred.of_eq (REPred.comp Computable.encode hR) <| fun σ ↦ ?_; + simpa [Semiformula.quote_eq_encode] using + (inductionR_quote_iff (S := fun _ : ℕ ↦ True) (C := Set.univ) (fun _ ↦ Iff.rfl) σ).trans + (mem_inductionScheme_iff σ).symm + +lemma inductionScheme_re_sigma1 : REPred (· ∈ InductionScheme ℒₒᵣ (Arithmetic.Hierarchy Σ 1)) := + by + have hR : REPred (InductionR Bootstrapping.IsSigma1) := + rePred_iff_sigma1.mpr <| + HierarchySymbol.Definable.of_deltaOne InductionR.sigma1_defined.to_definable + refine REPred.of_eq (REPred.comp Computable.encode hR) fun σ ↦ ?_ + simpa [Semiformula.quote_eq_encode] using + (inductionR_quote_iff isSigma1_iff_hierarchy σ).trans (mem_inductionScheme_iff σ).symm + +instance : (InductionScheme ℒₒᵣ Set.univ).RE := + ⟨inductionScheme_re_univ⟩ + +instance : (InductionScheme ℒₒᵣ (Arithmetic.Hierarchy Σ 1)).RE := + ⟨inductionScheme_re_sigma1⟩ + +instance : 𝐏𝐀.RE := + Theory.RE.add (Theory.RE.ofFinite PeanoMinus.finite) inferInstance + +instance : 𝐈Σ₁.RE := + Theory.RE.add (Theory.RE.ofFinite PeanoMinus.finite) inferInstance + +/-! ## `𝐏𝐀` and `𝐈Σ₁` are `Δ₁` + +TODO: remove. Not mathematically essential — `RE` above already suffices. -/ + +noncomputable instance : 𝐏𝐀.Δ₁ := + Theory.Δ₁.add PeanoMinus.delta1 InductionScheme.delta1Univ + +noncomputable instance : 𝐈Σ₁.Δ₁ := + Theory.Δ₁.add PeanoMinus.delta1 InductionScheme.delta1Sigma1 + +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Incompleteness/First.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Incompleteness/First.lean new file mode 100644 index 000000000..049e3c657 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Incompleteness/First.lean @@ -0,0 +1,100 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Incompleteness.StandardProvability +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.R0.Representation +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.CraigTrick + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +/-! +# Gödel's first incompleteness theorem for arithmetic theories stronger than $\mathsf{R_0}$ +-/ + +namespace FFL +namespace FirstOrder +namespace Arithmetic + +open FFL.Entailment Bootstrapping Bootstrapping.ObjectArithmetic + +/-- Gödel's first incompleteness theorem -/ +theorem incomplete (T : ArithmeticTheory) [T.Δ₁] [𝐑₀ ≼ T] [T.SoundOnHierarchy Σ 1] : + Incomplete T := by + have con : Consistent T := inferInstance + let D : ℕ → Prop := fun φ : ℕ ↦ + IsSemiformula ℒₒᵣ 1 φ ∧ Provable T (neg ℒₒᵣ <| subst ℒₒᵣ ?[numeral φ] φ) + have D_re : REPred D := + by + have : + Σ₁-Predicate fun φ : ℕ ↦ + IsSemiformula ℒₒᵣ 1 φ ∧ Provable T (neg ℒₒᵣ <| subst ℒₒᵣ ?[numeral φ] φ) := + by definability + exact rePred_iff_sigma1.mpr this + have D_spec (φ : ArithmeticSemisentence 1) : D ⌜φ⌝ ↔ T ⊢ ∼φ/[⌜φ⌝] := by + simp [D, ← provable_iff_provable, Sentence.quote_def, Rewriting.emb_subst_eq_subst_coe₁, + Semiformula.quote_def] + let δ : ArithmeticSemisentence 1 := codeOfREPred D + have (n : ℕ) : D n ↔ T ⊢ δ/[↑n] := by + simpa [Semiformula.coe_subst_eq_subst_coe₁] using rePred_weak_representation D_re + let π : ArithmeticSentence := δ/[⌜δ⌝] + have : T ⊢ π ↔ T ⊢ ∼π := + calc + T ⊢ π ↔ T ⊢ δ/[⌜δ⌝] := by rfl + _ ↔ D ⌜δ⌝ := by simpa using (this ⌜δ⌝).symm + _ ↔ T ⊢ ∼δ/[⌜δ⌝] := (D_spec δ) + _ ↔ T ⊢ ∼π := by rfl + refine incomplete_def.mpr ⟨π, ?_, ?_⟩ + · intro h + exact + not_consistent_iff_inconsistent.mpr (inconsistent_of_provable_of_unprovable h (this.mp h)) + inferInstance + · intro h + exact + not_consistent_iff_inconsistent.mpr + (inconsistent_of_provable_of_unprovable (this.mpr h) h) inferInstance + +theorem exists_true_but_unprovable_sentence_of_sigma1sound (T : ArithmeticTheory) [T.Δ₁] + [𝐑₀ ≼ T] [T.SoundOnHierarchy Σ 1] : ∃ δ : ArithmeticSentence, ℕ↓[ℒₒᵣ] ⊧ δ ∧ T ⊬ δ := + exists_true_but_unprovable_sentence_of_incomplete (Arithmetic.incomplete T) + +instance {T : ArithmeticTheory} [T.RE] [𝐑₀ ≼ T] : 𝐑₀ ≼ T.craig := + WeakerThan.trans (𝓣 := T) inferInstance (inferInstance : T ≼ T.craig) + +instance {T : ArithmeticTheory} [T.RE] [T.SoundOnHierarchy Σ 1] : + ArithmeticTheory.SoundOnHierarchy (T.craig) Σ 1 := + ArithmeticTheory.SoundOn.of_weakerThan _ T T.craig + +/-- Gödel's first incompleteness theorem for r.e. theories -/ +theorem incomplete_of_RE (T : ArithmeticTheory) [T.RE] [𝐑₀ ≼ T] [T.SoundOnHierarchy Σ 1] : + Incomplete T := + (Equiv.incomplete_iff (inferInstance : T ≊ T.craig)).mpr (incomplete T.craig) + +theorem exists_true_but_unprovable_sentence_of_RE_of_sigma1sound (T : ArithmeticTheory) [T.RE] + [𝐑₀ ≼ T] [T.SoundOnHierarchy Σ 1] : ∃ δ : ArithmeticSentence, ℕ↓[ℒₒᵣ] ⊧ δ ∧ T ⊬ δ := + exists_true_but_unprovable_sentence_of_incomplete (incomplete_of_RE T) + +instance {T : ArithmeticTheory} [ℕ↓[ℒₒᵣ] ⊧* T] [T.Δ₁] [𝐑₀ ≼ T] [T.SoundOnHierarchy Σ 1] : + T ≺ 𝐓𝐀 := by + constructor; · infer_instance + · obtain ⟨δ, δTrue, δUnprov⟩ := exists_true_but_unprovable_sentence_of_sigma1sound T; + exact not_weakerThan_iff.mpr ⟨δ, TA.provable_iff.mpr δTrue, δUnprov⟩ + +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Incompleteness/ProvabilityAbstraction/Basic.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Incompleteness/ProvabilityAbstraction/Basic.lean new file mode 100644 index 000000000..8ccbb2afb --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Incompleteness/ProvabilityAbstraction/Basic.lean @@ -0,0 +1,403 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Basic +public import LeanPool.PointwiseComposition.Foundation.Meta.ClProver + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +/-! +# Abstract incompleteness theorems and related results +-/ + +namespace FFL + +open FFL.Entailment + +namespace FirstOrder + +variable {L₀ L : Language} + +/-- The Referenceable By construction in `FFL.FirstOrder.Language`. -/ +abbrev Language.ReferenceableBy (L L₀ : Language) := + Semiterm.Operator.GödelNumber L₀ (Sentence L) + +namespace ProvabilityAbstraction + +/-- Data and laws for Provability in `FFL.FirstOrder.ProvabilityAbstraction`. -/ +structure Provability [L.ReferenceableBy L₀] (T₀ : Theory L₀) (T : Theory L) where + /-- The prov construction in `FFL.FirstOrder.ProvabilityAbstraction.Provability`. -/ + prov : Semisentence L₀ 1 + /-- Derivability condition `D1` -/ + bew_def {σ : Sentence L} : T ⊢ σ → T₀ ⊢ prov/[⌜σ⌝] + +namespace Provability + +variable [L.ReferenceableBy L₀] {T₀ : Theory L₀} {T : Theory L} + +/-- The pr construction in `FFL.FirstOrder.ProvabilityAbstraction.Provability`. -/ +@[coe] +def pr (𝔅 : Provability T₀ T) (σ : Sentence L) : Sentence L₀ := + 𝔅.prov/[⌜σ⌝] + +instance : CoeFun (Provability T₀ T) (fun _ ↦ Sentence L → Sentence L₀) := + ⟨pr⟩ + +/-- The con construction in `FFL.FirstOrder.ProvabilityAbstraction.Provability`. -/ +def con (𝔅 : Provability T₀ T) : Sentence L₀ := + ∼𝔅 ⊥ + +/-- The dia construction in `FFL.FirstOrder.ProvabilityAbstraction.Provability`. -/ +abbrev dia (𝔅 : Provability T₀ T) (φ : Sentence L) : Sentence L₀ := + ∼𝔅 (∼φ) + +end Provability + +section + +namespace Provability + +section + +variable {L₀ L : Language} [L.ReferenceableBy L₀] {T₀ : Theory L₀} {T : Theory L} + +lemma D1 {𝔅 : Provability T₀ T} {σ : Sentence L} : T ⊢ σ → T₀ ⊢ 𝔅 σ := fun h ↦ 𝔅.bew_def h + +/-- Data and laws for HBL2 in `FFL.FirstOrder.ProvabilityAbstraction.Provability`. -/ +class HBL2 [L.ReferenceableBy L₀] {T₀ : Theory L₀} {T : Theory L} (𝔅 : Provability T₀ T) where + D2 {σ τ : Sentence L} : T₀ ⊢ 𝔅 (σ ⇒ₗ τ) ⇒ₗ 𝔅 σ ⇒ₗ 𝔅 τ + +export HBL2 (D2) + +variable [L.ReferenceableBy L] {T₀ T : Theory L} (𝔅 : Provability T₀ T) + +/-- Data and laws for HBL3 in `FFL.FirstOrder.ProvabilityAbstraction.Provability`. -/ +class HBL3 where + D3 {σ : Sentence L} : T₀ ⊢ 𝔅 σ ⇒ₗ 𝔅 (𝔅 σ) + +export HBL3 (D3) + +/-- Data and laws for HBL in `FFL.FirstOrder.ProvabilityAbstraction.Provability`. -/ +class HBL extends 𝔅.HBL2, 𝔅.HBL3 + +/-- Data and laws for Mono in `FFL.FirstOrder.ProvabilityAbstraction.Provability`. -/ +class Mono [L.ReferenceableBy L₀] {T₀ : Theory L₀} {T : Theory L} (𝔅 : Provability T₀ T) where + mono {σ τ : Sentence L} : T ⊢ σ ⇒ₗ τ → T₀ ⊢ 𝔅 σ ⇒ₗ 𝔅 τ + +export Mono (mono) + +/-- Data and laws for Ext in `FFL.FirstOrder.ProvabilityAbstraction.Provability`. -/ +class Ext [L.ReferenceableBy L₀] {T₀ : Theory L₀} {T : Theory L} (𝔅 : Provability T₀ T) where + ext {σ τ : Sentence L} : T ⊢ σ ⇔ₗ τ → T₀ ⊢ 𝔅 σ ⇔ₗ 𝔅 τ + +export Ext (ext) + +/-- Data and laws for Rosser in `FFL.FirstOrder.ProvabilityAbstraction.Provability`. -/ +class Rosser [L.ReferenceableBy L₀] {T₀ : Theory L₀} {T : Theory L} (𝔅 : Provability T₀ T) where + Ros {σ : Sentence L} : T ⊢ ∼σ → T₀ ⊢ ∼𝔅 σ + +export Rosser (Ros) + +/-- Abstract version of formalized `Γ`-completeness for provability `𝔅`. + + example: `[∀ σ ∈ Σ₁, 𝔅.FormalizedCompleteOn σ]` for formalized `Σ₁`-completeness. +-/ +class FormalizedCompleteOn (𝔅 : Provability T₀ T) (σ) where + formalized_complete_on : T₀ ⊢ σ ⇒ₗ 𝔅 σ + +export FormalizedCompleteOn (formalized_complete_on) + +attribute [simp, grind .] formalized_complete_on + +instance [∀ σ, 𝔅.FormalizedCompleteOn (𝔅 σ)] : 𝔅.HBL3 := + ⟨by simp⟩ + +/-- NOTE: Named after [Vis21]. +-/ +class Kreisel [L.ReferenceableBy L] {T₀ T : Theory L} (𝔅 : Provability T₀ T) where + KR {σ : Sentence L} : T ⊢ 𝔅 σ → T ⊢ σ + +export Kreisel (KR) + +attribute [grind .] KR + +/-- Data and laws for Sound On in `FFL.FirstOrder.ProvabilityAbstraction.Provability`. -/ +class SoundOn [L.ReferenceableBy L₀] {T₀ : Theory L₀} {T : Theory L} (𝔅 : Provability T₀ T) + (M : outParam Type*) [Nonempty M] [Tarski.Structure L₀ M] where + sound_on {σ : Sentence L} : M↓[L₀] ⊧ (𝔅 σ : Sentence L₀) → T ⊢ σ + +export SoundOn (sound_on) + +attribute [grind .] sound_on + +omit [L.ReferenceableBy L₀] in +lemma syntactical_sound {T₀ T : Theory L} {𝔅 : Provability T₀ T} (M : Type*) [Nonempty M] + [Tarski.Structure L M] [SoundOn 𝔅 M] [M↓[L] ⊧* T₀] : ∀ {σ : Sentence L}, T₀ ⊢ 𝔅 σ → T ⊢ σ := + by + intro σ h; apply 𝔅.sound_on; apply models_of_provable (L := L) (T := T₀); · infer_instance; + · exact h; + +end + +section + +variable [L.ReferenceableBy L₀] {T₀ : Theory L₀} {T : Theory L} {𝔅 : Provability T₀ T} + {σ τ : Sentence L} + +lemma bew_distribute_imply [𝔅.HBL2] (h : T₀ ⊢ 𝔅 (σ ⇒ₗ τ)) : T₀ ⊢ 𝔅 σ ⇒ₗ 𝔅 τ := + D2⨀h + +instance [𝔅.HBL2] : 𝔅.Mono := + ⟨fun h => bew_distribute_imply <| D1 h⟩ + +instance [𝔅.HBL2] : 𝔅.Ext := + ⟨fun h => E_intro (mono (K_left h)) (mono (K_right h))⟩ + +lemma bew_distribute_and [𝔅.HBL2] : T₀ ⊢ 𝔅 (σ ⋏ τ) ⇒ₗ 𝔅 σ ⋏ 𝔅 τ := by + have h₁ : T₀ ⊢ 𝔅 (σ ⋏ τ) ⇒ₗ 𝔅 σ := bew_distribute_imply <| D1 and₁; + have h₂ : T₀ ⊢ 𝔅 (σ ⋏ τ) ⇒ₗ 𝔅 τ := bew_distribute_imply <| D1 and₂; cl_prover[h₁, h₂]; + +lemma bew_distribute_and' [𝔅.HBL2] : T₀ ⊢ 𝔅 (σ ⋏ τ) → T₀ ⊢ 𝔅 σ ⋏ 𝔅 τ := fun h => + bew_distribute_and⨀h + +lemma bew_collect_and [𝔅.HBL2] : T₀ ⊢ 𝔅 σ ⋏ 𝔅 τ ⇒ₗ 𝔅 (σ ⋏ τ) := + by + have h₁ : T₀ ⊢ 𝔅 σ ⇒ₗ 𝔅 (τ ⇒ₗ σ ⋏ τ) := 𝔅.mono <| by cl_prover + have h₂ : T₀ ⊢ 𝔅 (τ ⇒ₗ σ ⋏ τ) ⇒ₗ 𝔅 τ ⇒ₗ 𝔅 (σ ⋏ τ) := D2; cl_prover[h₁, h₂]; + +lemma dia_mono [𝔅.Mono] (h : T ⊢ σ ⇒ₗ τ) : T₀ ⊢ 𝔅.dia σ ⇒ₗ 𝔅.dia τ := + by + have : T₀ ⊢ 𝔅 (∼τ) ⇒ₗ 𝔅 (∼σ) := 𝔅.mono <| by cl_prover[h]; + cl_prover[this] + +end + +section + +variable [L.ReferenceableBy L] {T₀ T : Theory L} [T₀ ≼ T] {𝔅 : Provability T₀ T} + {σ τ : Sentence L} + +lemma mono' [𝔅.Mono] (h : T₀ ⊢ σ ⇒ₗ τ) : T₀ ⊢ 𝔅 σ ⇒ₗ 𝔅 τ := + 𝔅.mono <| WeakerThan.pbl h + +lemma ext' [𝔅.Ext] (h : T₀ ⊢ σ ⇔ₗ τ) : T₀ ⊢ 𝔅 σ ⇔ₗ 𝔅 τ := + 𝔅.ext <| WeakerThan.pbl h + +end + +end Provability + +end + +/-- Data and laws for Diagonalization in `FFL.FirstOrder.ProvabilityAbstraction`. -/ +class Diagonalization [L.ReferenceableBy L] (T : Theory L) where + /-- The fixedpoint construction in `FFL.FirstOrder.ProvabilityAbstraction.Diagonalization`. -/ + fixedpoint : Semisentence L 1 → Sentence L + diag (θ) : T ⊢ fixedpoint θ ⇔ₗ θ/[⌜fixedpoint θ⌝] + +open FFL.Entailment Diagonalization Provability + +variable [L.ReferenceableBy L] {T₀ T : Theory L} [Diagonalization T₀] {𝔅 : Provability T₀ T} + +/-- The gödel construction in `FFL.FirstOrder.ProvabilityAbstraction`. -/ +def gödel (𝔅 : Provability T₀ T) : Sentence L := + fixedpoint T₀ (“x. ¬!𝔅.prov x”) + +lemma gödel_spec : T₀ ⊢ (gödel 𝔅) ⇔ₗ ∼𝔅 (gödel 𝔅) := by + simpa [gödel, Provability.pr] using diag (“x. ¬!𝔅.prov x”); + +section First + +variable [L.DecidableEq] + +variable [T₀ ≼ T] [Consistent T] + +omit [L.DecidableEq] in +theorem unprovable_gödel : T ⊬ (gödel 𝔅) := + by + intro h; have h₁ : T ⊢ 𝔅 (gödel 𝔅) := WeakerThan.pbl <| D1 h; + have h₂ : T ⊢ (gödel 𝔅) ⇔ₗ ∼𝔅 (gödel 𝔅) := WeakerThan.pbl <| gödel_spec; + have : T ⊢ ⊥ := by cl_prover[h₁, h₂, h]; + have : ¬Consistent T := + not_consistent_iff_inconsistent.mpr <| inconsistent_iff_provable_bot.mpr this; + contradiction + +omit [L.DecidableEq] in +theorem unrefutable_gödel [𝔅.Kreisel] : T ⊬ ∼(gödel 𝔅) := + by + intro h₂; + have h₁ : T ⊢ (gödel 𝔅) := WeakerThan.pbl <| 𝔅.KR <| by cl_prover[gödel_spec (T₀ := T₀), h₂]; + have : T ⊢ ⊥ := (N_iff_CO.mp <| WeakerThan.pbl <| h₂)⨀h₁; + have : ¬Consistent T := + not_consistent_iff_inconsistent.mpr <| inconsistent_iff_provable_bot.mpr this + contradiction; + +omit [L.DecidableEq] in +theorem gödel_independent [𝔅.Kreisel] : Independent T (gödel 𝔅) := + by + constructor + · apply unprovable_gödel + · apply unrefutable_gödel + +omit [L.DecidableEq] in +theorem first_incompleteness [𝔅.Kreisel] : Incomplete T := + incomplete_def.mpr ⟨(gödel 𝔅), gödel_independent⟩ + +end First + +section Second + +variable [𝔅.HBL] + +omit [Diagonalization T₀] in +lemma formalized_consistent_of_existance_unprovable [L.DecidableEq] : T₀ ⊢ ∼𝔅 σ ⇒ₗ 𝔅.con := + contra <| mdp D2 <| D1 efq + +local notation "𝐆" => gödel 𝔅 + +variable [L.DecidableEq] [T₀ ≼ T] + +omit [L.DecidableEq] in +/-- Formalized First Incompleteness Theorem -/ +theorem formalized_unprovable_gödel : T₀ ⊢ 𝔅.con ⇒ₗ ∼𝔅 𝐆 := + by + suffices T₀ ⊢ ∼𝔅 ⊥ ⇒ₗ ∼𝔅 𝐆 from this + have h₁ : T₀ ⊢ 𝔅 𝐆 ⇒ₗ 𝔅 (𝔅 𝐆) := D3 + have h₂ : T₀ ⊢ 𝔅 𝐆 ⇒ₗ 𝔅 (𝔅 𝐆 ⇒ₗ ⊥) := 𝔅.mono' <| by cl_prover[gödel_spec (T₀ := T₀)] + have h₃ : T₀ ⊢ 𝔅 (𝔅 𝐆 ⇒ₗ ⊥) ⇒ₗ 𝔅 (𝔅 𝐆) ⇒ₗ 𝔅 ⊥ := D2 + cl_prover[h₁, h₂, h₃] + +theorem gödel_iff_con : T₀ ⊢ 𝐆 ⇔ₗ 𝔅.con := + by + have h₁ : T₀ ⊢ ∼𝔅 𝐆 ⇒ₗ 𝔅.con := formalized_consistent_of_existance_unprovable + have h₂ : T₀ ⊢ 𝔅.con ⇒ₗ ∼𝔅 𝐆 := formalized_unprovable_gödel + have h₃ : T₀ ⊢ 𝐆 ⇔ₗ ∼𝔅 𝐆 := gödel_spec + cl_prover[h₁, h₂, h₃]; + +theorem con_unprovable [Consistent T] : T ⊬ 𝔅.con := + by + intro h + have : T₀ ⊢ 𝐆 ⇔ₗ 𝔅.con := gödel_iff_con + have : T ⊢ 𝐆 := by cl_prover[h, this] + exact unprovable_gödel this + +theorem con_unrefutable [Consistent T] [𝔅.Kreisel] : T ⊬ ∼𝔅.con := + by + intro h + have : T ⊢ 𝐆 ⇔ₗ 𝔅.con := WeakerThan.pbl <| gödel_iff_con; + have : T ⊢ ∼𝐆 := by cl_prover[h, this] + exact unrefutable_gödel this + +theorem con_independent [Consistent T] [𝔅.Kreisel] : Independent T 𝔅.con := + by + constructor + · apply con_unprovable + · apply con_unrefutable + +end Second + +section Löb + +/-- The kreisel construction in `FFL.FirstOrder.ProvabilityAbstraction`. -/ +def kreisel (𝔅 : Provability T₀ T) (σ : Sentence L) : Sentence L := + fixedpoint T₀ (“x. !𝔅.prov x → !σ”) + +variable {σ : Sentence L} + +local notation "𝐊" => kreisel 𝔅 + +lemma kreisel_spec : T₀ ⊢ (𝐊 σ) ⇔ₗ (𝔅 (𝐊 σ) ⇒ₗ σ) := + by + have := diag (T := T₀) (“x. !𝔅.prov x → !σ”) + simpa [kreisel, Provability.pr, Rew.subst_comp_subst, ← TransitiveRewriting.comp_app] using + this; + +private lemma kreisel_specAux₂ : T₀ ⊢ (𝔅 (𝐊 σ) ⇒ₗ σ) ⇒ₗ (𝐊 σ) := + K_right kreisel_spec + +variable [𝔅.HBL] + +private lemma kreisel_specAux₁ [T₀ ≼ T] : T₀ ⊢ 𝔅 (𝐊 σ) ⇒ₗ 𝔅 σ := + Entailment.mdp₁ (C_trans (mdp D2 (D1 (WeakerThan.pbl <| K_left (kreisel_spec)))) D2) D3 + +variable [L.DecidableEq] [T₀ ≼ T] + +omit [L.DecidableEq] in +theorem löb_theorem (H : T ⊢ 𝔅 σ ⇒ₗ σ) : T ⊢ σ := by + have d₁ : T ⊢ 𝔅 (𝐊 σ) ⇒ₗ σ := C_trans (WeakerThan.pbl kreisel_specAux₁) H; + have d₂ : T ⊢ 𝔅 (𝐊 σ) := WeakerThan.pbl <| D1 <| WeakerThan.pbl kreisel_specAux₂⨀d₁; + exact d₁⨀d₂; + +omit [L.DecidableEq] in +theorem formalized_löb_theorem : T₀ ⊢ 𝔅 (𝔅 σ ⇒ₗ σ) ⇒ₗ 𝔅 σ := by + have h₁ : T₀ ⊢ 𝔅 (𝐊 σ) ⇒ₗ 𝔅 σ := kreisel_specAux₁; + have h₂ : T₀ ⊢ (𝔅 σ ⇒ₗ σ) ⇒ₗ (𝔅 (𝐊 σ) ⇒ₗ σ) := CCC_of_C_left h₁; + have h₃ : T ⊢ (𝔅 σ ⇒ₗ σ) ⇒ₗ 𝐊 σ := + WeakerThan.pbl <| C_trans (CCC_of_C_left h₁) kreisel_specAux₂; + exact C_trans (D2⨀(D1 h₃)) h₁; + +lemma formalized_unprovable_not_con [Consistent T] [𝔅.Kreisel] : T ⊬ 𝔅.con ⇒ₗ ∼𝔅 (∼𝔅.con) := by + by_contra hC; have : T ⊢ ∼𝔅.con := löb_theorem <| CN_of_CN_right hC; + have : T ⊬ ∼𝔅.con := con_unrefutable; contradiction; + +lemma formalized_unrefutable_gödel [Consistent T] [𝔅.Kreisel] : T ⊬ 𝔅.con ⇒ₗ ∼𝔅 (∼(gödel 𝔅)) := + by + by_contra hC; have : T ⊬ 𝔅.con ⇒ₗ ∼𝔅 (∼𝔅.con) := formalized_unprovable_not_con; + have : T ⊢ 𝔅.con ⇒ₗ ∼𝔅 (∼𝔅.con) := + C_trans hC <| + WeakerThan.pbl <| K_left <| ENN_of_E <| 𝔅.ext <| ENN_of_E <| WeakerThan.pbl gödel_iff_con + contradiction; + +end Löb + +section Rosser + +variable {T₀ T : Theory L} [Diagonalization T₀] [T₀ ≼ T] [Consistent T] {𝔅 : Provability T₀ T} + +local notation "𝐑" => gödel 𝔅 + +theorem unrefutable_rosser [𝔅.Rosser] : T ⊬ ∼𝐑 := by + intro hnρ; + have hρ : T ⊢ 𝐑 := WeakerThan.pbl <| (K_right gödel_spec)⨀(Ros hnρ); + have : ¬Consistent T := + not_consistent_iff_inconsistent.mpr <| + inconsistent_iff_provable_bot.mpr <| (N_iff_CO.mp hnρ)⨀hρ; + contradiction + +theorem rosser_independent [𝔅.Rosser] : Independent T 𝐑 := + by + constructor + · apply unprovable_gödel + · apply unrefutable_rosser + +theorem rosser_first_incompleteness (𝔅 : Provability T₀ T) [𝔅.Rosser] : Incomplete T := + incomplete_def.mpr ⟨gödel 𝔅, rosser_independent⟩ + +omit [Diagonalization T₀] [Consistent T] in +/-- If `𝔅` satisfies Rosser provability condition, then `𝔅.con` is provable from `T`. -/ +theorem kreisel_remark [𝔅.Rosser] : T ⊢ 𝔅.con := by + have : T₀ ⊢ ∼𝔅 ⊥ := Ros (N_iff_CO.mpr (by simp)); exact WeakerThan.pbl <| this; + +end Rosser + +end ProvabilityAbstraction + +end FirstOrder + +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Incompleteness/RosserProvability.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Incompleteness/RosserProvability.lean new file mode 100644 index 000000000..66cc28285 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Incompleteness/RosserProvability.lean @@ -0,0 +1,212 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Incompleteness.WitnessComparison +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.CraigTrick + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +/-! +# Rosser's provability predicate +-/ + +namespace FFL +namespace FirstOrder +namespace Arithmetic +namespace Bootstrapping + +open FFL.Entailment + +variable {V : Type*} [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +variable {L : Language} [L.Encodable] [L.LORDefinable] + +variable (T : Theory L) [T.Δ₁] + +/-- The Rosser Provable construction in `FFL.FirstOrder.Theory`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Theory.RosserProvable (φ : V) : Prop := + T.ProvabilityComparisonLE φ (neg L φ) + +section + +/-- The rosser Provable construction in `FFL.FirstOrder.Theory`. -/ +noncomputable def _root_.PointwiseComposition.FFL.FirstOrder.Theory.rosserProvable : + Σ₁.Semisentence 1 := + .mkSigma (“φ. ∃ nφ, !(negGraph L)nφ φ ∧ !T.provabilityComparisonLE φ nφ”) + +instance _root_.PointwiseComposition.FFL.FirstOrder.Theory.RosserProvable_defined : + Σ₁-Predicate (T.RosserProvable : V → Prop) via T.rosserProvable := + .mk fun v ↦ by simp [Theory.rosserProvable, Theory.RosserProvable] + +instance _root_.PointwiseComposition.FFL.FirstOrder.Theory.rosserProvable_definable : + Σ₁-Predicate (T.RosserProvable : V → Prop) := + T.RosserProvable_defined.to_definable + +/-- The rosser Pred construction in `FFL.FirstOrder.Theory`. -/ +noncomputable abbrev _root_.PointwiseComposition.FFL.FirstOrder.Theory.rosserPred + (σ : Sentence L) : ArithmeticSentence := + T.rosserProvable.val/[⌜σ⌝] + +end + +variable {T} + +lemma rosser_quote {φ : Proposition L} : + T.RosserProvable (V := V) ⌜φ⌝ ↔ T.ProvabilityComparisonLE (V := V) ⌜φ⌝ ⌜∼φ⌝ := by + simp [Theory.RosserProvable, Semiformula.quote_def] + +lemma rosser_quote₀ {φ : Sentence L} : + T.RosserProvable (V := V) ⌜φ⌝ ↔ T.ProvabilityComparisonLE (V := V) ⌜φ⌝ ⌜∼φ⌝ := by + simpa [Sentence.quote_def] using rosser_quote + +lemma rosser_quote_def {φ : Proposition L} : + T.RosserProvable (V := V) ⌜φ⌝ ↔ ∃ b : V, Proof T b ⌜φ⌝ ∧ ∀ b' < b, ¬Proof T b' ⌜∼φ⌝ := + rosser_quote + +lemma rosser_quote_def₀ {φ : Sentence L} : + T.RosserProvable (V := V) ⌜φ⌝ ↔ ∃ b : V, Proof T b ⌜φ⌝ ∧ ∀ b' < b, ¬Proof T b' ⌜∼φ⌝ := by + simpa [Sentence.quote_def] using! rosser_quote + +theorem RosserProvable.to_provable {φ : V} : T.RosserProvable φ → Provable T φ := + ProvabilityComparison.le_to_provable + +lemma provable_of_standard_proof {n : ℕ} {φ : Sentence L} : Proof T (n : V) ⌜φ⌝ → T ⊢ φ := + fun h ↦ + by + have : Proof T n ⌜φ⌝ ↔ Proof T (↑n : V) ⌜φ⌝ := by + simpa [Sentence.coe_quote_eq_quote] using + Defined.shigmaOne_absolute V (φ := proof T) (R := fun v ↦ Proof T (v 0) (v 1)) (R' := + fun v ↦ Proof T (v 0) (v 1)) Proof.defined Proof.defined ![n, ⌜φ⌝] + have : Provable T (⌜φ⌝ : ℕ) := ⟨n, this.mpr h⟩ + exact provable_iff_provable.mp this + + + +theorem rosser_internalize [Consistent T] {φ : Sentence L} : + T ⊢ φ → T.RosserProvable (⌜φ⌝ : V) := by + classical + intro h + let n : ℕ := ⌜h.get⌝ + have hn : Proof T (↑n : V) ⌜φ⌝ := by simp [n, coe_quote_proof_eq] + refine rosser_quote_def₀.mpr ⟨n, hn, ?_⟩ + intro b hb Hb + rcases eq_nat_of_lt_nat hb with ⟨b, rfl⟩ + have : T ⊢ ∼φ := provable_of_standard_proof (V := V) Hb + exact Consistent.not_inc inferInstance (inconsistent_of_provable_of_unprovable h this) + +theorem rosser_internalize_sentence [Consistent T] {σ : Sentence L} : + T ⊢ σ → T.RosserProvable (⌜σ⌝ : V) := fun h ↦ by + simpa [Sentence.quote_def] using! rosser_internalize h + +open _root_.Classical Classical in +theorem not_rosserProvable [Consistent T] {φ : Sentence L} : + T ⊢ ∼φ → ¬T.RosserProvable (⌜φ⌝ : V) := + by + rintro h r + let n : ℕ := ⌜h.get⌝ + have hn : Proof T (↑n : V) ⌜∼φ⌝ := by simp [n, coe_quote_proof_eq] + rcases rosser_quote₀.mp r with ⟨b, hb, Hb⟩ + have : b ≤ n := by grind; + rcases eq_nat_of_le_nat this with ⟨b, rfl⟩ + have : T ⊢ φ := provable_of_standard_proof hb + exact Consistent.not_inc inferInstance (inconsistent_of_provable_of_unprovable this h) + +theorem not_rosserProvable_sentence [Consistent T] {σ : Sentence L} : + T ⊢ ∼σ → ¬T.RosserProvable (⌜σ⌝ : V) := fun h ↦ by + simpa [Sentence.quote_def] using! not_rosserProvable h + +end Bootstrapping +end Arithmetic +end FirstOrder +end FFL + +namespace FFL +namespace FirstOrder +namespace Arithmetic + +open Bootstrapping + +open FFL.Entailment + +section + +variable {L : Language} [L.Encodable] [L.LORDefinable] + +variable {T : Theory L} [T.Δ₁] [Consistent T] + +local prefix:90 "𝐑" => T.rosserPred + +theorem rosserProvable_D1 {σ} : T ⊢ σ → 𝐈Σ₁ ⊢ 𝐑σ := fun h ↦ + complete 𝐈Σ₁ _ fun (V : Type) _ _ ↦ by simpa [models_iff] using rosser_internalize_sentence h + +theorem rosserProvable_rosser {σ} : T ⊢ ∼σ → 𝐈Σ₁ ⊢ ∼𝐑σ := fun h ↦ + complete 𝐈Σ₁ _ fun (V : Type) _ _ ↦ by simpa [models_iff] using not_rosserProvable_sentence h + +end + +section rosserProvability + +open ProvabilityAbstraction + +variable {L : Language} [L.Encodable] [L.LORDefinable] + +variable {T : Theory L} [T.Δ₁] [Consistent T] + +variable (T) + +/-- The rosser Provability construction in `FFL.FirstOrder.Theory`. -/ +noncomputable abbrev _root_.PointwiseComposition.FFL.FirstOrder.Theory.rosserProvability : + Provability 𝐈Σ₁ T where + prov := T.rosserProvable + bew_def := rosserProvable_D1 + +instance : T.rosserProvability.Rosser := + ⟨rosserProvable_rosser⟩ + +lemma rosserProvability_def (σ : Sentence L) : T.rosserProvability σ = T.rosserPred σ := + rfl + +instance : T.rosserProvability.SoundOn ℕ := by + constructor; intro σ h; + apply + Bootstrapping.provable_iff_provable.mp <| + Bootstrapping.ProvabilityComparison.le_to_provable <| by + simpa [models_iff, Provability.pr, Theory.RosserProvable] using h; + +end rosserProvability + +/-- Gödel-Rosser incompleteness theorem -/ +theorem incomplete_GR (T : ArithmeticTheory) [T.Δ₁] [𝐈Σ₁ ≼ T] [Consistent T] : Incomplete T := + ProvabilityAbstraction.rosser_first_incompleteness T.rosserProvability + +instance {T : ArithmeticTheory} [T.RE] [𝐈Σ₁ ≼ T] : 𝐈Σ₁ ≼ T.craig := + WeakerThan.trans inferInstance (inferInstance : T ≼ T.craig) + +/-- Gödel-Rosser incompleteness theorem for r.e. theories -/ +theorem incomplete_GR_of_RE (T : ArithmeticTheory) [T.RE] [𝐈Σ₁ ≼ T] [Consistent T] : + Incomplete T := + (Equiv.incomplete_iff (inferInstance : T ≊ T.craig)).mpr (incomplete_GR T.craig) + +theorem exists_true_but_unprovable_sentence_of_RE_of_consistent (T : ArithmeticTheory) [T.RE] + [𝐈Σ₁ ≼ T] [Consistent T] : ∃ δ : ArithmeticSentence, ℕ↓[ℒₒᵣ] ⊧ δ ∧ T ⊬ δ := + exists_true_but_unprovable_sentence_of_incomplete (incomplete_GR_of_RE T) + +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Incompleteness/Second.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Incompleteness/Second.lean new file mode 100644 index 000000000..91d2f53c5 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Incompleteness/Second.lean @@ -0,0 +1,66 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Incompleteness.Consistency +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Incompleteness.RosserProvability +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.CraigTrick + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +/-! +# Gödel's second incompleteness theorem for arithmetic theories stronger than $\mathsf{I}\Sigma_1$ +-/ + +namespace FFL +namespace FirstOrder +namespace Arithmetic + +open FFL.Entailment ProvabilityAbstraction + +variable (T : ArithmeticTheory) [T.Δ₁] [𝐈Σ₁ ≼ T] + +/-- Gödel's second incompleteness theorem -/ +theorem consistent_unprovable [Consistent T] : T ⊬ T.consistent.val := + ProvabilityAbstraction.con_unprovable (𝔅 := T.standardProvability) + +/-- Gödel's second incompleteness theorem for r.e. theories -/ +theorem craig_consistent_unprovable_of_RE (T : ArithmeticTheory) [T.RE] [𝐈Σ₁ ≼ T] + [Consistent T] : T ⊬ T.craig.consistent.val := fun h ↦ + consistent_unprovable T.craig (WeakerThan.pbl h) + +theorem inconsistent_unprovable [ArithmeticTheory.SoundOnHierarchy T Σ 1] : + T ⊬ ∼T.consistent.val := + ProvabilityAbstraction.con_unrefutable (𝔅 := T.standardProvability) + +/-- The consistency statement is independent. -/ +theorem inconsistent_independent [ArithmeticTheory.SoundOnHierarchy T Σ 1] : + Independent T T.consistent.val := + ProvabilityAbstraction.con_independent (𝔅 := T.standardProvability) + +instance [Consistent T] : T ≺ T ∪ T.Con := + StrictlyWeakerThan.of_unprovable_provable (φ := T.consistent) (consistent_unprovable T) + (Entailment.by_axm (by simp)) + +instance [ArithmeticTheory.SoundOnHierarchy T Σ 1] : T ≺ T ∪ T.Incon := + StrictlyWeakerThan.of_unprovable_provable (φ := ∼T.consistent) (inconsistent_unprovable T) + (Entailment.by_axm (by simp)) + +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Incompleteness/StandardProvability.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Incompleteness/StandardProvability.lean new file mode 100644 index 000000000..cf879e139 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Incompleteness/StandardProvability.lean @@ -0,0 +1,144 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.DerivabilityCondition.D1 +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.DerivabilityCondition.D2 +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.DerivabilityCondition.D3 +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Incompleteness.ProvabilityAbstraction.Basic +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.FixedPoint + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +/-! +# Derivability conditions of standard provability predicate +-/ + +namespace FFL +namespace FirstOrder +namespace Arithmetic + +open ISigma1 Bootstrapping ProvabilityAbstraction + +noncomputable instance : Diagonalization 𝐈Σ₁ + where + fixedpoint := fixedpoint + diag θ := diagonal θ + +section + +variable {L : Language} [L.Encodable] [L.LORDefinable] {T : Theory L} [T.Δ₁] + +local prefix:90 "□" => provabilityPred T + +/-- The derivability condition D1. -/ +theorem provable_D1 {σ} : T ⊢ σ → 𝐈Σ₁ ⊢ □σ := fun h ↦ + complete 𝐈Σ₁ _ fun (V : Type) _ _ ↦ by + simpa [models_iff] using internalize_provability (V := V) h + +/-- The derivability condition D2. -/ +theorem provable_D2 {σ π} : 𝐈Σ₁ ⊢ □(σ ⇒ₗ π) ⇒ₗ □σ ⇒ₗ □π := + complete 𝐈Σ₁ _ fun (V : Type) _ _ ↦ by simpa [models_iff] using modus_ponens_sentence T + +variable (T) + +/-- The standard Provability construction in `FFL.FirstOrder.Theory`. -/ +noncomputable abbrev _root_.PointwiseComposition.FFL.FirstOrder.Theory.standardProvability : + Provability 𝐈Σ₁ T where + prov := provable T + bew_def := provable_D1 + +variable {T} + +instance : T.standardProvability.HBL2 := + ⟨provable_D2⟩ + +lemma standardProvability_def (σ : Sentence L) : + T.standardProvability σ = provabilityPred T σ := + rfl + +instance : T.standardProvability.SoundOn ℕ := + ⟨fun h ↦ by simpa [Arithmetic.standardProvability_def, models_iff] using h⟩ + +end + +section arithmetic + +variable {T U : ArithmeticTheory} [T.Δ₁] + +local prefix:90 "□" => provabilityPred T + +lemma provable_sigma_one_complete [𝐏𝐀⁻ ≼ T] {σ : ArithmeticSentence} (hσ : Hierarchy Σ 1 σ) : + 𝐈Σ₁ ⊢ σ ⇒ₗ □σ := + complete 𝐈Σ₁ _ fun (V : Type) _ _ ↦ by + simpa [models_iff] using + Bootstrapping.ObjectArithmetic.sigma_one_complete (T := T) (V := V) hσ + +/-- The derivability condition D3. -/ +theorem provable_D3 [𝐏𝐀⁻ ≼ T] {σ : ArithmeticSentence} : 𝐈Σ₁ ⊢ □σ ⇒ₗ □□σ := + provable_sigma_one_complete (by simp) + +open FFL.Entailment FFL.Entailment.FiniteContext + +lemma provable_D2_context [𝐈Σ₁ ≼ U] {Γ σ π} (hσπ : Γ ⊢[U] □(σ ⇒ₗ π)) (hσ : Γ ⊢[U] □σ) : + Γ ⊢[U] □π := + FiniteContext.of' (weakening inferInstance provable_D2)⨀hσπ⨀hσ + +lemma provable_D3_context [𝐏𝐀⁻ ≼ T] [𝐈Σ₁ ≼ U] {Γ σ} (hσπ : Γ ⊢[U] □σ) : Γ ⊢[U] □□σ := + FiniteContext.of' (weakening inferInstance provable_D3)⨀hσπ + +lemma provable_sound [U.SoundOnHierarchy Σ 1] {σ} : U ⊢ □σ → T ⊢ σ := fun h ↦ + by + have : ℕ↓[ℒₒᵣ] ⊧ provabilityPred T σ := + ArithmeticTheory.SoundOn.sound (F := Arithmetic.Hierarchy Σ 1) h (by simp) + simpa [models_iff] using this + +lemma provable_complete [U.SoundOnHierarchy Σ 1] [𝐈Σ₁ ≼ U] {σ} : T ⊢ σ ↔ U ⊢ □σ := + ⟨fun h ↦ weakening inferInstance (provable_D1 h), provable_sound⟩ + +instance [𝐏𝐀⁻ ≼ T] : T.standardProvability.HBL3 := + ⟨provable_D3⟩ + +instance [𝐏𝐀⁻ ≼ T] : T.standardProvability.HBL where + +instance [T.SoundOnHierarchy Σ 1] : T.standardProvability.Kreisel := + ⟨fun h ↦ provable_sound h⟩ + +open FFL.Entailment in +/-- If `π` is equivalent to some Σ₁ sentence `σ`, + then `π ⇒ₗ □π` is provable in `T` (note: not `𝐈Σ₁`, compare `provable_sigma_one_complete`) +-/ +lemma provable_sigma_one_complete_of_E {σ π} [𝐈Σ₁ ≼ T] (hσ : Hierarchy Σ 1 σ) + (hσπ : 𝐈Σ₁ ⊢ σ ⇔ₗ π) : 𝐈Σ₁ ⊢ π ⇒ₗ □π := + by + apply C_replace ?_ ?_ <| provable_sigma_one_complete (T := T) <| hσ; · cl_prover[hσπ]; + · apply T.standardProvability.mono'; cl_prover[hσπ]; + +end arithmetic + +open FFL.Entailment in +lemma exists_true_but_unprovable_sentence_of_incomplete {T : ArithmeticTheory} + (h : Incomplete T) : ∃ δ : ArithmeticSentence, ℕ↓[ℒₒᵣ] ⊧ δ ∧ T ⊬ δ := + by + obtain ⟨δ, hδ⟩ := incomplete_def.mp h; by_cases ℕ↓[ℒₒᵣ] ⊧ δ + · exact ⟨δ, by assumption, hδ.1⟩ + · exact ⟨∼δ, by simpa, hδ.2⟩ + +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Incompleteness/WitnessComparison.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Incompleteness/WitnessComparison.lean new file mode 100644 index 000000000..fb7bc7aad --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Incompleteness/WitnessComparison.lean @@ -0,0 +1,170 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Incompleteness.StandardProvability + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +/-! +# Witness comparisons of provability +-/ + +namespace FFL +namespace FirstOrder +namespace Arithmetic +namespace Bootstrapping + +variable {V : Type*} [ORingStructure V] [V↓[ℒₒᵣ] ⊧* 𝐈Σ₁] + +section WitnessComparisons + +variable {L : Language} [L.Encodable] [L.LORDefinable] + +variable (T : Theory L) [T.Δ₁] + +/-- The Provability Comparison LE construction in `FFL.FirstOrder.Theory`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Theory.ProvabilityComparisonLE (φ ψ : V) : + Prop := + ∃ b, Proof T b φ ∧ ∀ b' < b, ¬Proof T b' ψ + +/-- The Provability Comparison LT construction in `FFL.FirstOrder.Theory`. -/ +def _root_.PointwiseComposition.FFL.FirstOrder.Theory.ProvabilityComparisonLT (φ ψ : V) : + Prop := + ∃ b, Proof T b φ ∧ ∀ b' ≤ b, ¬Proof T b' ψ + +section + +/-- The provability Comparison LE construction in `FFL.FirstOrder.Theory`. -/ +noncomputable def _root_.PointwiseComposition.FFL.FirstOrder.Theory.provabilityComparisonLE : + Σ₁.Semisentence 2 := + .mkSigma (“φ ψ. ∃ b, !(proof T).sigma b φ ∧ ∀ b' < b, ¬!(proof T).pi b' ψ”) + +instance _root_.PointwiseComposition.FFL.FirstOrder.Theory.provability_comparison_le_defined : + Σ₁-Relation[V] T.ProvabilityComparisonLE via T.provabilityComparisonLE := + .mk fun v ↦ by simp [Theory.provabilityComparisonLE, Theory.ProvabilityComparisonLE] + +instance _root_.PointwiseComposition.FFL.FirstOrder.Theory.provability_comparison_le_definable : + Σ₁-Relation[V] T.ProvabilityComparisonLE := + T.provability_comparison_le_defined.to_definable + +/-- instance for definability tactic -/ +instance + _root_.PointwiseComposition.FFL.FirstOrder.Theory.provability_comparison_le_definable' : + Σ-[0 + 1]-Relation[V] T.ProvabilityComparisonLE := + T.provability_comparison_le_definable + +/-- The provability Comparison LT construction in `FFL.FirstOrder.Theory`. -/ +noncomputable def _root_.PointwiseComposition.FFL.FirstOrder.Theory.provabilityComparisonLT : + Σ₁.Semisentence 2 := + .mkSigma (“φ ψ. ∃ b, !(proof T).sigma b φ ∧ ∀ b' <⁺ b, ¬!(proof T).pi b' ψ”) + +instance _root_.PointwiseComposition.FFL.FirstOrder.Theory.provability_comparison_lt_defined : + Σ₁-Relation[V] T.ProvabilityComparisonLT via T.provabilityComparisonLT := + .mk fun v ↦ by simp [Theory.provabilityComparisonLT, Theory.ProvabilityComparisonLT] + +instance _root_.PointwiseComposition.FFL.FirstOrder.Theory.provability_comparison_lt_definable : + Σ₁-Relation[V] T.ProvabilityComparisonLT := + T.provability_comparison_lt_defined.to_definable + +/-- instance for definability tactic -/ +instance + _root_.PointwiseComposition.FFL.FirstOrder.Theory.provability_comparison_lt_definable' : + Σ-[0 + 1]-Relation[V] T.ProvabilityComparisonLT := + T.provability_comparison_lt_definable + +end + +variable {T : Theory L} [T.Δ₁] + +namespace ProvabilityComparison + +variable {φ ψ χ : V} + +local infixl:50 "≼" => T.ProvabilityComparisonLE + +local infixl:50 "≺" => T.ProvabilityComparisonLT + +local prefix:50 "□" => Provable T + +@[grind =>] +lemma le_of_lt : φ ≺ ψ → φ ≼ ψ := by rintro ⟨b, _⟩; exact ⟨b, by grind⟩ + +@[grind =>] +lemma le_to_provable : φ ≼ ψ → □φ := by rintro ⟨b, hb, _⟩; exact ⟨b, by grind⟩ + +@[grind =>] +lemma le_trans : φ ≼ ψ → ψ ≼ χ → φ ≼ χ := by rintro ⟨b, hb, h⟩ ⟨d, hd, H⟩; use b; grind; + +@[grind =>] +lemma le_antisymm : φ ≼ ψ → ψ ≼ φ → φ = ψ := + by + rintro ⟨b, hb, Hb⟩ ⟨d, hd, Hd⟩ + have : b = d := by + by_contra ne + wlog lt : b < d + · grind; + have : ¬Proof T b φ := Hd b lt + contradiction + have : ({ φ } : V) = { ψ } := by simp [← hb.1, ← hd.1, this] + simpa using this + +lemma iff_le_refl_provable : φ ≼ φ ↔ □φ := + by + constructor + · exact le_to_provable + · rintro ⟨b, hb⟩ + have : ∃ b, Proof T b φ ∧ ∀ z < b, ¬Proof T z φ := + InductionOnHierarchy.least_number_sigma Σ 1 (P := (Proof T · φ)) (by definability) hb + rcases this with ⟨b, bd, h⟩ + exact ⟨b, bd, h⟩ + +@[grind .] +lemma lt_irrefl : ¬φ≺φ := by + rintro ⟨b, hb, h⟩; have : ¬Proof T b φ := h b (by simp); + contradiction + +@[grind =>] +lemma lt_trans : φ ≺ ψ → ψ ≺ χ → φ ≺ χ := by rintro ⟨b, hb, h⟩ ⟨d, hd, H⟩; use b; grind; + +@[grind =>] +lemma not_lt_of_le : φ ≼ ψ → ¬ψ ≺ φ := by grind; + +lemma find_minimal_proof_fintype {ι : Type*} [_root_.Finite ι] (φ : ι → V) {i : ι} + (H : □(φ i)) : + ∃ j, ∀ k, (φ j) ≼ (φ k) := by + classical + let : Fintype ι := Fintype.ofFinite ι + rcases show ∃ dᵢ, Proof T dᵢ (φ i)from H with ⟨dᵢ, Hdᵢ⟩ + have : ∃ z, (∃ j, Proof T z (φ j)) ∧ ∀ w < z, ∀ x, ¬Proof T w (φ x) := by + simpa using + InductionOnHierarchy.least_number_sigma Σ 1 (P := fun z ↦ ∃ j, Proof T z (φ j)) + (HierarchySymbol.Definable.fintype_exs fun j ↦ by definability) (x := dᵢ) ⟨i, Hdᵢ⟩ + rcases this with ⟨z, ⟨j, hj⟩, H⟩ + exact ⟨j, fun k ↦ ⟨z, hj, fun w hw ↦ H w hw k⟩⟩ + + + +end ProvabilityComparison + +end WitnessComparisons + +end Bootstrapping +end Arithmetic +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/LJ/Basic.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/LJ/Basic.lean new file mode 100644 index 000000000..576de8d7a --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/LJ/Basic.lean @@ -0,0 +1,548 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.LJ.Head + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace FFL +namespace FirstOrder + +variable {L : Language.{u}} + +open Semiformulaᵢ + +namespace LJ + +/-- Data and laws for Derivation in `FFL.FirstOrder.LJ`. -/ +inductive Derivation : Sequent L → Head L → Type _/-- Identity rule -/ + | identity (R : L.Rel k) (v) : Derivation ⦃rel R v⦄ (rel R v)/-- Cut rule -/ + | + cut {φ : Propositionᵢ L} {Γ Δ Ξ} : + Derivation Γ φ → Derivation (Δ + ⦃φ⦄) Ξ → Derivation (Γ + Δ) Ξ/-- +Left contraction -/ + | contraction : Derivation (Γ + ⦃φ, φ⦄) Ξ → Derivation (Γ + ⦃φ⦄) Ξ/-- Left weakening -/ + | weakening : Derivation Γ Ξ → Derivation (Γ + ⦃φ⦄) Ξ/-- Right weakening -/ + | weakeningRight : Derivation Γ none → Derivation Γ (some φ)/-- +Positive introduction of verum -/ + | verum : Derivation 0 (some ⊤)/-- Negative introduction of falsum -/ + | falsum : Derivation ⦃⊥⦄ none/-- Positive introduction of implication -/ + | positiveImply {φ ψ : Propositionᵢ L} : Derivation (Γ + ⦃φ⦄) ψ → Derivation Γ (φ ⇒ₗ ψ)/-- +Negative introduction of implication -/ + | + negativeImply {φ ψ : Propositionᵢ L} : + Derivation Γ φ → Derivation (Δ + ⦃ψ⦄) Ξ → Derivation (Γ + Δ + ⦃φ ⇒ₗ ψ⦄) Ξ/-- +Positive introduction of conjunction -/ + | + positiveAnd {φ ψ : Propositionᵢ L} : Derivation Γ φ → Derivation Γ ψ → Derivation Γ (φ ⋏ ψ)/-- +Negative introduction of conjunction -/ + | + negativeAnd {φ ψ : Propositionᵢ L} : Derivation (Γ + ⦃φ, ψ⦄) Ξ → Derivation (Γ + ⦃φ ⋏ ψ⦄) Ξ/-- +Positive introduction of disjunction (left) -/ + | positiveOrLeft {φ ψ : Propositionᵢ L} : Derivation Γ φ → Derivation Γ (φ ⋎ ψ)/-- +Positive introduction of disjunction (right) -/ + | positiveOrRight {φ ψ : Propositionᵢ L} : Derivation Γ ψ → Derivation Γ (φ ⋎ ψ)/-- +Negative introduction of disjunction -/ + | negativeOr : Derivation (Γ + ⦃φ⦄) Ξ → Derivation (Γ + ⦃ψ⦄) Ξ → Derivation (Γ + ⦃φ ⋎ ψ⦄) Ξ/-- +Positive introduction of universal quantifier -/ + | + positiveForall {φ : Semipropositionᵢ L 1} : + Derivation Γ⁺ (Rewriting.free φ) → Derivation Γ (∀¹ φ)/-- +Negative introduction of universal quantifier -/ + | + negativeForall {φ : Semipropositionᵢ L 1} {t : Term L ℕ} : + Derivation (Γ + ⦃φ/[t]⦄) Ξ → Derivation (Γ + ⦃∀¹ φ⦄) Ξ/-- +Positive introduction of existential quantifier -/ + | + positiveExists {φ : Semipropositionᵢ L 1} {t : Term L ℕ} : + Derivation Γ (φ/[t]) → Derivation Γ (∃¹ φ)/-- +Negative introduction of existential quantifier -/ + | + negativeExists {φ : Semipropositionᵢ L 1} : + Derivation (Γ⁺ + ⦃Rewriting.free φ⦄) Ξ.shift → Derivation (Γ + ⦃∃¹ φ⦄) Ξ + +/-- The «term ⊢ᴸᴶ¹ » construction in `FFL.FirstOrder.LJ`. -/ +infix:45 " ⊢ᴸᴶ¹ " => Derivation + +namespace Derivation + +variable {Γ Δ : Sequent L} {Ξ Λ : Head L} + +open Rewriting LawfulSyntacticRewriting + +/-- The cast construction in `FFL.FirstOrder.LJ.Derivation`. -/ +def cast (d : Γ ⊢ᴸᴶ¹ Ξ) (seq : Γ = Δ := by abel) (heq : Ξ = Λ := by simp) : Δ ⊢ᴸᴶ¹ Λ := + seq ▸ heq ▸ d + +instance : Structural (fun Γ ↦ Γ ⊢ᴸᴶ¹ Ξ) + where + weakening d := d.weakening + contraction d := d.contraction + +/-- The traversal construction in `FFL.FirstOrder.LJ.Derivation`. -/ +def traversal [L.DecidableEq] {Γ : Sequent L} {Ξ : Head L} : + Γ ⊢ᴸᴶ¹ Ξ → (PointwiseComposition.Multiset.Traversal Γ) + | identity R v => .atom (Semiformulaᵢ.rel R v) + | cut d e => d.traversal.add e.traversal.remove + | contraction (φ := φ) d => (d.traversal.cast (by abel)).remove (a := φ) + | weakening (φ := φ) d => d.traversal.succ φ + | weakeningRight d => d.traversal + | verum => .zero + | falsum => .atom ⊥ + | positiveImply d => d.traversal.remove + | negativeImply (φ := φ) (ψ := ψ) d e => (d.traversal.add e.traversal.remove).succ (φ ⇒ₗ ψ) + | positiveAnd d _ => d.traversal + | negativeAnd (φ := φ) (ψ := ψ) d => + ((d.traversal.cast (by abel)).remove (a := ψ)).remove (a := φ) |>.succ (φ ⋏ ψ) + | positiveOrLeft d => d.traversal + | positiveOrRight d => d.traversal + | negativeOr (φ := φ) (ψ := ψ) d _ => d.traversal.remove.succ (φ ⋎ ψ) + | positiveForall d => + (d.traversal.map (Rew.rewriteMap Nat.pred ▹ ·)).cast + (by simp [Rewriting.shifts, Multiset.map_map, Rewriting.rewriteMap_pred_shift]) + | negativeForall (φ := φ) d => d.traversal.remove.succ (∀¹ φ) + | positiveExists d => d.traversal + | negativeExists (φ := φ) d => + ((d.traversal.remove.map (Rew.rewriteMap Nat.pred ▹ ·)).cast + (by simp [Rewriting.shifts, Multiset.map_map, Rewriting.rewriteMap_pred_shift])).succ + (∃¹ φ) + +/-- The contra construction in `FFL.FirstOrder.LJ.Derivation`. -/ +def contra [L.DecidableEq] (d : Γ ⊢ᴸᴶ¹ Ξ) (t : (PointwiseComposition.Multiset.Traversal Δ)) + (h : Γ ⊆ Δ := by simp) : Δ ⊢ᴸᴶ¹ Ξ := + Structural.ofSubset (F := Propositionᵢ L) (𝔇 := fun Γ ↦ Γ ⊢ᴸᴶ¹ Ξ) (Γ := Γ) (Δ := Δ) + d.traversal t d h + +/-- The eta construction in `FFL.FirstOrder.LJ.Derivation`. -/ +def eta : (φ : Propositionᵢ L) → ⦃φ⦄ ⊢ᴸᴶ¹ φ + | .rel R v => identity R v + | ⊥ => falsum.weakeningRight + | φ ⋏ ψ => + positiveAnd + (cast + (negativeAnd (Γ := 0) (φ := φ) (ψ := ψ) (Ξ := φ) <| + ((eta φ).weakening (φ := ψ)).cast (by simp))) + (cast + (negativeAnd (Γ := 0) (φ := φ) (ψ := ψ) (Ξ := ψ) <| + ((eta ψ).weakening (φ := φ)).cast (by simp [add_comm]))) + | φ ⋎ ψ => + negativeOr (Γ := 0) (φ := φ) (ψ := ψ) (Ξ := φ ⋎ ψ) (cast (positiveOrLeft (ψ := ψ) (eta φ))) + (cast (positiveOrRight (φ := φ) (eta ψ))) + | φ ⇒ₗ ψ => + positiveImply <| + cast + (negativeImply (φ := φ) (ψ := ψ) (Δ := 0) (Ξ := ψ) (eta φ) + (cast (eta ψ) (by simp) (by simp))) + | ∀¹ φ => + positiveForall (Γ := ⦃∀¹ φ⦄) <| + cast + (negativeForall (Γ := 0) (Ξ := Rewriting.free φ) (φ := Rewriting.shift φ) (t := &0) <| + cast (eta (Rewriting.free φ)) (by simp) (by simp)) + (by simp) + | ∃¹ φ => + negativeExists (Γ := 0) (Ξ := ∃¹ φ) <| + cast + (positiveExists (Γ := ⦃Rewriting.free φ⦄) (φ := Rewriting.shift φ) (t := &0) <| + cast (eta (Rewriting.free φ)) (by simp) (by simp)) +termination_by φ => φ.complexity + +/-- The assumption construction in `FFL.FirstOrder.LJ.Derivation`. -/ +def assumption [L.DecidableEq] {φ : Propositionᵢ L} + (t : (PointwiseComposition.Multiset.Traversal Γ)) (h : φ ∈ Γ) : Γ ⊢ᴸᴶ¹ φ := + (eta φ).contra t (by simpa using h) + +/-- The positive Neg construction in `FFL.FirstOrder.LJ.Derivation`. -/ +def positiveNeg {φ : Propositionᵢ L} (d : Γ + ⦃φ⦄ ⊢ᴸᴶ¹ (⊥ : Propositionᵢ L)) : + Γ ⊢ᴸᴶ¹ (∼φ : Propositionᵢ L) := + positiveImply d + +/-- The negative Neg construction in `FFL.FirstOrder.LJ.Derivation`. -/ +def negativeNeg {φ : Propositionᵢ L} (d : Γ ⊢ᴸᴶ¹ φ) : Γ + ⦃(∼φ : Propositionᵢ L)⦄ ⊢ᴸᴶ¹ none := + cast (seq := by rw [add_zero]; rfl) <| + negativeImply (φ := φ) (ψ := ⊥) (Γ := Γ) (Δ := 0) (Ξ := none) d <| + cast falsum (by simp) (by rfl) + +/-- The modus Ponens construction in `FFL.FirstOrder.LJ.Derivation`. -/ +def modusPonens [L.DecidableEq] {φ ψ : Propositionᵢ L} (di : Γ ⊢ᴸᴶ¹ φ ⇒ₗ ψ) (dφ : Γ ⊢ᴸᴶ¹ φ) : + Γ ⊢ᴸᴶ¹ ψ := + have d : Γ + Γ ⊢ᴸᴶ¹ ψ := + cut (φ := φ ⇒ₗ ψ) (Γ := Γ) (Δ := Γ) (Ξ := ψ) di <| + cast (seq := by simp) <| + negativeImply (φ := φ) (ψ := ψ) (Γ := Γ) (Δ := 0) (Ξ := ψ) dφ + (cast (eta ψ) (by simp) (by simp)) + cast + (Structural.contractMany (F := Propositionᵢ L) (𝔇 := fun Δ ↦ Δ ⊢ᴸᴶ¹ (some ψ)) (Δ := 0) + di.traversal (cast d (by simp) (by rfl))) + (by simp) + +/-- The neg Elim construction in `FFL.FirstOrder.LJ.Derivation`. -/ +def negElim [L.DecidableEq] {φ : Propositionᵢ L} (dn : Γ ⊢ᴸᴶ¹ (∼φ : Propositionᵢ L)) + (dφ : Γ ⊢ᴸᴶ¹ φ) : Γ ⊢ᴸᴶ¹ (⊥ : Propositionᵢ L) := + modusPonens dn dφ + +/-- The cut One construction in `FFL.FirstOrder.LJ.Derivation`. -/ +def cutOne {φ : Propositionᵢ L} (dφ : Γ ⊢ᴸᴶ¹ φ) (d : ⦃φ⦄ ⊢ᴸᴶ¹ Ξ) : Γ ⊢ᴸᴶ¹ Ξ := + cast (seq := by simp) <| cut (Γ := Γ) (Δ := 0) (Ξ := Ξ) dφ <| cast d (by simp) + +/-- The and Left construction in `FFL.FirstOrder.LJ.Derivation`. -/ +def andLeft {φ ψ : Propositionᵢ L} (d : Γ ⊢ᴸᴶ¹ φ ⋏ ψ) : Γ ⊢ᴸᴶ¹ φ := + cutOne d <| + cast <| + negativeAnd (Γ := 0) (φ := φ) (ψ := ψ) (Ξ := φ) <| + ((eta φ).weakening (φ := ψ)).cast (by simp) + +/-- The and Right construction in `FFL.FirstOrder.LJ.Derivation`. -/ +def andRight {φ ψ : Propositionᵢ L} (d : Γ ⊢ᴸᴶ¹ φ ⋏ ψ) : Γ ⊢ᴸᴶ¹ ψ := + cutOne d <| + cast <| + negativeAnd (Γ := 0) (φ := φ) (ψ := ψ) (Ξ := ψ) <| + ((eta ψ).weakening (φ := φ)).cast (by simp [add_comm]) + +/-- The specialize construction in `FFL.FirstOrder.LJ.Derivation`. -/ +def specialize {φ : Semipropositionᵢ L 1} (d : Γ ⊢ᴸᴶ¹ ∀¹ φ) (t : Term L ℕ) : Γ ⊢ᴸᴶ¹ φ/[t] := + cutOne d <| + cast <| + negativeForall (Γ := 0) (Ξ := φ/[t]) (φ := φ) (t := t) <| (eta (φ/[t])).cast (by simp) + +/-- The rewrite construction in `FFL.FirstOrder.LJ.Derivation`. -/ +def rewrite (f : ℕ → SyntacticTerm L) {Γ : Sequent L} {Ξ : Head L} : + Γ ⊢ᴸᴶ¹ Ξ → Γ.map (Rew.rewrite f ▹ ·) ⊢ᴸᴶ¹ Head.rewrite f Ξ + | identity R v => identity R (Rew.rewrite f ∘ v) + | cut (φ := φ) (Γ := Γ) (Δ := Δ) dφ d => + (cut (φ := Rew.rewrite f ▹ φ) (Γ := Γ.map (Rew.rewrite f ▹ ·)) (Δ := + Δ.map (Rew.rewrite f ▹ ·)) (Ξ := Head.rewrite f Ξ) ((rewrite f dφ).cast) + ((rewrite f d).cast (by simp))).cast + (by simp) + | contraction (Γ := Γ) (φ := φ) (Ξ := Ξ) d => + (contraction (Γ := Γ.map (Rew.rewrite f ▹ ·)) (φ := Rew.rewrite f ▹ φ) (Ξ := + Head.rewrite f Ξ) ((rewrite f d).cast (by simp) (by cases Ξ <;> rfl))).cast + (by simp) (by cases Ξ <;> rfl) + | weakening (Γ := Γ) (φ := φ) (Ξ := Ξ) d => + (weakening (Γ := Γ.map (Rew.rewrite f ▹ ·)) (φ := Rew.rewrite f ▹ φ) (Ξ := Head.rewrite f Ξ) + (rewrite f d)).cast + (by simp) (by cases Ξ <;> rfl) + | weakeningRight (φ := φ) d => + ((rewrite f d).weakeningRight (φ := Rew.rewrite f ▹ φ)).cast (by simp) + | verum => verum + | falsum => falsum + | positiveImply (Γ := Γ) (φ := φ) (ψ := ψ) d => + (positiveImply (Γ := Γ.map (Rew.rewrite f ▹ ·)) (φ := Rew.rewrite f ▹ φ) (ψ := + Rew.rewrite f ▹ ψ) ((rewrite f d).cast (by simp))).cast + (by simp) + | negativeImply (Γ := Γ) (Δ := Δ) (φ := φ) (ψ := ψ) dφ dψ => + (negativeImply (Γ := Γ.map (Rew.rewrite f ▹ ·)) (Δ := Δ.map (Rew.rewrite f ▹ ·)) (Ξ := + Head.rewrite f Ξ) (φ := Rew.rewrite f ▹ φ) (ψ := Rew.rewrite f ▹ ψ) + (rewrite f dφ).cast ((rewrite f dψ).cast (by simp))).cast + (by simp) + | positiveAnd dφ dψ => positiveAnd (rewrite f dφ) (rewrite f dψ) + | negativeAnd (Γ := Γ) (φ := φ) (ψ := ψ) d => + (negativeAnd (Γ := Γ.map (Rew.rewrite f ▹ ·)) (Ξ := Head.rewrite f Ξ) (φ := + Rew.rewrite f ▹ φ) (ψ := Rew.rewrite f ▹ ψ) ((rewrite f d).cast (by simp))).cast + (by simp) + | positiveOrLeft d => positiveOrLeft (rewrite f d) + | positiveOrRight d => positiveOrRight (rewrite f d) + | negativeOr (Γ := Γ) (φ := φ) (ψ := ψ) dφ dψ => + (negativeOr (Γ := Γ.map (Rew.rewrite f ▹ ·)) (Ξ := Head.rewrite f Ξ) (φ := + Rew.rewrite f ▹ φ) (ψ := Rew.rewrite f ▹ ψ) ((rewrite f dφ).cast (by simp)) + ((rewrite f dψ).cast (by simp))).cast + (by simp) + | positiveForall (Γ := Γ) (φ := φ) d => + let g : ℕ → SyntacticTerm L := &0 :>ₙ fun x ↦ Rew.shift (f x) + (positiveForall (Γ := Γ.map (Rew.rewrite f ▹ ·)) (φ := Rew.rewrite (Rew.bShift ∘ f) ▹ φ) <| + (rewrite g d).cast (by simp [g, Rewriting.shifts, shift_rewrite_eq]) + (by simp [g, Head.rewrite, free_rewrite_eq, Function.comp_def])) |>.cast + (by simp) (by simp [Head.rewrite, Rew.q_rewrite]) + | negativeForall (Γ := Γ) (φ := φ) (t := t) d => + (negativeForall (Γ := Γ.map (Rew.rewrite f ▹ ·)) (Ξ := Head.rewrite f Ξ) (φ := + Rew.rewrite (Rew.bShift ∘ f) ▹ φ) (t := Rew.rewrite f t) + ((rewrite f d).cast (by simp [rewrite_subst_eq]))).cast + (by simp [Rew.q_rewrite]) + | positiveExists (φ := φ) (t := t) d => + (positiveExists (Γ := Γ.map (Rew.rewrite f ▹ ·)) (φ := Rew.rewrite (Rew.bShift ∘ f) ▹ φ) + (t := Rew.rewrite f t) ((rewrite f d).cast (heq := by simp [rewrite_subst_eq]))).cast + (heq := by simp [Head.rewrite, Rew.q_rewrite]) + | negativeExists (Γ := Γ) (Ξ := Ξ) (φ := φ) d => + let g : ℕ → SyntacticTerm L := &0 :>ₙ fun x ↦ Rew.shift (f x) + (negativeExists (Γ := Γ.map (Rew.rewrite f ▹ ·)) (Ξ := Head.rewrite f Ξ) (φ := + Rew.rewrite (Rew.bShift ∘ f) ▹ φ) <| + (rewrite g d).cast + (by simp [g, Rewriting.shifts, free_rewrite_eq, shift_rewrite_eq, Function.comp_def]) + (by cases Ξ <;> simp [g, Head.rewrite, Head.shift, shift_rewrite_eq])) |>.cast + (by simp [Rew.q_rewrite]) + +/-- Height of an LJ derivation, with initial rules at height zero (standard definition). -/ +def height {Γ : Sequent L} {Ξ : Head L} : Γ ⊢ᴸᴶ¹ Ξ → ℕ + | identity _ _ => 0 + | cut d₁ d₂ => max (height d₁) (height d₂) + 1 + | contraction d => height d + 1 + | weakening d => height d + 1 + | weakeningRight d => height d + 1 + | verum => 0 + | falsum => 0 + | positiveImply d => height d + 1 + | negativeImply d₁ d₂ => max (height d₁) (height d₂) + 1 + | positiveAnd d₁ d₂ => max (height d₁) (height d₂) + 1 + | negativeAnd d => height d + 1 + | positiveOrLeft d => height d + 1 + | positiveOrRight d => height d + 1 + | negativeOr d₁ d₂ => max (height d₁) (height d₂) + 1 + | positiveForall d => height d + 1 + | negativeForall d => height d + 1 + | positiveExists d => height d + 1 + | negativeExists d => height d + 1 + +/-- Transport along sequent equalities preserves height (routine). -/ +@[simp] +lemma height_cast {Γ Δ : Sequent L} {Ξ Λ : Head L} (d : Γ ⊢ᴸᴶ¹ Ξ) (hΓ : Γ = Δ) (hΞ : Ξ = Λ) : + height (d.cast hΓ hΞ) = height d := by + subst Δ + subst Λ + rfl + +/-- Term substitution preserves derivation height (standard syntactic property). -/ +@[simp] +lemma height_rewrite (f : ℕ → SyntacticTerm L) {Γ : Sequent L} {Ξ : Head L} (d : Γ ⊢ᴸᴶ¹ Ξ) : + height (d.rewrite f) = height d := + by + induction d generalizing f <;> simp only [LJ.Derivation.rewrite, height, height_cast] + case positiveAnd a b iha ihb => exact congrArg (· + 1) <| congrArg₂ max (iha f) (ihb f) + all_goals aesop + +/-- The map construction in `FFL.FirstOrder.LJ.Derivation`. -/ +protected def map (d : Γ ⊢ᴸᴶ¹ Ξ) (f : ℕ → ℕ) : + Γ.map (Rew.rewriteMap f ▹ ·) ⊢ᴸᴶ¹ Ξ.map (Rew.rewriteMap f ▹ ·) := + d.rewrite fun x ↦ &(f x) + +/-- The shift construction in `FFL.FirstOrder.LJ.Derivation`. -/ +protected def shift (d : Γ ⊢ᴸᴶ¹ Ξ) : Γ⁺ ⊢ᴸᴶ¹ Ξ.shift := + cast (d.map Nat.succ) (by rfl) (by cases Ξ <;> rfl) + +/-- The dni construction in `FFL.FirstOrder.LJ.Derivation`. -/ +def dni {φ : Propositionᵢ L} (d : Γ ⊢ᴸᴶ¹ φ) : Γ ⊢ᴸᴶ¹ (∼∼φ : Propositionᵢ L) := + positiveNeg d.negativeNeg.weakeningRight + +/-- Contraposition for singleton derivations (standard intuitionistic reasoning). -/ +def contrapose {φ ψ : Propositionᵢ L} (d : ⦃φ⦄ ⊢ᴸᴶ¹ ψ) : ⦃∼ψ⦄ ⊢ᴸᴶ¹ (∼φ : Propositionᵢ L) := + positiveNeg <| d.negativeNeg.weakeningRight.cast (heq := rfl) + +/-- Double negation preserves derivability, by twice applying contraposition (folklore). -/ +def doubleNegationMap {φ ψ : Propositionᵢ L} (d : ⦃φ⦄ ⊢ᴸᴶ¹ ψ) : + ⦃∼∼φ⦄ ⊢ᴸᴶ¹ (∼∼ψ : Propositionᵢ L) := + d.contrapose.contrapose + +/-- The dne Of Negative construction in `FFL.FirstOrder.LJ.Derivation`. -/ +def dneOfNegative : {φ : Propositionᵢ L} → φ.IsNegative → ⦃∼∼φ⦄ ⊢ᴸᴶ¹ φ + | ⊥, _ => + ((positiveNeg (Γ := 0) (φ := ⊥) ((eta ⊥).cast (by simp))).negativeNeg.weakeningRight).cast + (heq := rfl) + | φ ⋏ ψ, h => + have hn : φ.IsNegative ∧ ψ.IsNegative := by simpa using h + positiveAnd (cutOne (doubleNegationMap (andLeft (eta _))) (dneOfNegative hn.1)) + (cutOne (doubleNegationMap (andRight (eta _))) (dneOfNegative hn.2)) + | φ ⇒ₗ ψ, h => by + have ihψ := dneOfNegative (φ := ψ) (by simpa using h) + let d₁ : ⦃φ⦄ + ⦃φ ⇒ₗ ψ⦄ ⊢ᴸᴶ¹ ψ := + negativeImply (Δ := 0) (eta φ) ((eta ψ).cast (by simp) rfl) |>.cast (heq := rfl) + let d₂ : ⦃φ, ∼ψ⦄ ⊢ᴸᴶ¹ (∼(φ ⇒ₗ ψ) : Propositionᵢ L) := + positiveNeg <| d₁.negativeNeg.weakeningRight.cast (heq := rfl) + let d₃ : ⦃∼∼(φ ⇒ₗ ψ), φ⦄ ⊢ᴸᴶ¹ (∼∼ψ : Propositionᵢ L) := + positiveNeg <| d₂.negativeNeg.weakeningRight.cast (heq := rfl) + exact positiveImply (cutOne d₃ ihψ) + | ∀¹ φ, h => + positiveForall <| + cutOne + (cast (doubleNegationMap (specialize (eta (∀¹ Rewriting.shift φ)) &0)) + (by simp [Semiformulaᵢ.neg_def]) (by simp)) + (dneOfNegative (by simpa using h)) +termination_by φ _ => φ.complexity + +/-- The of DNOf Negative construction in `FFL.FirstOrder.LJ.Derivation`. -/ +def ofDNOfNegative {φ : Propositionᵢ L} (d : Γ ⊢ᴸᴶ¹ (∼∼φ : Propositionᵢ L)) (h : φ.IsNegative) : + Γ ⊢ᴸᴶ¹ φ := + cutOne d (dneOfNegative h) + +/-- Mutual LJ derivability from singleton antecedents. -/ +abbrev InterDerivation (L : Language.{u}) (φ ψ : Propositionᵢ L) := + (⦃φ⦄ ⊢ᴸᴶ¹ ψ) × (⦃ψ⦄ ⊢ᴸᴶ¹ φ) + +namespace InterDerivation + +variable {φ ψ χ φ₁ φ₂ ψ₁ ψ₂ : Propositionᵢ L} + +/-- The refl construction in `FFL.FirstOrder.LJ.Derivation.InterDerivation`. -/ +protected def refl (φ : Propositionᵢ L) : InterDerivation L φ φ := + ⟨eta φ, eta φ⟩ + +/-- The symm construction in `FFL.FirstOrder.LJ.Derivation.InterDerivation`. -/ +def symm (d : InterDerivation L φ ψ) : InterDerivation L ψ φ := + ⟨d.2, d.1⟩ + +/-- The trans construction in `FFL.FirstOrder.LJ.Derivation.InterDerivation`. -/ +def trans (d₁ : InterDerivation L φ ψ) (d₂ : InterDerivation L ψ χ) : InterDerivation L φ χ := + ⟨cutOne d₁.1 d₂.1, cutOne d₂.2 d₁.2⟩ + +/-- The neg construction in `FFL.FirstOrder.LJ.Derivation.InterDerivation`. -/ +def neg (d : InterDerivation L φ ψ) : InterDerivation L (∼φ) (∼ψ) := + ⟨contrapose d.2, contrapose d.1⟩ + +/-- The and construction in `FFL.FirstOrder.LJ.Derivation.InterDerivation`. -/ +def and (dφ : InterDerivation L φ₁ φ₂) (dψ : InterDerivation L ψ₁ ψ₂) : + InterDerivation L (φ₁ ⋏ ψ₁) (φ₂ ⋏ ψ₂) := + by + constructor + · exact positiveAnd (cutOne (andLeft (eta _)) dφ.1) (cutOne (andRight (eta _)) dψ.1) + · exact positiveAnd (cutOne (andLeft (eta _)) dφ.2) (cutOne (andRight (eta _)) dψ.2) + +/-- The all construction in `FFL.FirstOrder.LJ.Derivation.InterDerivation`. -/ +def all {φ ψ : Semipropositionᵢ L 1} + (d : InterDerivation L (Rewriting.free φ) (Rewriting.free ψ)) : + InterDerivation L (∀¹ φ) (∀¹ ψ) := + by + let lift : + ∀ {φ ψ : Semipropositionᵢ L 1}, + (⦃Rewriting.free φ⦄ ⊢ᴸᴶ¹ Rewriting.free ψ) → ⦃∀¹ φ⦄ ⊢ᴸᴶ¹ ∀¹ ψ := + fun {φ ψ} d ↦ + positiveForall <| + cutOne (cast (specialize (eta (∀¹ Rewriting.shift φ)) &0) (by simp) (by simp)) d + exact ⟨lift d.1, lift d.2⟩ + +/-- The dne construction in `FFL.FirstOrder.LJ.Derivation.InterDerivation`. -/ +def dne (h : φ.IsNegative) : InterDerivation L (∼∼φ) φ := + ⟨dneOfNegative h, dni (eta φ)⟩ + +/-- The iffneg Of Neg Iff construction in `FFL.FirstOrder.LJ.Derivation.InterDerivation`. -/ +def iffnegOfNegIff (h : φ.IsNegative) (d : InterDerivation L (∼φ) ψ) : + InterDerivation L φ (∼ψ) := + (dne h).symm.trans d.neg + +end InterDerivation + +end Derivation + +end LJ + +/-- Data and laws for LJ in `FFL.FirstOrder`. -/ +inductive LJ (L : Language.{u}) + | symbol + +/-- The «term𝐋𝐉¹» construction in `FFL.FirstOrder`. -/ +notation "𝐋𝐉¹" => LJ.symbol + +/-- The «term𝐋𝐉¹[ ]» construction in `FFL.FirstOrder`. -/ +notation "𝐋𝐉¹[" L "]" => LJ.symbol (L := L) + +/-- The Proof construction in `FFL.FirstOrder.LJ`. -/ +abbrev LJ.Proof (φ : Propositionᵢ L) := + 0 ⊢ᴸᴶ¹ some φ + +instance : Entailment (LJ L) (Propositionᵢ L) where Prf _ := LJ.Proof + +namespace LJ + +namespace Proof + +lemma def_eq (φ : Propositionᵢ L) : (𝐋𝐉¹ ⊢! φ) = (0 ⊢ᴸᴶ¹ some φ) := + rfl + +end Proof + +end LJ + +/-- Data and laws for Proof in `FFL.FirstOrder.Theoryᵢ`. -/ +structure Theoryᵢ.Proof (T : Theoryᵢ L) (σ : Sentenceᵢ L) where + /-- The axioms construction in `FFL.FirstOrder.Theoryᵢ.Proof`. -/ + axioms : Multiset (Sentenceᵢ L) + axioms_mem : ∀ ψ ∈ axioms, ψ ∈ T + /-- The derivation construction in `FFL.FirstOrder.Theoryᵢ.Proof`. -/ + derivation : axioms.map Rewriting.emb ⊢ᴸᴶ¹ ↑σ + +instance : Entailment (Theoryᵢ L) (Sentenceᵢ L) := + ⟨Theoryᵢ.Proof⟩ + +namespace Theoryᵢ +namespace Proof + +variable {T U : Theoryᵢ L} [L.DecidableEq] + +/-- The weakening construction in `FFL.FirstOrder.Theoryᵢ.Proof`. -/ +def weakening (ss : T ⊆ U) : T ⊢! σ → U ⊢! σ + | ⟨Γ, hΓ, d⟩ => ⟨Γ, fun ψ hψ ↦ ss (hΓ ψ hψ), d⟩ + +instance : Entailment.Axiomatized (Theoryᵢ L) + where + prfAxm {T} φ + h := + ⟨⦃φ⦄, by simpa using AdjunctiveSet.mem_set_iff.mp h, + LJ.Derivation.cast (LJ.Derivation.eta (φ : Propositionᵢ L)) (by simp)⟩ + weakening := weakening + +/-- The deduct construction in `FFL.FirstOrder.Theoryᵢ.Proof`. -/ +def deduct : adjoin φ T ⊢! ψ → T ⊢! φ ⇒ₗ ψ + | ⟨Γ, hΓ, d⟩ => + ⟨Γ.filter (· ≠ φ), by + intro θ hθ + have hθΓ : θ ∈ Γ := (Multiset.mem_filter.mp hθ).1 + have hθφ : θ ≠ φ := (Multiset.mem_filter.mp hθ).2 + simpa [hθφ] using hΓ θ hθΓ, + LJ.Derivation.cast (heq := by rfl) <| + LJ.Derivation.positiveImply (φ := (φ : Propositionᵢ L)) (ψ := (ψ : Propositionᵢ L)) <| + LJ.Derivation.contra d + (((d.traversal.filter (· ≠ (φ : Propositionᵢ L))).cast + (by simp [Multiset.filter_map, Rewriting.emb_injective.eq_iff])).succ + (φ : Propositionᵢ L)) + (by + intro θ hθ + rcases Multiset.mem_map.mp hθ with ⟨χ, hχ, rfl⟩ + by_cases h : χ = φ + · subst χ + simp + · exact + Multiset.mem_add.mpr <| + Or.inl <| + Multiset.mem_map_of_mem Rewriting.emb <| Multiset.mem_filter_of_mem hχ h)⟩ + +/-- The deduct Inv construction in `FFL.FirstOrder.Theoryᵢ.Proof`. -/ +def deductInv : T ⊢! φ ⇒ₗ ψ → adjoin φ T ⊢! ψ + | ⟨Γ, hΓ, d⟩ => + ⟨Γ + ⦃φ⦄, by + intro θ hθ + rcases Multiset.mem_add.mp hθ with hθ | hθ + · exact Set.mem_insert_of_mem φ (hΓ θ hθ) + · exact Or.inl (by simpa using hθ), + LJ.Derivation.cast (seq := by simp) (heq := by rfl) <| + LJ.Derivation.cut (φ := ((φ : Propositionᵢ L) ⇒ₗ (ψ : Propositionᵢ L))) (Γ := + Γ.map Rewriting.emb) (Δ := ⦃(φ : Propositionᵢ L)⦄) (Ξ := (ψ : Propositionᵢ L)) + (LJ.Derivation.cast d (heq := by rfl)) + (LJ.Derivation.cast (heq := rfl) <| + LJ.Derivation.negativeImply (φ := (φ : Propositionᵢ L)) (ψ := (ψ : Propositionᵢ L)) + (Γ := ⦃(φ : Propositionᵢ L)⦄) (Δ := 0) (Ξ := (ψ : Propositionᵢ L)) + (LJ.Derivation.eta (φ : Propositionᵢ L)) + (LJ.Derivation.cast (LJ.Derivation.eta (ψ : Propositionᵢ L)) (by simp) + (by simp)))⟩ + +instance : Entailment.Deduction (Theoryᵢ L) + where + ofInsert := deduct + inv := deductInv + +end Proof +end Theoryᵢ + +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/LJ/GoedelGentzen.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/LJ/GoedelGentzen.lean new file mode 100644 index 000000000..a2c1f0b62 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/LJ/GoedelGentzen.lean @@ -0,0 +1,264 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.LJ.Basic +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.LK.Basic + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace FFL +namespace FirstOrder + +namespace Semiformula + +/-- The double Negation construction in `FFL.FirstOrder.Semiformula`. -/ +def doubleNegation {n} : Semiformula L ξ n → Semiformulaᵢ L ξ n + | rel r v => ∼∼(.rel r v) + | nrel r v => ∼(.rel r v) + | ⊤ => ⊤ + | ⊥ => ⊥ + | φ ⋏ ψ => φ.doubleNegation ⋏ ψ.doubleNegation + | φ ⋎ ψ => ∼(∼φ.doubleNegation ⋏ ∼ψ.doubleNegation) + | ∀¹ φ => ∀¹ φ.doubleNegation + | ∃¹ φ => ∼(∀¹ ∼φ.doubleNegation) + +/-- The «term ᴺ» construction in `FFL.FirstOrder`. -/ +scoped[PointwiseComposition.FFL.FirstOrder] postfix:max "ᴺ" => Semiformula.doubleNegation + +@[simp] +lemma doubleNegation_rel {k} (r : L.Rel k) (v : Fin k → Semiterm L ξ n) : + (rel r v)ᴺ = ∼∼(.rel r v) := + rfl + +@[simp] +lemma doubleNegation_nrel {k} (r : L.Rel k) (v : Fin k → Semiterm L ξ n) : + (nrel r v)ᴺ = ∼(.rel r v) := + rfl + +@[simp] +lemma doubleNegation_verum : (⊤ : Semiformula L ξ n)ᴺ = ∼⊥ := + rfl + +@[simp] +lemma doubleNegation_falsum : (⊥ : Semiformula L ξ n)ᴺ = ⊥ := + rfl + +@[simp] +lemma doubleNegation_and (φ ψ : Semiformula L ξ n) : (φ ⋏ ψ)ᴺ = φᴺ ⋏ ψᴺ := + rfl + +@[simp] +lemma doubleNegation_or (φ ψ : Semiformula L ξ n) : (φ ⋎ ψ)ᴺ = ∼(∼φᴺ ⋏ ∼ψᴺ) := + rfl + +@[simp] +lemma doubleNegation_all (φ : Semiformula L ξ (n + 1)) : (∀¹ φ)ᴺ = ∀¹ φᴺ := + rfl + +@[simp] +lemma doubleNegation_ex (φ : Semiformula L ξ (n + 1)) : (∃¹ φ)ᴺ = ∼(∀¹ ∼φᴺ) := + rfl + +lemma doubleNegation_imply (φ ψ : Semiformula L ξ n) : (φ ⇒ₗ ψ)ᴺ = ∼(∼(∼φ)ᴺ ⋏ ∼ψᴺ) := by + simp [imp_eq] + +@[simp] +lemma doubleNegation_isNegative (φ : Semiformula L ξ n) : φᴺ.IsNegative := by + induction φ using rec' <;> simp [*] + +@[simp] +lemma doubleNegation_conj₂ (Γ : List (Semiformula L ξ n)) : + ((PointwiseComposition.List.conj₂ Γ))ᴺ = + (PointwiseComposition.List.conj₂ (Γ.map Semiformula.doubleNegation)) := + match Γ with + | [] => by simp; rfl + | [φ] => by simp + | φ :: ψ :: Γ => by simp [doubleNegation_conj₂ (ψ :: Γ)] + +lemma doubleNegation_fconj (s : Finset (Semiformula L ξ n)) : + ((PointwiseComposition.Finset.conj s))ᴺ = + (PointwiseComposition.List.conj₂ (s.toList.map Semiformula.doubleNegation)) := + doubleNegation_conj₂ _ + +lemma rew_doubleNegation (ω : Rew L ξ₁ n₁ ξ₂ n₂) (φ : Semiformula L ξ₁ n₁) : + ω ▹ φᴺ = (ω ▹ φ)ᴺ := by + induction φ using rec' generalizing n₂ <;> simp [Semiformulaᵢ.rew_rel, *, Function.comp_def] + +lemma subst_doubleNegation (φ : Semiformula L ξ n₁) (v : Fin n₁ → Semiterm L ξ n₂) : + φᴺ ↜ v = (φ ↜ v)ᴺ := + rew_doubleNegation _ _ + +lemma emb_doubleNegation (φ : Semisentence L n₁) : + Rewriting.emb (φᴺ) = (Rewriting.emb φ : Semiformula L ξ n₁)ᴺ := + rew_doubleNegation _ _ + +end Semiformula + +namespace LK +namespace Sequent + +/-- The double Negation construction in `FFL.FirstOrder.LK.Sequent`. -/ +def doubleNegation (Γ : LK.Sequent L) : LJ.Sequent L := + Γ.map Semiformula.doubleNegation + +/-- The «term ᴺ 1» construction in `FFL.FirstOrder`. -/ +scoped[PointwiseComposition.FFL.FirstOrder] postfix:max "ᴺ" => LK.Sequent.doubleNegation + +@[simp] +lemma doubleNegation_zero : (0 : LK.Sequent L)ᴺ = 0 := + rfl + +@[simp] +lemma doubleNegation_atom (φ : Proposition L) : (⦃φ⦄ : LK.Sequent L)ᴺ = ⦃φᴺ⦄ := by + simp [doubleNegation] + +@[simp] +lemma doubleNegation_add (Γ Δ : LK.Sequent L) : (Γ + Δ)ᴺ = Γᴺ + Δᴺ := by simp [doubleNegation] + +lemma shift_doubleNegation (Γ : LK.Sequent L) : (Γᴺ)⁺ = (Γ⁺)ᴺ := by + simp [LK.Sequent.doubleNegation, Rewriting.shifts, Semiformula.rew_doubleNegation] + +end Sequent +end LK + +/-- The double Negation construction in `FFL.FirstOrder.Theory`. -/ +def Theory.doubleNegation (T : Theory L) : Theoryᵢ L := + Semiformula.doubleNegation '' T + +namespace LJ +namespace Derivation + +open Rewriting LawfulSyntacticRewriting + +variable {L : Language} [L.DecidableEq] + +/-- The neg Double Negation construction in `FFL.FirstOrder.LJ.Derivation`. -/ +def negDoubleNegation : (φ : Proposition L) → InterDerivation L (∼φᴺ) (∼φ)ᴺ + | .rel R v => InterDerivation.dne (by simp) + | .nrel R v => InterDerivation.refl _ + | ⊤ => by + constructor + · exact + negElim (eta (∼(⊤ : Propositionᵢ L))) <| verum.weakening (φ := ∼∼(⊥ : Propositionᵢ L)) + · apply positiveNeg + exact assumption ((Multiset.Traversal.atom _).succ _) (by simp) + | ⊥ => InterDerivation.refl _ + | φ ⋏ ψ => by + have eφ := (negDoubleNegation φ).iffnegOfNegIff (by simp) + have eψ := (negDoubleNegation ψ).iffnegOfNegIff (by simp) + simpa using (eφ.and eψ).neg + | φ ⋎ ψ => by + have e := (negDoubleNegation φ).and (negDoubleNegation ψ) + exact (InterDerivation.dne (by simp)).trans e + | ∀¹ φ => by + have e := (negDoubleNegation (Rewriting.free φ)).iffnegOfNegIff (by simp) + have e : InterDerivation L (Rewriting.free φᴺ) (Rewriting.free (∼(∼φ)ᴺ)) := by + simpa [Semiformula.rew_doubleNegation] using e + simpa using (InterDerivation.all e).neg + | ∃¹ φ => by + have e := negDoubleNegation (Rewriting.free φ) + have e : InterDerivation L (Rewriting.free (∼φᴺ)) (Rewriting.free ((∼φ)ᴺ)) := by + simpa [Semiformula.rew_doubleNegation] using e + exact (InterDerivation.dne (by simp)).trans (InterDerivation.all e) +termination_by φ => φ.complexity + +/-- The neg Double Negation' construction in `FFL.FirstOrder.LJ.Derivation`. -/ +def negDoubleNegation' (φ : Proposition L) : InterDerivation L (∼(∼φ)ᴺ) φᴺ := by + simpa using negDoubleNegation (∼φ) + +end Derivation +end LJ + +namespace LK +namespace Derivation + +open Rewriting LawfulSyntacticRewriting + +variable {L : Language} [L.DecidableEq] + +/-- Discharges a translated negated formula from an LJ contradiction derivation. -/ +def deductNeg {Γ : LK.Sequent L} {φ : Proposition L} + (d : (∼(Γ + ⦃φ⦄))ᴺ ⊢ᴸᴶ¹ (⊥ : Propositionᵢ L)) : (∼Γ)ᴺ ⊢ᴸᴶ¹ (∼(∼φ)ᴺ : Propositionᵢ L) := + LJ.Derivation.positiveNeg (Γ := (∼Γ)ᴺ) (φ := (∼φ)ᴺ) <| d.cast (by simp) + +/-- The gödel Gentzen construction in `FFL.FirstOrder.LK.Derivation`. -/ +def gödelGentzen {Γ : LK.Sequent L} : ⊢ᴸᴷ¹ Γ → (∼Γ)ᴺ ⊢ᴸᴶ¹ (⊥ : Propositionᵢ L) + | identity R v => by + exact + ((LJ.Derivation.eta (∼(.rel R v) : Propositionᵢ L)).negativeNeg.cast + (by simp [LK.Sequent.doubleNegation]) (by rfl)).weakeningRight + | verum => by simpa [LK.Sequent.doubleNegation] using LJ.Derivation.eta (⊥ : Propositionᵢ L) + | and (Γ := Γ) (φ := φ) (ψ := ψ) dφ dψ => + by + have dφ : (∼Γ)ᴺ ⊢ᴸᴶ¹ (∼(∼φ)ᴺ : Propositionᵢ L) := deductNeg (gödelGentzen dφ) + have dψ : (∼Γ)ᴺ ⊢ᴸᴶ¹ (∼(∼ψ)ᴺ : Propositionᵢ L) := deductNeg (gödelGentzen dψ) + have dAnd := LJ.Derivation.positiveAnd dφ dψ + exact (dAnd.negativeNeg.cast (by simp [LK.Sequent.doubleNegation]) (by rfl)).weakeningRight + | or (Γ := Γ) (φ := φ) (ψ := ψ) d => + (LJ.Derivation.negativeAnd (Γ := (∼Γ)ᴺ) (φ := (∼φ)ᴺ) (ψ := (∼ψ)ᴺ) (Ξ := + (⊥ : Propositionᵢ L)) <| + (gödelGentzen d).cast (by simp)).cast + (by simp [LK.Sequent.doubleNegation]) + | all (Γ := Γ) (φ := φ) d => + by + have hshift : (∼Γ⁺)ᴺ = ((∼Γ)ᴺ)⁺ := by + rw [← Rewriting.shifts_neg, LK.Sequent.shift_doubleNegation] + have dFree : ((∼Γ)ᴺ)⁺ ⊢ᴸᴶ¹ (∼Rewriting.free ((∼φ)ᴺ) : Propositionᵢ L) := + (deductNeg (gödelGentzen d)).cast (by simp [hshift]) + (by simp [Semiformula.rew_doubleNegation]) + have dAll := + LJ.Derivation.positiveForall (Γ := (∼Γ)ᴺ) (φ := ∼(∼φ)ᴺ) <| + dFree.cast (heq := by simp [Semiformula.rew_doubleNegation]) + exact (dAll.negativeNeg.cast (by simp [LK.Sequent.doubleNegation]) (by rfl)).weakeningRight + | exs (Γ := Γ) (φ := φ) (t := t) d => + (LJ.Derivation.negativeForall (Γ := (∼Γ)ᴺ) (φ := (∼φ)ᴺ) (t := t) (Ξ := + (⊥ : Propositionᵢ L)) <| + (gödelGentzen d).cast (by simp [Semiformula.rew_doubleNegation])) |>.cast + (by simp [LK.Sequent.doubleNegation]) + | cut (Γ := Γ) (Δ := Δ) (φ := φ) d dn => + by + have ihn := gödelGentzen dn + have dnφ : (∼Γ)ᴺ ⊢ᴸᴶ¹ (∼(∼φ)ᴺ : Propositionᵢ L) := deductNeg (gödelGentzen d) + have dφ : (∼Γ)ᴺ ⊢ᴸᴶ¹ φᴺ := LJ.Derivation.cutOne dnφ (LJ.Derivation.negDoubleNegation' φ).1 + exact + (LJ.Derivation.cut (Γ := (∼Γ)ᴺ) (Δ := (∼Δ)ᴺ) (φ := φᴺ) (Ξ := (⊥ : Propositionᵢ L)) dφ <| + ihn.cast (by simp)).cast + (by simp [LK.Sequent.doubleNegation]) + | contraction (Γ := Γ) (φ := φ) d => + have e : (∼Γ)ᴺ + ⦃(∼φ)ᴺ, (∼φ)ᴺ⦄ ⊢ᴸᴶ¹ (⊥ : Propositionᵢ L) := + (gödelGentzen d).cast (by simp [LK.Sequent.doubleNegation]) (by rfl) + (LJ.Derivation.contraction (Γ := (∼Γ)ᴺ) (φ := (∼φ)ᴺ) (Ξ := (⊥ : Propositionᵢ L)) e).cast + (by simp [LK.Sequent.doubleNegation]) (by rfl) + | weakening (Γ := Γ) (φ := φ) d => + ((gödelGentzen d).weakening (φ := (∼φ)ᴺ)).cast (by simp [LK.Sequent.doubleNegation]) + +end Derivation +end LK + +theorem Provable.gödel_gentzen {L : Language.{u}} [L.DecidableEq] {φ : Proposition L} : + 𝐋𝐊¹ ⊢ φ → 𝐋𝐉¹ ⊢ φᴺ := by + rintro ⟨d⟩ + have d : ⦃(∼φ)ᴺ⦄ ⊢ᴸᴶ¹ (⊥ : Propositionᵢ L) := by + simpa [LK.Sequent.doubleNegation] using LK.Derivation.gödelGentzen d + have dn : (0 : LJ.Sequent L) ⊢ᴸᴶ¹ (∼(∼φ)ᴺ : Propositionᵢ L) := + LJ.Derivation.positiveNeg (φ := (∼φ)ᴺ) d + exact ⟨LJ.Derivation.cutOne dn (LJ.Derivation.negDoubleNegation' φ).1⟩ + +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/LJ/Head.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/LJ/Head.lean new file mode 100644 index 000000000..bbb99d9e1 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/LJ/Head.lean @@ -0,0 +1,83 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Multiset +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Option +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Syntax.Intuitionistic.Rew +public import LeanPool.PointwiseComposition.Foundation.Logic.Calculus + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# First-order $\mathbf{LJ}$ -/ + +@[expose] public section + +namespace FFL +namespace FirstOrder + +variable {L : Language.{u}} + +open Semiformulaᵢ + +/-- The Theoryᵢ construction in `FFL.FirstOrder`. -/ +abbrev Theoryᵢ (L : Language.{u}) := + Set (Sentenceᵢ L) + +namespace LJ + +/-- The Sequent construction in `FFL.FirstOrder.LJ`. -/ +abbrev Sequent (L : Language.{u}) := + Multiset (Propositionᵢ L) + +/-- The Head construction in `FFL.FirstOrder.LJ`. -/ +abbrev Head (L : Language.{u}) := + Option (Propositionᵢ L) + +namespace Head + +/-- The shift construction in `FFL.FirstOrder.LJ.Head`. -/ +def shift (Ξ : Head L) : Head L := + Ξ.map Rewriting.shift + +/-- The rewrite construction in `FFL.FirstOrder.LJ.Head`. -/ +def rewrite (f : ℕ → SyntacticTerm L) (Ξ : Head L) : Head L := + Ξ.map (Rew.rewrite f ▹ ·) + +@[simp] +lemma shift_none : shift (none : Head L) = none := + rfl + +@[simp] +lemma shift_some (φ : Propositionᵢ L) : shift φ = some (Rewriting.shift φ) := + rfl + +@[simp] +lemma rewrite_none (f : ℕ → SyntacticTerm L) : rewrite f (none : Head L) = none := + rfl + +@[simp] +lemma rewrite_some (f : ℕ → SyntacticTerm L) (φ : Propositionᵢ L) : + rewrite f φ = some (Rew.rewrite f ▹ φ) := + rfl + +end Head + +end LJ + +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/Basic.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/Basic.lean new file mode 100644 index 000000000..5a75426f7 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/Basic.lean @@ -0,0 +1,651 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +/- public import Foundation.Logic.Calculus -/ +public import LeanPool.PointwiseComposition.Foundation.Logic.Calculus +public import LeanPool.PointwiseComposition.Foundation.Propositional.Entailment.Int +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Syntax.Classical.Rew +public import Mathlib.Data.List.MinMax + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# One-sided sequent calculus for first-order classical logic -/ + +@[expose] public section + +namespace FFL + +namespace FirstOrder + +variable {L : Language} + +/-- The Sequent construction in `FFL.FirstOrder.LK`. -/ +abbrev LK.Sequent (L : Language) := + Multiset (Proposition L) + +namespace LK +namespace Sequent + +open Semiformula + +/-- The new Var construction in `FFL.FirstOrder.LK.Sequent`. -/ +def newVar (Γ : LK.Sequent L) : ℕ := + (Γ.map Semiformula.fvSup).foldr max 0 + +lemma not_hasFreeVariable_newVar {φ : Proposition L} {Γ : LK.Sequent L} (h : φ ∈ Γ) : + ¬HasFreeVariable φ Γ.newVar := + not_hasFreeVariable_of_lt_fvSup φ <| by + simp only [newVar] + induction Γ using Multiset.induction_on with + | empty => simp at h + | @cons ψ Γ ih => + simp only [Multiset.map_cons, Multiset.foldr_cons] + rcases Multiset.mem_cons.mp h with (rfl | h) + · exact Nat.le_max_left _ _ + · exact (ih h).trans (Nat.le_max_right _ _) + +/-- The Is Closed construction in `FFL.FirstOrder.LK.Sequent`. -/ +def IsClosed (Γ : LK.Sequent L) : Prop := + ∃ φ ∈ Γ, ∼φ ∈ Γ + +/-- The embed construction in `FFL.FirstOrder.LK.Sequent`. -/ +def embed (Γ : Multiset (Sentence L)) : LK.Sequent L := + Γ.map Rewriting.emb + +@[simp] +lemma embed_nil : embed (0 : Multiset (Sentence L)) = 0 := + rfl + +@[simp] +lemma embed_singleton {φ : Sentence L} : + embed (⦃φ⦄ : Multiset (Sentence L)) = ⦃(φ : Proposition L)⦄ := + rfl + +@[simp] +lemma embed_add (Γ Δ : Multiset (Sentence L)) : embed (Γ + Δ) = embed Γ + embed Δ := by + simp [embed] + +@[simp] +lemma embed_shift (Γ : Multiset (Sentence L)) : (embed Γ)⁺ = embed Γ := by + simp [embed, Rewriting.shifts] + +end Sequent +end LK + +/-! +## Derivation for $\mathbf{LK}$ -/ + +/-- Derivation for $\mathbf{LK}$ -/ +inductive LK.Derivation : LK.Sequent L → Type _ + | identity (r : L.Rel k) (v) : LK.Derivation ⦃.rel r v, .nrel r v⦄ + | cut : LK.Derivation (Γ + ⦃φ⦄) → LK.Derivation (Δ + ⦃∼φ⦄) → LK.Derivation (Γ + Δ) + | contraction : LK.Derivation (Γ + ⦃φ, φ⦄) → LK.Derivation (Γ + ⦃φ⦄) + | weakening : LK.Derivation Γ → LK.Derivation (Γ + ⦃φ⦄) + | verum : LK.Derivation ⦃⊤⦄ + | or : LK.Derivation (Γ + ⦃φ, ψ⦄) → LK.Derivation (Γ + ⦃φ ⋎ ψ⦄) + | and : LK.Derivation (Γ + ⦃φ⦄) → LK.Derivation (Γ + ⦃ψ⦄) → LK.Derivation (Γ + ⦃φ ⋏ ψ⦄) + | all : LK.Derivation (Γ⁺ + ⦃φ.free⦄) → LK.Derivation (Γ + ⦃∀¹ φ⦄) + | exs : LK.Derivation (Γ + ⦃φ/[t]⦄) → LK.Derivation (Γ + ⦃∃¹ φ⦄) + +/-- The «term⊢ᴸᴷ¹ » construction in `FFL.FirstOrder`. -/ +prefix:45 "⊢ᴸᴷ¹ " => LK.Derivation + +namespace LK +namespace Derivation + +open Rewriting LawfulSyntacticRewriting + +variable {Γ Δ : LK.Sequent L} + +/-- The height construction in `FFL.FirstOrder.LK.Derivation`. -/ +def height {Δ : LK.Sequent L} : ⊢ᴸᴷ¹ Δ → ℕ + | identity _ _ => 0 + | cut dp dn => max dp.height dn.height + 1 + | contraction d => d.height + 1 + | weakening d => d.height + 1 + | verum => 0 + | or d => d.height + 1 + | and dp dq => max (height dp) (height dq) + 1 + | all d => d.height + 1 + | exs d => d.height + 1 + +section height + +@[simp] +lemma height_id {k} {r : L.Rel k} {v} : height (identity r v) = 0 := + rfl + +@[simp] +lemma height_cut {φ} (dp : ⊢ᴸᴷ¹ Γ + ⦃φ⦄) (dn : ⊢ᴸᴷ¹ Δ + ⦃∼φ⦄) : + height (cut dp dn) = (max (height dp) (height dn)).succ := + rfl + +@[simp] +lemma height_contraction (d : ⊢ᴸᴷ¹ Γ + ⦃φ, φ⦄) : height (contraction d) = d.height.succ := + rfl + +@[simp] +lemma height_weakening (d : ⊢ᴸᴷ¹ Γ) : height (weakening (φ := φ) d) = d.height.succ := + rfl + +@[simp] +lemma height_verum : height (verum : ⊢ᴸᴷ¹ (⦃⊤⦄ : LK.Sequent L)) = 0 := + rfl + +@[simp] +lemma height_and {φ ψ} (dp : ⊢ᴸᴷ¹ Γ + ⦃φ⦄) (dq : ⊢ᴸᴷ¹ Γ + ⦃ψ⦄) : + height (and dp dq) = (max (height dp) (height dq)).succ := + rfl + +@[simp] +lemma height_or {φ ψ} (d : ⊢ᴸᴷ¹ Γ + ⦃φ, ψ⦄) : height (or d) = d.height.succ := + rfl + +@[simp] +lemma height_all {φ : Semiproposition L 1} (d : ⊢ᴸᴷ¹ Γ⁺ + ⦃φ.free⦄) : + height (all d) = d.height.succ := + rfl + +@[simp] +lemma height_exs {t} {φ} (d : ⊢ᴸᴷ¹ Γ + ⦃φ/[t]⦄) : height (exs d) = d.height.succ := + rfl + +end height + +/-- The cast construction in `FFL.FirstOrder.LK.Derivation`. -/ +abbrev cast (d : ⊢ᴸᴷ¹ Δ) (e : Δ = Γ := by abel) : ⊢ᴸᴷ¹ Γ := + e ▸ d + +@[simp] +lemma height_cast (d : ⊢ᴸᴷ¹ Δ) (e : Δ = Γ) : height (LK.Derivation.cast d e) = height d := by + rcases e with rfl; simp [LK.Derivation.cast] + +instance : Structural (LK.Derivation (L := L)) + where + weakening d := d.weakening + contraction d := d.contraction + +/-- Enumerates the end sequent by recursion on the local inference rules. +This is a routine syntactic construction. -/ +def traversal [L.DecidableEq] {Γ : LK.Sequent L} : + ⊢ᴸᴷ¹ Γ → (PointwiseComposition.Multiset.Traversal Γ) + | identity r v => (Multiset.Traversal.atom (Semiformula.rel r v)).succ (Semiformula.nrel r v) + | cut d dn => d.traversal.remove.add dn.traversal.remove + | contraction (φ := φ) d => (d.traversal.cast (by abel)).remove (a := φ) + | weakening (φ := φ) d => d.traversal.succ φ + | verum => .atom ⊤ + | or (φ := φ) (ψ := ψ) d => + ((d.traversal.cast (by abel)).remove (a := ψ)).remove (a := φ) |>.succ (φ ⋎ ψ) + | and (φ := φ) (ψ := ψ) d _ => d.traversal.remove.succ (φ ⋏ ψ) + | all (Γ := Γ) (φ := φ) d => + ((d.traversal.remove.map (Rew.rewriteMap Nat.pred ▹ ·)).cast + (by simp [Rewriting.shifts, Multiset.map_map, Rewriting.rewriteMap_pred_shift])).succ + (∀¹ φ) + | exs (φ := φ) d => d.traversal.remove.succ (∃¹ φ) + +/-- Applies structural rules along supplied traversals (a routine derived rule). -/ +def contra [L.DecidableEq] (d : ⊢ᴸᴷ¹ Δ) (t : (PointwiseComposition.Multiset.Traversal Γ)) + (h : Δ ⊆ Γ := by simp) : ⊢ᴸᴷ¹ Γ := + Structural.ofSubset (F := Proposition L) (𝔇 := LK.Derivation (L := L)) (Γ := Δ) (Δ := Γ) + (traversal (L := L) d) t d h + +/-- The tensor construction in `FFL.FirstOrder.LK.Derivation`. -/ +def tensor {φ ψ} (tΓ : (PointwiseComposition.Multiset.Traversal Γ)) + (tΔ : (PointwiseComposition.Multiset.Traversal Δ)) (dφ : ⊢ᴸᴷ¹ Γ + ⦃φ⦄) (dψ : ⊢ᴸᴷ¹ Δ + ⦃ψ⦄) : + ⊢ᴸᴷ¹ Γ + Δ + ⦃φ ⋏ ψ⦄ := + and (Structural.weakenMany tΔ dφ |>.cast) (Structural.weakenMany tΓ dψ |>.cast) + +/-- The eta construction in `FFL.FirstOrder.LK.Derivation`. -/ +def eta : (φ : Proposition L) → ⊢ᴸᴷ¹ ⦃φ, ∼φ⦄ + | .rel R v => identity R v + | .nrel R v => (identity R v).cast (by simp [add_comm]) + | ⊤ => verum.weakening + | ⊥ => (verum.weakening (φ := ⊥)).cast (by simp [add_comm]) + | φ ⋏ ψ => + (or (Γ := ⦃φ ⋏ ψ⦄) (φ := ∼φ) (ψ := ∼ψ) + (tensor (Γ := ⦃∼φ⦄) (Δ := ⦃∼ψ⦄) (φ := φ) (ψ := ψ) (Multiset.Traversal.atom _) + (Multiset.Traversal.atom _) (eta φ).cast (eta ψ).cast).cast).cast + (by simp [add_comm]) + | φ ⋎ ψ => + (or (Γ := ⦃∼φ ⋏ ∼ψ⦄) (φ := φ) (ψ := ψ) + (tensor (Γ := ⦃φ⦄) (Δ := ⦃ψ⦄) (φ := ∼φ) (ψ := ∼ψ) (Multiset.Traversal.atom _) + (Multiset.Traversal.atom _) (eta φ) (eta ψ)).cast).cast + (by simp [add_comm]) + | ∀¹ φ => + (all (Γ := ⦃∃¹ ∼φ⦄) (φ := φ) + ((exs (Γ := ⦃φ.free⦄) (φ := ∼φ.shift) (t := &0) ((eta φ.free).cast (by simp))).cast + (by simp [add_comm]))).cast + (by simp [add_comm]) + | ∃¹ φ => + (all (Γ := ⦃∃¹ φ⦄) (φ := ∼φ) + (cast + (exs (Γ := ⦃(∼φ).free⦄) (φ := φ.shift) (t := &0) + ((eta φ.free).cast (by simp [add_comm]))) + (by simp [add_comm]))).cast + (by simp) +termination_by φ => φ.complexity + +instance : OneSidedLK (LK.Derivation (L := L)) + where + verum := verum + and d₁ d₂ := d₁.and d₂ + or d := d.or + weakening d := d.weakening + contraction d := d.contraction + identity φ := eta φ + +instance : OneSidedLK.Cut (LK.Derivation (L := L)) where cut dp dn := cut dp dn + +lemma of_isClosed {Γ : LK.Sequent L} (h : Γ.IsClosed) : Nonempty (⊢ᴸᴷ¹ Γ) := by + classical + rcases h with ⟨φ, hp, hn⟩ + refine ⟨contra (L := L) (eta φ) (default : PointwiseComposition.Multiset.Traversal Γ) ?_⟩ + intro ψ hψ + simp only [Multiset.mem_add, Multiset.mem_atom_iff] at hψ + rcases hψ with rfl | rfl <;> assumption + +/-- The rewrite construction in `FFL.FirstOrder.LK.Derivation`. -/ +def rewrite {Γ} (f : ℕ → SyntacticTerm L) : ⊢ᴸᴷ¹ Γ → ⊢ᴸᴷ¹ Γ.map (Rew.rewrite f ▹ ·) + | identity R v => identity R (Rew.rewrite f ∘ v) + | cut (φ := φ) (Γ := Γ) (Δ := Δ) d₁ d₂ => + (cut (Γ := Γ.map (Rew.rewrite f ▹ ·)) (Δ := Δ.map (Rew.rewrite f ▹ ·)) (φ := + Rew.rewrite f ▹ φ) ((d₁.rewrite f).cast (by simp)) + ((d₂.rewrite f).cast (by simp))).cast + (by simp) + | contraction (Γ := Γ) (φ := φ) d => + (contraction (Γ := Γ.map (Rew.rewrite f ▹ ·)) (φ := Rew.rewrite f ▹ φ) + ((d.rewrite f).cast (by simp))).cast + (by simp) + | weakening (Γ := Γ) (φ := φ) d => + (weakening (φ := Rew.rewrite f ▹ φ) (d.rewrite f)).cast (by simp) + | verum => verum + | or (Γ := Γ) (φ := φ) (ψ := ψ) d => + (or (Γ := Γ.map (Rew.rewrite f ▹ ·)) (φ := Rew.rewrite f ▹ φ) (ψ := Rew.rewrite f ▹ ψ) + ((d.rewrite f).cast (by simp))).cast + (by simp) + | and (Γ := Γ) (φ := φ) (ψ := ψ) d₁ d₂ => + (and (Γ := Γ.map (Rew.rewrite f ▹ ·)) (φ := Rew.rewrite f ▹ φ) (ψ := Rew.rewrite f ▹ ψ) + ((d₁.rewrite f).cast (by simp)) ((d₂.rewrite f).cast (by simp))).cast + (by simp) + | all (φ := φ) (Γ := Γ) d => + let g : ℕ → SyntacticTerm L := &0 :>ₙ fun x ↦ Rew.shift (f x) + have : ⊢ᴸᴷ¹ (Γ⁺ + ⦃φ.free⦄).map (Rew.rewrite g ▹ ·) := d.rewrite g + (all (Γ := Γ.map (Rew.rewrite f ▹ ·)) (φ := Rew.rewrite (Rew.bShift ∘ f) ▹ φ) + (LK.Derivation.cast this + (by + simp [g, free_rewrite_eq, Rewriting.shifts, shift_rewrite_eq, + Function.comp_def]))).cast + (by simp [Rew.q_rewrite]) + | exs (φ := φ) (Γ := Γ) (t := t) d => + have : ⊢ᴸᴷ¹ (Γ + ⦃φ/[t]⦄).map (Rew.rewrite f ▹ ·) := d.rewrite f + (exs (Γ := Γ.map (Rew.rewrite f ▹ ·)) (φ := Rew.rewrite (Rew.bShift ∘ f) ▹ φ) (t := + Rew.rewrite f t) (LK.Derivation.cast this (by simp [rewrite_subst_eq]))).cast + (by simp [Rew.q_rewrite]) + +/-- The map construction in `FFL.FirstOrder.LK.Derivation`. -/ +protected def map {Δ : LK.Sequent L} (d : ⊢ᴸᴷ¹ Δ) (f : ℕ → ℕ) : + ⊢ᴸᴷ¹ Δ.map (Rew.rewriteMap f ▹ ·) := + d.rewrite (fun x ↦ &(f x)) + +/-- The shift construction in `FFL.FirstOrder.LK.Derivation`. -/ +protected def shift {Δ : LK.Sequent L} (d : ⊢ᴸᴷ¹ Δ) : ⊢ᴸᴷ¹ Δ⁺ := + LK.Derivation.cast (LK.Derivation.map d Nat.succ) (by rfl) + +section Hom + +variable {L₁ : Language} {L₂ : Language} {Δ₁ : LK.Sequent L₁} + +lemma shifts_image (Φ : L₁ →ᵥ L₂) {Δ : Multiset (Proposition L₁)} : + (Δ.map <| Semiformula.lMap Φ)⁺ = (Δ⁺.map <| Semiformula.lMap Φ) := by + simp [Rewriting.shifts, Semiformula.lMap_shift] + +/-- The l Map construction in `FFL.FirstOrder.LK.Derivation`. -/ +def lMap (Φ : L₁ →ᵥ L₂) {Γ} : ⊢ᴸᴷ¹ Γ → ⊢ᴸᴷ¹ Γ.map (.lMap Φ) + | identity r v => + .cast (identity (Φ.rel r) (fun i ↦ .lMap Φ (v i))) (by simp [Function.comp_def]) + | cut (Γ := Γ) (Δ := Δ) (φ := φ) d dn => + (cut (Γ := Γ.map (.lMap Φ)) (Δ := Δ.map (.lMap Φ)) (φ := .lMap Φ φ) + (LK.Derivation.cast (lMap Φ d) (by simp)) + (LK.Derivation.cast (lMap Φ dn) (by simp))).cast + (by simp) + | contraction (Γ := Γ) (φ := φ) d => + (contraction (Γ := Γ.map (.lMap Φ)) (φ := .lMap Φ φ) ((lMap Φ d).cast (by simp))).cast + (by simp) + | weakening (φ := φ) d => (weakening (φ := .lMap Φ φ) (lMap Φ d)).cast (by simp) + | verum => by simpa using verum + | or (Γ := Γ) (φ := φ) (ψ := ψ) d => + (or (Γ := Γ.map (.lMap Φ)) (φ := .lMap Φ φ) (ψ := .lMap Φ ψ) + (LK.Derivation.cast (lMap Φ d) (by simp))).cast + (by simp) + | and (Γ := Γ) (φ := φ) (ψ := ψ) dp dq => + (and (Γ := Γ.map (.lMap Φ)) (φ := .lMap Φ φ) (ψ := .lMap Φ ψ) + (LK.Derivation.cast (lMap Φ dp) (by simp)) + (LK.Derivation.cast (lMap Φ dq) (by simp))).cast + (by simp) + | all (Γ := Γ) (φ := φ) d => + (all (Γ := Γ.map (.lMap Φ)) (φ := .lMap Φ φ) + (LK.Derivation.cast (lMap Φ d) + (by simp [← Semiformula.lMap_free, shifts_image]))).cast + (by simp) + | exs (Γ := Γ) (φ := φ) (t := t) d => + (exs (Γ := Γ.map (.lMap Φ)) (φ := .lMap Φ φ) (t := Semiterm.lMap Φ t) + (.cast (lMap Φ d) (by simp [Semiformula.lMap_subst]))).cast + (by simp) + +end Hom + +private lemma map_subst_eq_free (φ : Semiproposition L 1) (h : ¬φ.HasFreeVariable m) : + (@Rew.rewriteMap L ℕ ℕ 0 (fun x ↦ if x = m then 0 else x + 1)) ▹ (φ/[&m] : Proposition L) = + Rewriting.free φ := + by + simp only [← TransitiveRewriting.comp_app] + exact + Semiformula.rew_eq_of_funEqOn (by simp [Rew.comp_app]) + (fun x hx => by simp [Rew.comp_app, ne_of_mem_of_not_mem hx h]) + +private lemma map_rewriteMap_eq_shifts (Δ : LK.Sequent L) (h : ∀ φ ∈ Δ, ¬φ.HasFreeVariable m) : + Δ.map (fun φ ↦ @Rew.rewriteMap L ℕ ℕ 0 (fun x ↦ if x = m then 0 else x + 1) ▹ φ) = Δ⁺ := + by + apply Multiset.map_congr rfl + intro φ hp + exact Semiformula.rew_eq_of_funEqOn₀ (by intro x hx; simp [ne_of_mem_of_not_mem hx (h φ hp)]) + +/-- The generalize By New Var construction in `FFL.FirstOrder.LK.Derivation`. -/ +def generalizeByNewVar {φ : Semiproposition L 1} (hp : ¬φ.HasFreeVariable m) + (hΔ : ∀ ψ ∈ Δ, ¬ψ.HasFreeVariable m) (d : ⊢ᴸᴷ¹ Δ + ⦃φ/[&m]⦄) : ⊢ᴸᴷ¹ Δ + ⦃∀¹ φ⦄ := + by + have : ⊢ᴸᴷ¹ Δ⁺ + ⦃φ.free⦄ := + LK.Derivation.cast (LK.Derivation.map d (fun x ↦ if x = m then 0 else x + 1)) + (by simp [map_subst_eq_free φ hp, map_rewriteMap_eq_shifts Δ hΔ]) + exact all this + +end Derivation +end LK + +/-! +## Classical proof system -/ + +/-- Data and laws for LK in `FFL.FirstOrder`. -/ +inductive LK (L : Language) + | symbol + +/-- The «term𝐋𝐊¹» construction in `FFL.FirstOrder`. -/ +notation "𝐋𝐊¹" => LK.symbol + +/-- The «term𝐋𝐊¹[ ]» construction in `FFL.FirstOrder`. -/ +notation "𝐋𝐊¹[" L "]" => LK.symbol (L := L) + +/-- The Proof construction in `FFL.FirstOrder.LK`. -/ +abbrev LK.Proof (φ : Proposition L) := + ⊢ᴸᴷ¹ ⦃φ⦄ + +instance : Entailment (LK L) (Proposition L) where Prf _ := LK.Proof + +namespace LK +namespace Proof + +lemma def_eq (φ : Proposition L) : (𝐋𝐊¹ ⊢! φ) = (⊢ᴸᴷ¹ ⦃φ⦄) := + rfl + +lemma provable_def (φ : Proposition L) : 𝐋𝐊¹ ⊢ φ ↔ Nonempty (⊢ᴸᴷ¹ ⦃φ⦄) := by rfl + +lemma unprovable_def (φ : Proposition L) : 𝐋𝐊¹ ⊬ φ ↔ IsEmpty (⊢ᴸᴷ¹ ⦃φ⦄) := by + unfold Entailment.Unprovable; simp [provable_def] + +instance : OneSidedLK.PrincipalEntailment (LK.Derivation (L := L)) (𝐋𝐊¹ : LK L) where + equiv := Equiv.refl _ + +instance classical : Entailment.Cl (𝐋𝐊¹ : LK L) := + inferInstance + +lemma all (φ : Semiproposition L 1) : 𝐋𝐊¹ ⊢ φ.free → 𝐋𝐊¹ ⊢ ∀¹ φ := fun h ↦ + ⟨LK.Derivation.all (Γ := 0) (φ := φ) (h.get.cast (by simp [Rewriting.shifts]))⟩ + +lemma allClosure_fixitr {φ : Proposition L} (dp : 𝐋𝐊¹ ⊢ φ) : + (m : ℕ) → 𝐋𝐊¹ ⊢ ∀¹* Rew.fixitr 0 m ▹ φ + | 0 => by simpa + | m + 1 => by + simp only [LawfulSyntacticRewriting.allClosure_fixitr] + apply all; simpa using allClosure_fixitr dp m + +lemma univCl' {φ : Proposition L} (b : 𝐋𝐊¹ ⊢ φ) : 𝐋𝐊¹ ⊢ φ.univCl' := + allClosure_fixitr b φ.fvSup + +lemma lMap (Φ : L₁ →ᵥ L₂) {φ : Proposition L₁} : 𝐋𝐊¹ ⊢ φ → 𝐋𝐊¹ ⊢ φ.lMap Φ := + by + rintro ⟨d⟩ + have : ⊢ᴸᴷ¹ ⦃φ⦄ := d + have : ⊢ᴸᴷ¹ ⦃.lMap Φ φ⦄ := this.lMap Φ + exact ⟨this⟩ + +end Proof +end LK + +/-- Data and laws for Proof in `FFL.FirstOrder.Theory`. -/ +structure Theory.Proof (T : Theory L) (σ : Sentence L) where + /-- The axioms construction in `FFL.FirstOrder.Theory.Proof`. -/ + axioms : Multiset (Sentence L) + axioms_mem : ∀ ψ ∈ axioms, ψ ∈ T + /-- The derivation construction in `FFL.FirstOrder.Theory.Proof`. -/ + derivation : OneSidedLK.Pullback LK.Derivation Rewriting.emb (⦃σ⦄ + ∼axioms) + +namespace Theory +namespace Proof + +instance : Entailment (Theory L) (Sentence L) where Prf := Theory.Proof + +variable {T : Theory L} + +/-- A singleton derivation gives a theory proof without using any axioms. -/ +def ofDerivation {T : Theory L} {φ : Sentence L} + (d : OneSidedLK.Pullback LK.Derivation Rewriting.emb ⦃φ⦄) : T ⊢! φ := + ⟨0, by simp, OneSidedLK.cast d⟩ + +instance : Entailment.Compact (Theory L) + where + core b := {φ | φ ∈ b.axioms} + corePrf b := ⟨b.axioms, by simp, b.derivation⟩ + core_finite b := by simp [AdjunctiveSet.Finite, AdjunctiveSet.set] + core_subset b := by simpa [AdjunctiveSet.subset_iff] using b.axioms_mem + +instance (T : Theory L) : Entailment.ModusPonens T where + mdpProof {φ ψ} bi + bp := by + refine ⟨bi.axioms + bp.axioms, ?_, ?_⟩ + · exact Multiset.forall_mem_add.mpr ⟨bi.axioms_mem, bp.axioms_mem⟩ + · exact + OneSidedLK.cast + (OneSidedLK.modusPonens (Γ := ∼bi.axioms) (Δ := ∼bp.axioms) (φ := φ) (ψ := ψ) + (OneSidedLK.cast bi.derivation) (OneSidedLK.cast bp.derivation)) + (by simp; abel) + +instance : Entailment.Cl T := + OneSidedLK.AxiomDerivation.cl T ofDerivation + +instance : Entailment.Axiomatized (Theory L) + where + prfAxm {𝓢 φ} + h := + ⟨⦃φ⦄, by simpa using h, + by + change ⊢ᴸᴷ¹ (⦃φ⦄ + ∼(⦃φ⦄ : Multiset (Sentence L))).map Rewriting.emb + simpa [Multiset.tilde_def] using LK.Derivation.eta (Rewriting.emb φ)⟩ + weakening {𝓢 𝓣 φ} h b := ⟨b.axioms, fun ψ hψ ↦ h (b.axioms_mem ψ hψ), b.derivation⟩ + +/-- Replaces each used axiom by its proof in another theory. +This is a routine consequence of implication introduction and modus ponens. -/ +noncomputable def cut {U : Theory L} (h : T ⊢!* U) (b : U ⊢! φ) : T ⊢! φ := + go b.axioms.toList (by simpa using b.axioms_mem) (OneSidedLK.cast b.derivation (by simp)) +where/-- The go construction in `FFL.FirstOrder.Theory.Proof.cut`. -/ + go (l : List (Sentence L)) (hl : ∀ ψ ∈ l, ψ ∈ U) {φ : Sentence L} + (d : OneSidedLK.Pullback LK.Derivation Rewriting.emb (⦃φ⦄ + ∼(l : Multiset _))) : T ⊢! φ := + (match l with + | [] => ofDerivation (OneSidedLK.cast d (by simp)) + | ψ :: l => + Entailment.mdpProof + (go l (by simp_all) (φ := ψ ⇒ₗ φ) + (OneSidedLK.cast + (OneSidedLK.or (Γ := ∼(l : Multiset _)) (φ := ∼ψ) (ψ := φ) + (OneSidedLK.cast d + (by + change ⦃φ⦄ + ∼(ψ ::ₘ (l : Multiset _)) = _ + simp [Multiset.tilde_def, ← Multiset.add_atom_eq_cons, add_comm, + add_left_comm]))) + (by simp [Semiformula.imp_eq]; abel))) + (h (hl ψ (by simp)))) + +noncomputable instance : Entailment.StrongCut (Theory L) (Theory L) := + ⟨cut⟩ + +instance : Entailment.DeductiveExplosion (Theory L) where + dexp b + φ := by + refine ⟨b.axioms, b.axioms_mem, ?_⟩ + have db : ⊢ᴸᴷ¹ (∼LK.Sequent.embed b.axioms) + ⦃Rewriting.emb (⊥ : Sentence L)⦄ := + LK.Derivation.cast b.derivation + (by simp [LK.Sequent.embed, add_comm, Multiset.map_tilde_comm]) + exact + ((OneSidedLK.removeBot db).weakening (φ := Rewriting.emb φ)).cast + (by simp [LK.Sequent.embed, add_comm, Multiset.map_tilde_comm]) + +lemma weakerThan_of_le {T U : Theory L} (h : T ⊆ U) : T ≼ U := + Entailment.Axiomatized.weakerThanOfSubset h + +instance (T U : Theory L) : T ≼ T ∪ U := + weakerThan_of_le (by simp) + +instance (T U : Theory L) : U ≼ T ∪ U := + weakerThan_of_le (by simp) + +lemma provable_iff : + T ⊢ φ ↔ + ∃ Γ : Multiset (Sentence L), + (∀ ψ ∈ Γ, ψ ∈ T) ∧ Nonempty (⊢ᴸᴷ¹ ⦃(φ : Proposition L)⦄ + ∼LK.Sequent.embed Γ) := + by + constructor + · rintro ⟨b⟩ + exact + ⟨b.axioms, b.axioms_mem, + ⟨by + simpa [OneSidedLK.Pullback, LK.Sequent.embed, Multiset.map_tilde_comm] using + b.derivation⟩⟩ + · rintro ⟨Γ, hΓ, ⟨d⟩⟩ + exact + ⟨Γ, hΓ, by simpa [OneSidedLK.Pullback, LK.Sequent.embed, Multiset.map_tilde_comm] using d⟩ + +lemma inconsistent_iff : + Entailment.Inconsistent T ↔ + ∃ Γ : Multiset (Sentence L), (∀ ψ ∈ Γ, ψ ∈ T) ∧ Nonempty (⊢ᴸᴷ¹ ∼LK.Sequent.embed Γ) := + by + rw [Entailment.inconsistent_iff_provable_bot, provable_iff] + constructor + · rintro ⟨Γ, hΓ, ⟨d⟩⟩ + have db : ⊢ᴸᴷ¹ (∼LK.Sequent.embed Γ) + ⦃Rewriting.emb (⊥ : Sentence L)⦄ := + d.cast (by rw [add_comm]) + exact ⟨Γ, hΓ, ⟨OneSidedLK.removeBot db⟩⟩ + · rintro ⟨Γ, hΓ, ⟨d⟩⟩ + exact + ⟨Γ, hΓ, ⟨(d.weakening (φ := Rewriting.emb (⊥ : Sentence L))).cast (by simp [add_comm])⟩⟩ + +open Entailment LK.Derivation + +@[simp] +lemma empty_provable_iff_eprovable : (∅ : Theory L) ⊢ φ ↔ 𝐋𝐊¹ ⊢ (φ : Proposition L) := + by + constructor + · rintro ⟨b⟩ + have hzero : b.axioms = 0 := + Multiset.eq_zero_of_forall_notMem fun ψ hψ ↦ by simpa using b.axioms_mem ψ hψ + have d := b.derivation + rw [hzero] at d + change ⊢ᴸᴷ¹ ⦃Rewriting.emb φ⦄ at d + exact ⟨d⟩ + · rintro ⟨d⟩ + change ⊢ᴸᴷ¹ ⦃Rewriting.emb φ⦄ at d + exact ⟨ofDerivation d⟩ + +open Entailment LK.Derivation + +lemma of_LK_provable {T : Theory L} {φ : Sentence L} : 𝐋𝐊¹ ⊢ (φ : Proposition L) → T ⊢ φ := + by + rintro ⟨d⟩ + change ⊢ᴸᴷ¹ ⦃Rewriting.emb φ⦄ at d + exact ⟨ofDerivation d⟩ + +lemma specialize {T : Theory L} (φ : Semisentence L 1) (t : ClosedTerm L) : + T ⊢ ∀¹ φ ⇒ₗ Semiformula.subst φ ![t] := + by + apply of_LK_provable + refine ⟨?_⟩ + let φt : Sentence L := Semiformula.subst φ ![t] + have d : ⊢ᴸᴷ¹ ⦃(φt : Proposition L)⦄ + ⦃(∼(φ : Semiproposition L 1))/[Rew.emb t]⦄ := by + simpa [φt, Semiformula.coe_subst_eq_subst_coe₁] using LK.Derivation.eta (φt : Proposition L) + exact + (LK.Derivation.or (Γ := 0) (φ := ∃¹ ∼(φ : Semiproposition L 1)) (ψ := (φt : Proposition L)) + (LK.Derivation.cast + (LK.Derivation.exs (Γ := ⦃(φt : Proposition L)⦄) (φ := ∼(φ : Semiproposition L 1)) + (t := Rew.emb t) d) + (by simp [add_comm]))).cast + (by simp [Semiformula.imp_eq, φt]) + +open _root_.Classical Classical in +noncomputable instance : Entailment.Deduction (Theory L) + where + ofInsert {φ ψ T} + b := by + let Γ := b.axioms.filter (· ≠ φ) + refine ⟨Γ, ?_, ?_⟩ + · intro χ hχ + rcases Multiset.mem_filter.mp hχ with ⟨hχ, hnχ⟩ + simpa [hnχ] using b.axioms_mem χ hχ + · exact + LK.Derivation.cast + (LK.Derivation.or (Γ := (∼Γ).map Rewriting.emb) (φ := Rewriting.emb (∼φ)) (ψ := + Rewriting.emb ψ) + (contra (L := L) b.derivation (Γ := + (∼Γ).map Rewriting.emb + ⦃Rewriting.emb (∼φ), Rewriting.emb ψ⦄) + (default : + Multiset.Traversal + ((∼Γ).map Rewriting.emb + ⦃Rewriting.emb (∼φ), Rewriting.emb ψ⦄)) + (by + simpa [OneSidedLK.Pullback, Multiset.tilde_def, Γ, add_assoc] using + Multiset.map_subset_map (f := Rewriting.emb) <| + Multiset.add_map_subset_map_filter_add_atom (s := b.axioms) (t := ⦃ψ⦄) (f := + fun χ ↦ ∼χ) (a := φ)))) + (by simp [Multiset.tilde_def, Semiformula.imp_eq, add_comm]) + inv {φ ψ T} + b := + Entailment.mdpProof (Entailment.Axiomatized.weakening (by simp) b) + (Entailment.Axiomatized.byAxm (by simp)) + +end Proof +end Theory + +/-! +### Theory -/ + +/-- The theory construction in `FFL.FirstOrder.Theory`. -/ +def Theory.theory (T : Theory L) : Theory L := + {σ | T ⊢ σ} + +@[simp] +lemma Theory.mem_theory {T : Theory L} : σ ∈ T.theory ↔ T ⊢ σ := by simp [Theory.theory] + +end FirstOrder + +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/Completeness.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/Completeness.lean new file mode 100644 index 000000000..cb262b6d0 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/Completeness.lean @@ -0,0 +1,20 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.LK.Completeness.CanonicalModel +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.LK.Completeness.CountableSublanguage +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.LK.Completeness.CounterModel + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/Completeness/CanonicalModel.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/Completeness/CanonicalModel.lean new file mode 100644 index 000000000..4bc7fed47 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/Completeness/CanonicalModel.lean @@ -0,0 +1,261 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.LK.Hauptsatz +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.LK.Soundness +public import LeanPool.PointwiseComposition.Foundation.Logic.ForcingRelation + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# Canonical model for classical first-order logic + +Main reference: Jeremy Avigad, Algebraic proofs of cut elimination [Avi01] + -/ + +@[expose] public section + +namespace FFL +namespace FirstOrder +namespace LK +namespace Derivation +namespace Canonical + +open scoped FFL.FirstOrder.Derivation.Canonical + +variable {L : Language} + + + +variable (L) + +/-- The Consistent Sequent construction in `FFL.FirstOrder.LK.Derivation.Canonical`. -/ +def ConsistentSequent := + { Γ : LK.Sequent L // IsEmpty (⊢ᴸᴷ¹ ∼Γ) } + +variable {L} + +local notation "ℙ" => ConsistentSequent L + +namespace ConsistentSequent + +instance : Preorder ℙ where + le q p := Nonempty (q.val ≼ p.val) + le_refl p := ⟨StrongerThan.refl p.val⟩ + le_trans _ _ _ hqp hrq := ⟨hqp.some.trans hrq.some⟩ + +/-- The nil construction in `FFL.FirstOrder.LK.Derivation.Canonical.ConsistentSequent`. -/ +def nil : ℙ := + ⟨0, by simp⟩ + +instance : OrderTop ℙ where + top := nil + le_top := by + classical + rintro ⟨Γ, hΓ⟩ + exact ⟨StrongerThan.ofSubset default default <| by simp [nil]⟩ + +/-- The of Unprovable construction in +`FFL.FirstOrder.LK.Derivation.Canonical.ConsistentSequent`. -/ +def ofUnprovable (φ : Proposition L) (h : 𝐋𝐊¹ ⊬ ∼φ) : ℙ := + ⟨⦃φ⦄, by classical simpa [LK.Proof.unprovable_def] using h⟩ + +end ConsistentSequent + +/-- The Is Forced construction in `FFL.FirstOrder.LK.Derivation.Canonical`. -/ +abbrev IsForced (p : ℙ) (φ : Propositionᵢ L) := + Nonempty (Forces p.val φ) + +instance : ForcingRelation ℙ (Propositionᵢ L) := + ⟨IsForced⟩ + +instance : WeakForcingRelation ℙ (Proposition L) := + ⟨fun p φ ↦ p ⊩ φᴺ⟩ + +namespace IsForced + +@[simp] +lemma rel {p : ℙ} {k} {R : L.Rel k} {v} : p ⊩ .rel R v ↔ Nonempty (⊢ᴸᴷ¹ ∼p.val + ⦃.rel R v⦄) := + by + classical + constructor + · rintro ⟨b⟩ + have ⟨d, hd⟩ := b.relEquiv + exact ⟨d⟩ + · rintro ⟨d⟩ + let ⟨b, hb⟩ := hauptsatz d + exact ⟨Forces.relEquiv.symm ⟨b, hb⟩⟩ + +@[simp] +lemma fal {p : ℙ} : p ⊩ ∀¹ φ ↔ ∀ t, p ⊩ φ/[t] := + by + constructor + · rintro ⟨b⟩ t + exact ⟨b.allEquiv t⟩ + · rintro h + exact ⟨Forces.allEquiv.symm fun t ↦ (h t).some⟩ + +lemma and {p : ℙ} {φ ψ : Propositionᵢ L} : p ⊩ φ ⋏ ψ ↔ p ⊩ φ ∧ p ⊩ ψ := + by + constructor + · rintro ⟨b⟩ + have ⟨bφ, bψ⟩ := b.andEquiv + exact ⟨⟨bφ⟩, ⟨bψ⟩⟩ + · rintro ⟨⟨bφ⟩, ⟨bψ⟩⟩ + exact ⟨Forces.andEquiv.symm ⟨bφ, bψ⟩⟩ + +lemma or {p : ℙ} {φ ψ : Propositionᵢ L} : p ⊩ φ ⋎ ψ ↔ p ⊩ φ ∨ p ⊩ ψ := + by + constructor + · rintro ⟨b⟩ + have b' := b.orEquiv + exact b'.rec (fun bφ ↦ .inl ⟨bφ⟩) (fun bψ ↦ .inr ⟨bψ⟩) + · rintro (⟨⟨hφ⟩⟩ | ⟨⟨hψ⟩⟩) + · exact ⟨Forces.orEquiv.symm <| .inl hφ⟩ + · exact ⟨Forces.orEquiv.symm <| .inr hψ⟩ + +lemma not_falsum (p : ℙ) : ¬p ⊩ ⊥ := by + rintro ⟨b⟩ + have ⟨d, hd⟩ := b.falsumEquiv + exact p.prop.false d + +lemma imply {p : ℙ} {φ ψ : Propositionᵢ L} : p ⊩ φ ⇒ₗ ψ ↔ (∀ q ≤ p, q ⊩ φ → q ⊩ ψ) := + by + classical + constructor + · rintro ⟨b⟩ q ⟨sqp⟩ ⟨bφ⟩ + exact ⟨b.implyEquiv _ sqp bφ⟩ + · rintro h + refine ⟨Forces.implyEquiv.symm fun q sqp hφ ↦ ?_⟩ + by_cases hq : IsEmpty (⊢ᴸᴷ¹ ∼q) + · exact (h ⟨q, hq⟩ ⟨sqp⟩ ⟨hφ⟩).some + · have : Nonempty (⊢ᴸᴷ¹ ∼q) := by simpa using hq + have d : ⊢ᴸᴷ¹ ∼q := this.some + let ⟨b, hb⟩ := hauptsatz d + exact (Forces.falsumEquiv.symm ⟨b, hb⟩).explosion ψ + +lemma not {p : ℙ} {φ : Propositionᵢ L} : p ⊩ ∼φ ↔ (∀ q ≤ p, ¬q ⊩ φ) := by + simp [Semiformulaᵢ.neg_def, imply, not_falsum] + +@[simp] +lemma exs {p : ℙ} : p ⊩ ∃¹ φ ↔ ∃ t, p ⊩ φ/[t] := + by + constructor + · rintro ⟨b⟩ + have ⟨t, f⟩ := b.exsEquiv + exact ⟨t, ⟨f⟩⟩ + · rintro ⟨t, h⟩ + exact ⟨Forces.exsEquiv.symm ⟨t, h.some⟩⟩ + +lemma monotone {p q : ℙ} (hqp : q ≤ p) {φ : Propositionᵢ L} (hφ : p ⊩ φ) : q ⊩ φ := + ⟨Forces.monotone hqp.some hφ.some⟩ + +instance : ForcingRelation.IntKripke ℙ (· ≥ ·) + where + verum _ := ⟨Forces.implyEquiv.symm fun _ _ d ↦ d⟩ + falsum p := not_falsum p + and _ := and + or _ := or + imply _ := imply + not _ := not + monotone hφ _ hpq := hφ.monotone hpq + +lemma sound [L.DecidableEq] {φ : Propositionᵢ L} : 𝐋𝐉¹ ⊢ φ → ℙ ∀⊩ φ := by + rintro ⟨d⟩ p; + exact ⟨Forces.ljSound d p.val default⟩ + +end IsForced + +namespace IsWeaklyForced + +open IsForced + +lemma iff_isForced {φ : Proposition L} {p : ℙ} : p ⊩ᶜ φ ↔ p ⊩ φᴺ := by rfl + +lemma dn_neg_iff {φ : Proposition L} {p : ℙ} : p ⊩ᶜ ∼φ ↔ p ⊩ ∼φᴺ := + by + let : L.DecidableEq := ⟨fun _ ↦ Classical.decEq _, fun _ ↦ Classical.decEq _⟩ + have e := LJ.Derivation.negDoubleNegation φ + constructor + · rintro ⟨h⟩ + exact ⟨Forces.sound e.2 p.val default fun ψ hψ ↦ h.cast (Multiset.mem_atom_iff.mp hψ).symm⟩ + · rintro ⟨h⟩ + exact ⟨Forces.sound e.1 p.val default fun ψ hψ ↦ h.cast (Multiset.mem_atom_iff.mp hψ).symm⟩ + +@[simp] +lemma verum (p : ℙ) : p ⊩ᶜ ⊤ := by simp [iff_isForced, IsForced.not] + +@[simp] +lemma falsum (p : ℙ) : ¬p ⊩ᶜ ⊥ := by simp [iff_isForced] + +@[simp] +lemma not {φ : Proposition L} {p : ℙ} : p ⊩ᶜ ∼φ ↔ ∀ q ≤ p, ¬q ⊩ᶜ φ := by + simp [IsForced.not, dn_neg_iff, ]; rfl + +@[simp] +lemma and {φ ψ : Proposition L} {p : ℙ} : p ⊩ᶜ φ ⋏ ψ ↔ p ⊩ᶜ φ ∧ p ⊩ᶜ ψ := by + simp [iff_isForced, ] + +@[simp] +lemma or {φ ψ : Proposition L} {p : ℙ} : p ⊩ᶜ φ ⋎ ψ ↔ ∀ q ≤ p, ∃ r ≤ q, r ⊩ᶜ φ ∨ r ⊩ᶜ ψ := by + simp [iff_isForced, IsForced.not, ]; grind + +@[simp] +lemma all {φ : Semiproposition L 1} {p : ℙ} : p ⊩ᶜ ∀¹ φ ↔ ∀ t, p ⊩ᶜ φ/[t] := by + simp [iff_isForced, Semiformula.subst_doubleNegation] + +@[simp] +lemma exs {φ : Semiproposition L 1} {p : ℙ} : p ⊩ᶜ ∃¹ φ ↔ ∀ q ≤ p, ∃ r ≤ q, ∃ t, r ⊩ᶜ φ/[t] := + by simp [iff_isForced, IsForced.not, Semiformula.subst_doubleNegation]; grind + +lemma monotone {φ : Proposition L} {p q : ℙ} (h : q ≤ p) : p ⊩ᶜ φ → q ⊩ᶜ φ := + IsForced.monotone h + +lemma gnericity {φ : Proposition L} {p : ℙ} : p ⊩ᶜ φ ↔ ∀ q ≤ p, ∃ r ≤ q, r ⊩ᶜ φ := + calc + p ⊩ᶜ φ ↔ p ⊩ᶜ ∼∼φ := by simp + _ ↔ ∀ q ≤ p, ∃ r ≤ q, r ⊩ᶜ φ := by rw [not]; simp [not] + +lemma complete {φ : Proposition L} : ℙ ∀⊩ᶜ φ ↔ 𝐋𝐊¹ ⊢ φ := + by + classical + constructor + · intro h + by_contra b + let p : ℙ := ⟨⦃∼φ⦄, ⟨fun bφ ↦ b ⟨by simpa using! bφ⟩⟩⟩ + have hp : p ⊩ φᴺ := h p + have hn : p ⊩ᶜ ∼φ := ⟨Forces.refl (∼φ)⟩ + have : ∀ q ≤ p, ¬q ⊩ φᴺ := by simpa [not] using! hn + have : ¬p ⊩ φᴺ := this p (by simp) + contradiction + · intro b + let : L.DecidableEq := ⟨fun _ ↦ Classical.decEq _, fun _ ↦ Classical.decEq _⟩ + exact IsForced.sound <| Provable.gödel_gentzen b + +protected lemma refl (φ : Proposition L) (h : 𝐋𝐊¹ ⊬ ∼φ) : + ConsistentSequent.ofUnprovable φ h ⊩ᶜ φ := by + classical + exact ⟨Forces.refl φ⟩ + +end IsWeaklyForced + +end Canonical + +end Derivation +end LK +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/Completeness/CountableSublanguage.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/Completeness/CountableSublanguage.lean new file mode 100644 index 000000000..7c1085517 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/Completeness/CountableSublanguage.lean @@ -0,0 +1,323 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Tarski.Basic +public import Mathlib.Logic.Equiv.List + +/-! Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section +namespace FFL + +namespace FirstOrder + +variable {L : Language.{u}} + +/-! ### Finite sublanguage -/ + +namespace Language + +/-- The sublanguage construction in `FFL.FirstOrder.Language`. -/ +def sublanguage (L : Language) (pFunc : ∀ k, L.Func k → Prop) (pRel : ∀ k, L.Rel k → Prop) : + Language where + Func k := Subtype (pFunc k) + Rel k := Subtype (pRel k) + +section sublanguage + +variable (L) + +variable {pf : (k : ℕ) → L.Func k → Prop} {pr : (k : ℕ) → L.Rel k → Prop} + +/-- The unsub construction in `FFL.FirstOrder.Language`. -/ +def unsub : sublanguage L pf pr →ᵥ L + where + func := Subtype.val + rel := Subtype.val + +@[simp] +lemma unsub_onFunc : L.unsub.func φ = φ.val := + rfl + +@[simp] +lemma unsub_onRel : L.unsub.rel φ = φ.val := + rfl + +end sublanguage + +end Language + +namespace Semiterm + +open Language +variable [∀ k, DecidableEq (L.Func k)] + +/-- The symbols construction in `FFL.FirstOrder.Semiterm`. -/ +def symbols : Semiterm L ξ n → Finset (Σ k, L.Func k) + | #_ => ∅ + | &_ => ∅ + | func f v => insert ⟨_, f⟩ (Finset.biUnion Finset.univ (fun i ↦ symbols (v i))) + +@[simp] +lemma lang_func {k} (f : L.Func k) (v : Fin k → Semiterm L ξ n) : ⟨k, f⟩ ∈ (func f v).symbols := + by simp [symbols] + +lemma lang_func_ss {k} (f : L.Func k) (v : Fin k → Semiterm L ξ n) (i) : + (v i).symbols ⊆ (func f v).symbols := by intros x; simp [symbols]; grind + +/-- The to Sublanguage construction in `FFL.FirstOrder.Semiterm`. -/ +def toSublanguage (pf : ∀ k, L.Func k → Prop) (pr : ∀ k, L.Rel k → Prop) : + ∀ t : Semiterm L ξ n, + (∀ k f, ⟨k, f⟩ ∈ t.symbols → pf k f) → Semiterm (sublanguage L pf pr) ξ n + | #x, _ => #x + | &x, _ => &x + | func (arity := k) f v, h => + func ⟨f, h k f (by simp)⟩ + (fun i ↦ toSublanguage pf pr (v i) (fun k' f' h' => h k' f' (lang_func_ss f v i h'))) + +@[simp] +lemma lMap_toSublanguage (pf : ∀ k, L.Func k → Prop) (pr : ∀ k, L.Rel k → Prop) + (t : Semiterm L ξ n) (h : ∀ k f, ⟨k, f⟩ ∈ t.symbols → pf k f) : + (t.toSublanguage pf pr h).lMap L.unsub = t := by + induction t with + | bvar x => rfl + | fvar x => rfl + | func f v ih => exact congrArg (Semiterm.func f) (funext fun i ↦ ih i _) + +end Semiterm + +namespace Semiformula + +variable [L.DecidableEq] + +/-- The function Symbols construction in `FFL.FirstOrder.Semiformula`. -/ +noncomputable def functionSymbols {n} : Semiformula L ξ n → Finset (Σ k, L.Func k) + | rel _ v => Finset.biUnion Finset.univ fun i ↦ (v i).symbols + | nrel _ v => Finset.biUnion Finset.univ fun i ↦ (v i).symbols + | ⊤ => ∅ + | ⊥ => ∅ + | φ ⋏ ψ => functionSymbols φ ∪ functionSymbols ψ + | φ ⋎ ψ => functionSymbols φ ∪ functionSymbols ψ + | ∀¹ φ => functionSymbols φ + | ∃¹ φ => functionSymbols φ + +/-- The relation Symbols construction in `FFL.FirstOrder.Semiformula`. -/ +noncomputable def relationSymbols {n} : Semiformula L ξ n → Finset (Σ k, L.Rel k) + | rel r _ => {⟨_, r⟩} + | nrel r _ => {⟨_, r⟩} + | ⊤ => ∅ + | ⊥ => ∅ + | φ ⋏ ψ => relationSymbols φ ∪ relationSymbols ψ + | φ ⋎ ψ => relationSymbols φ ∪ relationSymbols ψ + | ∀¹ φ => relationSymbols φ + | ∃¹ φ => relationSymbols φ + +lemma functionSymbols_rel_ss {k} (r : L.Rel k) (v : Fin k → Semiterm L ξ n) (i) : + (v i).symbols ⊆ (rel r v).functionSymbols := + by + intros x + simp only [functionSymbols, Finset.mem_biUnion, Finset.mem_univ, true_and] + intros h; exact ⟨i, h⟩ + +/-- The to Sublanguage construction in `FFL.FirstOrder.Semiformula`. -/ +def toSublanguage (pf : ∀ k, L.Func k → Prop) (pr : ∀ k, L.Rel k → Prop) {n} : + (φ : Semiformula L ξ n) → + (∀ k f, ⟨k, f⟩ ∈ φ.functionSymbols → pf k f) → + (∀ k r, ⟨k, r⟩ ∈ φ.relationSymbols → pr k r) → Semiformula (L.sublanguage pf pr) ξ n + | rel r v, hf, hr => + rel ⟨r, hr _ r (by simp [relationSymbols])⟩ fun i ↦ + (v i).toSublanguage pf pr fun k f h ↦ hf k f (functionSymbols_rel_ss r v i h) + | nrel r v, hf, hr => + nrel ⟨r, hr _ r (by simp [relationSymbols])⟩ fun i ↦ + (v i).toSublanguage pf pr fun k f h ↦ hf k f (functionSymbols_rel_ss r v i h) + | ⊤, _, _ => ⊤ + | ⊥, _, _ => ⊥ + | φ ⋏ ψ, hf, hr => + toSublanguage pf pr φ (fun k f h ↦ hf k f (Finset.mem_union_left _ h)) + (fun k r h ↦ hr k r (Finset.mem_union_left _ h)) ⋏ + toSublanguage pf pr ψ (fun k f h ↦ hf k f (Finset.mem_union_right _ h)) + (fun k r h ↦ hr k r (Finset.mem_union_right _ h)) + | φ ⋎ ψ, hf, hr => + toSublanguage pf pr φ (fun k f h ↦ hf k f (Finset.mem_union_left _ h)) + (fun k r h ↦ hr k r (Finset.mem_union_left _ h)) ⋎ + toSublanguage pf pr ψ (fun k f h ↦ hf k f (Finset.mem_union_right _ h)) + (fun k r h ↦ hr k r (Finset.mem_union_right _ h)) + | ∀¹ φ, hf, hr => ∀¹ toSublanguage pf pr φ hf hr + | ∃¹ φ, hf, hr => ∃¹ toSublanguage pf pr φ hf hr + +@[simp] +lemma lMap_toSublanguage (pf : ∀ k, L.Func k → Prop) (pr : ∀ k, L.Rel k → Prop) {n} + (φ : Semiformula L ξ n) (hf : ∀ k f, ⟨k, f⟩ ∈ φ.functionSymbols → pf k f) + (hr : ∀ k r, ⟨k, r⟩ ∈ φ.relationSymbols → pr k r) : + lMap L.unsub (φ.toSublanguage pf pr hf hr) = φ := by + induction φ using rec' with + | hverum => rfl + | hfalsum => rfl + | hrel r v => + exact congrArg (Semiformula.rel r) (funext fun i ↦ Semiterm.lMap_toSublanguage _ _ _ _) + | hnrel r v => + exact congrArg (Semiformula.nrel r) (funext fun i ↦ Semiterm.lMap_toSublanguage _ _ _ _) + | hand φ ψ ihφ ihψ => simp [*, toSublanguage] + | hor φ ψ ihφ ihψ => simp [*, toSublanguage] + | hall φ ih => exact congrArg Semiformula.all (ih hf hr) + | hexs φ ih => exact congrArg Semiformula.exs (ih hf hr) + +variable (φ : Semiformula L ξ n) + +/-- +A language consists of the function and relation symbols appearing in a given finite set of +formulas. -/ +abbrev sublanguage : Language := + Language.sublanguage L (fun k f ↦ ⟨k, f⟩ ∈ φ.functionSymbols) + (fun k r ↦ ⟨k, r⟩ ∈ φ.relationSymbols) + +noncomputable instance (k) : Fintype (φ.sublanguage.Func k) := + Fintype.subtype + (φ.functionSymbols.preimage (⟨k, ·⟩) (Set.injOn_of_injective sigma_mk_injective)) (by simp) + +noncomputable instance (k) : Fintype (φ.sublanguage.Rel k) := + Fintype.subtype + (φ.relationSymbols.preimage (⟨k, ·⟩) (Set.injOn_of_injective sigma_mk_injective)) (by simp) + +noncomputable instance : φ.sublanguage.Encodable + where + func _ := Fintype.toEncodable _ + rel _ := Fintype.toEncodable _ + +/-- The to Sub Language Self construction in `FFL.FirstOrder.Semiformula`. -/ +def toSubLanguageSelf (φ : Semiformula L ξ n) : Semiformula φ.sublanguage ξ n := + φ.toSublanguage _ _ (fun _ _ ↦ id) (fun _ _ ↦ id) + +@[simp] +lemma lMap_toSubLanguage {φ : Semiformula L ξ n} : φ.toSubLanguageSelf.lMap L.unsub = φ := + lMap_toSublanguage _ _ _ _ _ + +end Semiformula + +/-! ### Tarski.Structure induced by an injective language homomorphism -/ + +namespace Language + +/-- Data and laws for Injective in `FFL.FirstOrder.Language.Hom`. -/ +class Hom.Injective (Φ : L₁ →ᵥ L₂) : Prop where + func : ∀ k, Function.Injective (Φ.func : L₁.Func k → L₂.Func k) + rel : ∀ k, Function.Injective (Φ.rel : L₁.Rel k → L₂.Rel k) + +instance unsub_injective (pf : ∀ k, L.Func k → Prop) (pr : ∀ k, L.Rel k → Prop) : + (L.unsub : L.sublanguage pf pr →ᵥ L).Injective := + ⟨fun _ ↦ Subtype.val_injective, fun _ ↦ Subtype.val_injective⟩ + +end Language + +namespace Tarski +namespace Structure + +/-- The extend Structure construction in `FFL.FirstOrder.Tarski.Structure`. -/ +noncomputable abbrev extendStructure (Φ : L₁ →ᵥ L₂) {M : Type*} [Nonempty M] + (s : Tarski.Structure L₁ M) : Tarski.Structure L₂ M + where + func {k} f₂ v := Classical.epsilon (∃ f₁ : L₁.Func k, Φ.func f₁ = f₂ ∧ · = s.func f₁ v) + rel {k} r₂ v := ∃ r₁ : L₁.Rel k, Φ.rel r₁ = r₂ ∧ s.rel r₁ v + +namespace extendStructure + +variable {M : Type*} [Nonempty M] (s₁ : Tarski.Structure L₁ M) + +protected lemma func (Φ : L₁ →ᵥ L₂) [hΦ : Φ.Injective] (f₁ : L₁.Func k) (v : Fin k → M) : + (s₁.extendStructure Φ).func (Φ.func f₁) v = s₁.func f₁ v := + by + have : ∃ y, ∃ f₁' : L₁.Func k, Φ.func f₁' = Φ.func f₁ ∧ y = s₁.func f₁' v := + ⟨s₁.func f₁ v, f₁, rfl, rfl⟩ + rcases Classical.epsilon_spec this with ⟨f', f'eq, h⟩ + rcases hΦ.func k f'eq with rfl; exact h + +protected lemma rel + (Φ : L₁ →ᵥ L₂) [hΦ : Φ.Injective] + (r₁ : L₁.Rel k) (v : Fin k → M) : + (s₁.extendStructure Φ).rel (Φ.rel r₁) v ↔ s₁.rel r₁ v := by + refine ⟨by intros h; rcases h with ⟨r₁', bv, h⟩; rcases hΦ.rel k bv with rfl; exact h, by + intros h; refine ⟨r₁, rfl, h⟩⟩ + +lemma val_lMap (Φ : L₁ →ᵥ L₂) [Φ.Injective] (bv : Fin n → M) (fv : ξ → M) + (t : Semiterm L₁ ξ n) : (t.lMap Φ).val (s := s₁.extendStructure Φ) bv fv = t.val bv fv := + by + induction t + case func k f v ih => + simpa [ih, Function.comp_def] using extendStructure.func s₁ Φ f fun i ↦ (v i).val bv fv + case _ => simp [*] + case _ => simp [*] + +open Semiformula + +lemma eval_lMap (Φ : L₁ →ᵥ L₂) [Φ.Injective] (bv : Fin n → M) (fv : ξ → M) + {φ : Semiformula L₁ ξ n} : + (lMap Φ φ).Eval (s := s₁.extendStructure Φ) bv fv ↔ φ.Eval bv fv := + by + induction φ using Semiformula.rec' + case hrel k r + v => + simp only [Semiformula.lMap_rel, eval_rel, val_lMap s₁ Φ bv fv, Function.comp_def] + exact extendStructure.rel s₁ Φ r (fun i ↦ (v i).val bv fv) + case hnrel k r + v => + simp only [lMap_nrel, eval_nrel, val_lMap s₁ Φ bv fv, Function.comp_def] + simpa [not_iff_not] using extendStructure.rel s₁ Φ r (fun i ↦ (v i).val bv fv) + case _ => simp [*] + case _ => simp [*] + case _ => simp [*] + case _ => simp [*] + case _ => simp [*] + case _ => simp [*] + +lemma models_lMap (Φ : L₁ →ᵥ L₂) [Φ.Injective] (φ : Sentence L₁) : + (s₁.extendStructure Φ).toStruc ⊧ φ.lMap Φ ↔ s₁.toStruc ⊧ φ := by + simp [Semantics.Models, eval_lMap s₁ Φ] + +end extendStructure + +end Structure +end Tarski + +section lMap + +variable {L₁ : Language.{u}} {L₂ : Language.{u}} + +lemma lMap_models_lMap_iff (Φ : L₁ →ᵥ L₂) [Φ.Injective] {T : Theory L₁} {φ : Sentence L₁} : + T.lMap Φ ⊨ φ.lMap Φ ↔ T ⊨ φ := by + constructor + · intro h s₁ hs₁ + refine (Tarski.Structure.extendStructure.models_lMap s₁.struc Φ φ).mp <| h ?_ + suffices ∀ σ ∈ T, (Tarski.Structure.extendStructure Φ s₁.struc).toStruc ⊧ σ.lMap Φ by + simpa [Semantics.modelsSet_iff, Theory.lMap, Semantics.models] + intro σ hσ + exact (Tarski.Structure.extendStructure.models_lMap s₁.struc Φ σ).mpr (hs₁.models _ hσ) + · exact lMap_models_lMap + +lemma satisfiable_lMap (Φ : L₁ →ᵥ L₂) [Φ.Injective] {T : Theory L₁} (s : Satisfiable T) : + Satisfiable (T.lMap Φ) := by + rcases s with ⟨⟨M, i, s⟩, hM⟩ + exact + ⟨⟨M, i, s.extendStructure Φ⟩, + by + have : ∀ φ ∈ T, (Tarski.Structure.extendStructure Φ s).toStruc ⊧ φ.lMap Φ := fun φ hφ ↦ + (Tarski.Structure.extendStructure.models_lMap s Φ φ).mpr (hM.models _ hφ) + simpa [Theory.lMap] using this⟩ + +end lMap + +end FirstOrder + +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/Completeness/CounterModel.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/Completeness/CounterModel.lean new file mode 100644 index 000000000..27107df25 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/Completeness/CounterModel.lean @@ -0,0 +1,379 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Syntax.Classical.Coding +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.LK.Completeness.CanonicalModel +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.LK.Completeness.CountableSublanguage +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Tarski.Ultraproduct +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.LK.Eq +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Tarski.Model +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Order.Dense +public import Mathlib.Logic.Equiv.List +public import Mathlib.Logic.Encodable.Basic + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# Completeness theorem -/ + +@[expose] public section + +/-! +### Generic filters -/ + +namespace FFL +namespace FirstOrder +namespace LK +namespace Derivation +namespace Canonical + +open scoped FFL.FirstOrder.Derivation.Canonical + +open _root_.Order Order + +variable {K : Language} + +local notation "ℙ" => ConsistentSequent K + + + +/-- The decidable Points construction in `FFL.FirstOrder.LK.Derivation.Canonical`. -/ +def decidablePoints (φ : Proposition K) : DenseSet ℙ + where + set := {p | p ⊩ᶜ φ ∨ p ⊩ᶜ ∼φ} + is_dense := by + classical + intro p + have : p ⊩ᶜ φ ⋎ ∼φ := IsWeaklyForced.complete.mpr Entailment.lem p + have : ∀ q ≤ p, ∃ r ≤ q, r ⊩ᶜ φ ∨ r ⊩ᶜ ∼φ := by simpa using this + simpa using this p (by rfl) + +@[simp] +lemma mem_decidablePoints_def (p : ℙ) (φ : Proposition K) : + p ∈ decidablePoints φ ↔ p ⊩ᶜ φ ∨ p ⊩ᶜ ∼φ := by rfl + +/-- The henkin Points construction in `FFL.FirstOrder.LK.Derivation.Canonical`. -/ +def henkinPoints (φ : Semiproposition K 1) : DenseSet ℙ + where + set := {p | ∀ q ≤ p, q ⊩ᶜ ∃¹ φ → ∃ t, q ⊩ᶜ φ/[t]} + is_dense := by + classical + intro p + suffices ∃ q ≤ p, ∀ q_1 ≤ q, (∀ q ≤ q_1, ∃ r ≤ q, ∃ t, r ⊩ᶜ φ/[t]) → ∃ t, q_1 ⊩ᶜ φ/[t] by + simpa only [IsWeaklyForced.exs, Set.mem_ofPred_eq] + have : p ⊩ᶜ (∃¹ φ) ⋎ (∀¹ ∼φ) := IsWeaklyForced.complete.mpr Entailment.lem p + have : + ∀ q ≤ p, ∃ r ≤ q, (∀ q ≤ r, ∃ r ≤ q, ∃ t, r ⊩ᶜ φ/[t]) ∨ (∀ t, ∀ q ≤ r, ¬q ⊩ᶜ φ/[t]) := by + simpa using this + rcases this p (by rfl) with ⟨q, hqp, (h | h)⟩ + · rcases h q (by rfl) with ⟨r, hrq, t, ht⟩ + refine ⟨r, le_trans hrq hqp, fun s hsr _ ↦ ⟨t, IsWeaklyForced.monotone hsr ht⟩⟩ + · refine ⟨q, hqp, ?_⟩ + intro r hrq hA + rcases hA r (by rfl) with ⟨s, hsr, u, hu⟩ + have : ¬s ⊩ᶜ φ/[u] := h u s (le_trans hsr hrq) + contradiction + +@[simp] +lemma mem_henkinPoints_def (p : ℙ) (φ : Semiproposition K 1) : + p ∈ henkinPoints φ ↔ ∀ q ≤ p, q ⊩ᶜ ∃¹ φ → ∃ t, q ⊩ᶜ φ/[t] := by rfl + +/-- The dense Sets construction in `FFL.FirstOrder.LK.Derivation.Canonical`. -/ +abbrev denseSets : Set (DenseSet ℙ) := + Set.range decidablePoints ∪ Set.range henkinPoints + +variable [K.Encodable] + +theorem exists_genericFilter (p : ℙ) : + ∃ G : PFilter ℙ, (PointwiseComposition.Order.PFilter.IsGeneric G) denseSets ∧ p ∈ G := + PFilter.exists_genericFilter_of_countable denseSets + (Set.countable_union.mpr + ⟨Set.countable_range decidablePoints, Set.countable_range henkinPoints⟩) + p + +/-- The generic Filter construction in `FFL.FirstOrder.LK.Derivation.Canonical`. -/ +noncomputable def genericFilter (p : ℙ) : PFilter ℙ := + Classical.choose (exists_genericFilter p) + +instance genericFilter_isGeneric (p : ℙ) : + (PointwiseComposition.Order.PFilter.IsGeneric (genericFilter p)) denseSets := + Classical.choose_spec (exists_genericFilter p) |>.1 + +@[simp] +lemma mem_genericFilter (p : ℙ) : p ∈ genericFilter p := + Classical.choose_spec (exists_genericFilter p) |>.2 + +/-- The Generic Forces construction in `FFL.FirstOrder.LK.Derivation.Canonical`. -/ +def GenericForces (p : ℙ) (φ : Proposition K) : Prop := + ∃ q ∈ genericFilter p, q ⊩ᶜ φ + +local infix:60 " ⊫ " => GenericForces + +lemma GenericForces.em (p : ℙ) (φ : Proposition K) : p ⊫ φ ∨ p ⊫ ∼φ := + by + have : ∃ q ∈ genericFilter p, q ∈ decidablePoints φ := + (genericFilter_isGeneric p).isGeneric (decidablePoints φ) (by simp) + rcases this with ⟨q, hqG, hq⟩ + have : q ⊩ᶜ φ ∨ q ⊩ᶜ ∼φ := by simpa using hq + rcases this with (em | em) + · left; refine ⟨q, hqG, em⟩ + · right; refine ⟨q, hqG, em⟩ + +@[simp] +lemma GenericForces.neg {p : ℙ} {φ : Proposition K} : p ⊫ ∼φ ↔ ¬p ⊫ φ := + by + suffices p ⊫ ∼φ → p ⊫ φ → False by + have := GenericForces.em p φ + grind + rintro ⟨q₀, hG₀, h₀⟩ + rintro ⟨q₁, hG₁, h₁⟩ + rcases (genericFilter p).directed _ hG₀ _ hG₁ with ⟨r, hG, hr₀, hr₁⟩ + have : r ⊩ᶜ φ := h₁.monotone hr₁ + have : ¬r ⊩ᶜ φ := IsWeaklyForced.not.mp h₀ r (by assumption) + contradiction + +@[simp] +lemma GenericForces.verum (p : ℙ) : p ⊫ ⊤ := + ⟨p, by simp⟩ + +@[simp] +lemma GenericForces.not_falsum (p : ℙ) : ¬p ⊫ ⊥ := by rintro ⟨q, hq⟩; simp_all + +@[simp] +lemma GenericForces.nrel {p : ℙ} : p ⊫ .nrel R v ↔ ¬p ⊫ .rel R v := + calc + p ⊫ .nrel R v ↔ p ⊫ ∼(.rel R v) := by simp + _ ↔ ¬p ⊫ .rel R v := by rw [GenericForces.neg] + +lemma GenericForces.henkin {p : ℙ} {φ : Semiproposition K 1} : p ⊫ ∃¹ φ → ∃ t, p ⊫ φ/[t] := + by + have : ∃ q ∈ genericFilter p, ∀ r ≤ q, r ⊩ᶜ ∃¹ φ → ∃ t, r ⊩ᶜ φ/[t] := + (genericFilter_isGeneric p).isGeneric (henkinPoints φ) (by simp) + rcases this with ⟨q, hqG, H⟩ + rintro ⟨r, hrG, hr⟩ + rcases (genericFilter p).directed _ hqG _ hrG with ⟨z, hGz, hzq, hzr⟩ + have : ∃ t, z ⊩ᶜ φ/[t] := H z hzq (hr.monotone hzr) + rcases this with ⟨t, hzt⟩ + refine ⟨t, ⟨z, hGz, hzt⟩⟩ + +@[simp] +lemma GenericForces.exs {p : ℙ} : p ⊫ ∃¹ φ ↔ ∃ t, p ⊫ φ/[t] := + by + constructor + · exact GenericForces.henkin + · rintro ⟨t, q, hqG, h⟩ + refine ⟨q, hqG, ?_⟩ + suffices ∀ r ≤ q, ∃ s ≤ r, ∃ t, s ⊩ᶜ φ/[t] by simpa + intro r hrq + refine ⟨r, by simp, t, h.monotone hrq⟩ + +@[simp] +lemma GenericForces.fal {p : ℙ} : p ⊫ ∀¹ φ ↔ ∀ t, p ⊫ φ/[t] := + calc + p ⊫ ∀¹ φ ↔ p ⊫ ∼(∃¹ ∼φ) := by simp + _ ↔ ¬p ⊫ ∃¹ ∼φ := by rw [GenericForces.neg] + _ ↔ ∀ t, p ⊫ φ/[t] := by simp [GenericForces.exs] + +@[simp] +lemma GenericForces.and {p : ℙ} {φ ψ : Proposition K} : p ⊫ φ ⋏ ψ ↔ p ⊫ φ ∧ p ⊫ ψ := + by + constructor + · rintro ⟨q, hqG, hq⟩ + have : q ⊩ᶜ φ ∧ q ⊩ᶜ ψ := by simpa using hq + rcases this with ⟨hφ, hψ⟩ + exact ⟨⟨q, hqG, hφ⟩, ⟨q, hqG, hψ⟩⟩ + · rintro ⟨⟨q₁, hG₁, h₁⟩, ⟨q₂, hG₂, h₂⟩⟩ + rcases (genericFilter p).directed _ hG₁ _ hG₂ with ⟨r, hGr, hr₁, hr₂⟩ + refine ⟨r, hGr, ?_⟩ + have : r ⊩ᶜ φ := h₁.monotone hr₁ + have : r ⊩ᶜ ψ := h₂.monotone hr₂ + simp_all + +@[simp] +lemma GenericForces.or {p : ℙ} {φ ψ : Proposition K} : p ⊫ φ ⋎ ψ ↔ p ⊫ φ ∨ p ⊫ ψ := + calc + p ⊫ φ ⋎ ψ ↔ p ⊫ ∼(∼φ ⋏ ∼ψ) := by simp + _ ↔ ¬p ⊫ ∼φ ⋏ ∼ψ := by rw [GenericForces.neg] + _ ↔ p ⊫ φ ∨ p ⊫ ψ := by simp; tauto + +/-- The term Model Of construction in `FFL.FirstOrder.LK.Derivation.Canonical`. -/ +abbrev termModelOf (p : ℙ) : Tarski.Structure K (Term K ℕ) + where + func _ f v := .func f v + rel _ R v := p ⊫ .rel R v + +@[simp] +lemma termModel_func_def (f : K.Func k) (v : Fin k → (Term K ℕ)) : + (termModelOf p).func f v = Semiterm.func f v := + rfl + +@[simp] +lemma termModel_rel_def (R : K.Rel k) (v) : (termModelOf p).rel R v ↔ p ⊫ .rel R v := by rfl + +@[simp] +lemma termModel_val_eq (t : Semiterm K ξ n) (fv : ξ → (Term K ℕ)) (bv : Fin n → (Term K ℕ)) : + t.val (s := termModelOf p) bv fv = Rew.bind bv fv t := by + induction t <;> simp [*, Function.comp_def] + +lemma forcing_lemma (φ : Semiformula K ξ n) {fv : ξ → (Term K ℕ)} {bv : Fin n → (Term K ℕ)} : + φ.Eval (s := termModelOf p) bv fv ↔ p ⊫ Rew.bind bv fv ▹ φ := + have e (t : Term K ℕ) (φ : Semiformula K ξ (n + 1)) : + ((Rew.bind bv fv).q ▹ φ)/[t] = Rew.bind (t :> bv) fv ▹ φ := + by + unfold Rewriting.subst; rw [← TransitiveRewriting.comp_app] + congr; ext x + · cases x using Fin.cases <;> simp [Rew.comp_app] + · simp [Rew.comp_app] + match φ with + | .rel R v | .nrel R v => by simp [Function.comp_def] + | ⊤ | ⊥ => by simp + | φ ⋏ ψ | φ ⋎ ψ => by simp [forcing_lemma φ, forcing_lemma ψ] + | ∀¹ φ | ∃¹ φ => by simp [e, forcing_lemma φ] + +lemma refl (φ : Proposition K) (h : 𝐋𝐊¹ ⊬ ∼φ) : + φ.Evalf (s := termModelOf (ConsistentSequent.ofUnprovable φ h)) (&·) := + (forcing_lemma φ).mpr + ⟨ConsistentSequent.ofUnprovable φ h, by simp, by simpa using IsWeaklyForced.refl φ h⟩ + +end Canonical +end Derivation +end LK + +/-! +### Completeness theorem -/ + +namespace LK + +open LK.Derivation.Canonical + +variable {L : Language} + +lemma satisfiable_of_irrefutable (σ : Sentence L) (h : 𝐋𝐊¹ ⊬ ∼(σ : Proposition L)) : + Satisfiable { σ } := by + classical + let K := σ.sublanguage + let π : Sentence K := σ.toSubLanguageSelf + have : 𝐋𝐊¹ ⊬ ∼(π : Proposition K) := fun h ↦ + by + have : 𝐋𝐊¹ ⊢ ∼(σ : Proposition L) := by + simpa [Semiformula.lMap_emb, π] using LK.Proof.lMap L.unsub h + contradiction + have : Satisfiable { π } := + ⟨⟨_, inferInstance, termModelOf (ConsistentSequent.ofUnprovable π (by simpa using this))⟩, + by simpa [models_iff] using refl (π : Proposition K) (by simpa using this)⟩ + simpa [Theory.lMap, π] using satisfiable_lMap L.unsub this + +end LK + +namespace Theory + +open FFL.Entailment + +variable {L : Language.{u}} {T : Theory L} + +/-- Completeness theorem (I) -/ +theorem small_satisfiable_of_consistent : Consistent T → Satisfiable T := fun consistent ↦ + compact.mpr fun u hu ↦ by + let σ := ⋀u.toList + have : T ⊢ σ := Conj₂_intro fun φ hφ ↦ by_axm <| hu (by simpa using hφ) + have : 𝐋𝐊¹ ⊬ ∼(σ : Proposition L) := fun h ↦ + have : T ⊢ ∼σ := Theory.Proof.of_LK_provable (φ := ∼σ) (by simpa using h) + have : T ⊢ ⊥ := neg_mdp this (by assumption) + consistent_iff_unprovable_bot.mp consistent this + have : Satisfiable { σ } := LK.satisfiable_of_irrefutable σ this + simpa [σ] using this + +lemma satisfiable_iff_consistent : + Semantics.Satisfiable (Tarski.Struc.{max u w} L) T ↔ Consistent T := + by + constructor + · exact consistent_of_satisfiable + · intro h + let ⟨M, _, _, h⟩ := satisfiable_iff.mp (small_satisfiable_of_consistent h) + exact + satisfiable_iff.mpr + ⟨ULift.{w} M, inferInstance, inferInstance, + ((uLift_elementaryEquiv L M).modelsTheory).mpr h⟩ + +/-- Completeness theorem (II) -/ +theorem Proof.complete : T ⊨[Tarski.Struc.{max u w} L] φ → T ⊢ φ := + by + contrapose! + intro h + have : Consistent (insert (∼φ) T) := unprovable_iff_consistent_adjoin.mp h + have : Semantics.Satisfiable (Tarski.Struc.{max u w} L) (insert (∼φ) T) := + satisfiable_iff_consistent.mpr this + rcases this with ⟨⟨M, i, s⟩, hM⟩ + have : ¬M↓[L] ⊧ φ ∧ M↓[L] ⊧* T := by simpa using hM + simpa [consequence_iff] using ⟨M, i.some, s, this.2, this.1⟩ + +theorem Proof.small_complete : T ⊨ φ → T ⊢ φ := + Proof.complete + +theorem Proof.complete_iff : T ⊨ φ ↔ T ⊢ φ := + ⟨fun h ↦ Proof.complete h, Proof.sound⟩ + +instance Proof.isComplete (T : Theory L) : + Complete T (Semantics.models (Tarski.Struc.{max u w} L) T) := + ⟨Proof.complete⟩ + +lemma satisfiable_iff_satisfiable : + Semantics.Satisfiable (Tarski.Struc.{max u w} L) T ↔ Satisfiable T := by + simp [satisfiable_iff_consistent.{u, w}, satisfiable_iff_consistent.{u, u}] + +lemma consequence_iff_consequence : T ⊨[Tarski.Struc.{max u w} L] φ ↔ T ⊨ φ := by + simp [consequence_iff_unsatisfiable, satisfiable_iff_satisfiable.{u, w}] + +end Theory + +/-! +### Corollaries -/ + +namespace ModelsTheory + +variable {L : Language.{u}} (M : Type w) [Nonempty M] [Tarski.Structure L M] (T U V : Theory L) + +lemma of_provably_subtheory [le : T ≼ U] (h : M↓[L] ⊧* U) : M↓[L] ⊧* T := + ⟨fun φ hφ ↦ + have : U ⊢ φ := le.pbl (Entailment.by_axm hφ) + consequence_iff'.{u, w}.mp (Theory.Proof.sound this) M⟩ + +lemma of_add_left [M↓[L] ⊧* T ∪ U] : M↓[L] ⊧* T := + models_of_ss inferInstance (show T ⊆ T ∪ U from by simp) + +lemma of_add_right [M↓[L] ⊧* T ∪ U] : M↓[L] ⊧* U := + models_of_ss inferInstance (show U ⊆ T ∪ U from by simp) + +end ModelsTheory + +variable {L : Language.{u}} [L.Eq] {T : Theory L} [𝐄𝐐 L ≼ T] + +lemma Theory.Proof.complete_on_eq_models (φ : Sentence L) + (H : + ∀ (M : Type (max u v)) [Nonempty M] [Tarski.Structure L M] [Tarski.Structure.Eq L M] + [M↓[L] ⊧* T], M↓[L] ⊧ φ) : + T ⊢ φ := + have : T ⊨ φ := + Theory.consequence_iff_consequence.mp <| + consequence_iff_eq.mpr fun M _ _ _ hT ↦ + letI : (Tarski.Structure.Model L M)↓[L] ⊧* T := + Tarski.Structure.ElementaryEquiv.modelsTheory.mp hT + Tarski.Structure.ElementaryEquiv.models.mpr (H (Tarski.Structure.Model L M)) + Theory.Proof.complete this + +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/CutFree.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/CutFree.lean new file mode 100644 index 000000000..a36449374 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/CutFree.lean @@ -0,0 +1,183 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.LK.Basic + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +/-! +# Canonical model of classical first-order logic + +Main reference: Jeremy Avigad, Algebraic proofs of cut elimination [Avi01] + -/ + +namespace FFL +namespace FirstOrder + +variable {L : Language.{u}} + +namespace LK +namespace Derivation + +/-- Data and laws for Is Cut Free in `FFL.FirstOrder.LK.Derivation`. -/ +inductive IsCutFree : {Γ : LK.Sequent L} → ⊢ᴸᴷ¹ Γ → Prop + | identity (r : L.Rel k) (v) : IsCutFree (identity r v) + | verum : IsCutFree verum + | or {d : ⊢ᴸᴷ¹ Γ + ⦃φ, ψ⦄} : IsCutFree d → IsCutFree d.or + | + and {dφ : ⊢ᴸᴷ¹ Γ + ⦃φ⦄} {dψ : ⊢ᴸᴷ¹ Γ + ⦃ψ⦄} : + IsCutFree dφ → IsCutFree dψ → IsCutFree (dφ.and dψ) + | all {d : ⊢ᴸᴷ¹ Γ⁺ + ⦃Rewriting.free φ⦄} : IsCutFree d → IsCutFree d.all + | exs (t) {d : ⊢ᴸᴷ¹ Γ + ⦃φ/[t]⦄} : IsCutFree d → IsCutFree d.exs + | contraction {d : ⊢ᴸᴷ¹ Γ + ⦃φ, φ⦄} : IsCutFree d → IsCutFree d.contraction + | weakening {d : ⊢ᴸᴷ¹ Γ} : IsCutFree d → IsCutFree (d.weakening (φ := φ)) + +attribute [simp] IsCutFree.identity IsCutFree.verum + +variable {Γ Δ : LK.Sequent L} + +@[simp] +lemma isCutFree_or_iff {d : ⊢ᴸᴷ¹ Γ + ⦃φ, ψ⦄} : IsCutFree d.or ↔ IsCutFree d := + by + constructor + · intro h + refine + h.rec (motive := fun {_} d _ ↦ + match d with + | .or d => IsCutFree d + | _ => True) + ?_ ?_ ?_ ?_ ?_ ?_ ?_ ?_ + all_goals simp_all + · exact .or + +@[simp] +lemma isCutFree_and_iff {dφ : ⊢ᴸᴷ¹ Γ + ⦃φ⦄} {dψ : ⊢ᴸᴷ¹ Γ + ⦃ψ⦄} : + IsCutFree (dφ.and dψ) ↔ IsCutFree dφ ∧ IsCutFree dψ := + by + constructor + · rintro h + refine + h.rec (motive := fun {_} d _ ↦ + match d with + | .and dφ dψ => IsCutFree dφ ∧ IsCutFree dψ + | _ => True) + ?_ ?_ ?_ ?_ ?_ ?_ ?_ ?_ + all_goals simp_all + · rintro ⟨hφ, hψ⟩ + exact hφ.and hψ + +@[simp] +lemma isCutFree_all_iff {d : ⊢ᴸᴷ¹ Γ⁺ + ⦃Rewriting.free φ⦄} : IsCutFree d.all ↔ IsCutFree d := + by + constructor + · intro h + refine + h.rec (motive := fun {_} d _ ↦ + match d with + | .all d => IsCutFree d + | _ => True) + ?_ ?_ ?_ ?_ ?_ ?_ ?_ ?_ + all_goals simp_all + · exact .all + +@[simp] +lemma isCutFree_exs_iff {d : ⊢ᴸᴷ¹ Γ + ⦃φ/[t]⦄} : IsCutFree d.exs ↔ IsCutFree d := + by + constructor + · intro h + refine + h.rec (motive := fun {_} d _ ↦ + match d with + | .exs d => IsCutFree d + | _ => True) + ?_ ?_ ?_ ?_ ?_ ?_ ?_ ?_ + all_goals simp_all + · exact .exs t + +@[simp] +lemma isCutFree_contraction_iff {d : ⊢ᴸᴷ¹ Γ + ⦃φ, φ⦄} : IsCutFree d.contraction ↔ IsCutFree d := + by + constructor + · intro h + refine + h.rec (motive := fun {_} d _ ↦ + match d with + | .contraction d => IsCutFree d + | _ => True) + ?_ ?_ ?_ ?_ ?_ ?_ ?_ ?_ + all_goals simp_all + · exact .contraction + +@[simp] +lemma isCutFree_weakening_iff {d : ⊢ᴸᴷ¹ Γ} : IsCutFree (d.weakening (φ := φ)) ↔ IsCutFree d := + by + constructor; + · intro h; + refine + h.rec (motive := fun {_} d _ ↦ + match d with + | .weakening d => IsCutFree d + | _ => True) + ?_ ?_ ?_ ?_ ?_ ?_ ?_ ?_; + all_goals simp_all; + · exact .weakening; + +@[simp] +lemma IsCutFree.cast {d : ⊢ᴸᴷ¹ Γ} {e : Γ = Δ} : IsCutFree (.cast d e) ↔ IsCutFree d := by + rcases e; rfl + +@[simp] +lemma IsCutFree.not_cut (dp : ⊢ᴸᴷ¹ Γ + ⦃φ⦄) (dn : ⊢ᴸᴷ¹ Δ + ⦃∼φ⦄) : ¬IsCutFree (dp.cut dn) := + by + intro h + refine + h.rec (motive := fun {_} d _ ↦ + match d with + | .cut _ _ => False + | _ => True) + ?_ ?_ ?_ ?_ ?_ ?_ ?_ ?_ + all_goals simp + +@[simp] +lemma isCutFree_rewrite_iff_isCutFree {f : ℕ → SyntacticTerm L} {d : ⊢ᴸᴷ¹ Γ} : + IsCutFree (rewrite f d) ↔ IsCutFree d := + by + induction d generalizing f <;> simp only [rewrite, IsCutFree.identity, iff_true, IsCutFree.cast, + IsCutFree.not_cut, isCutFree_contraction_iff, *, isCutFree_weakening_iff, IsCutFree.verum, + isCutFree_or_iff, isCutFree_and_iff, Nat.reduceAdd, isCutFree_all_iff, Nat.succ_eq_add_one, + isCutFree_exs_iff] + · exact .identity _ _ + · exact .verum + +@[simp] +lemma isCutFree_map_iff_isCutFree {f : ℕ → ℕ} {d : ⊢ᴸᴷ¹ Γ} : + IsCutFree (LK.Derivation.map d f) ↔ IsCutFree d := + isCutFree_rewrite_iff_isCutFree + +@[simp] +lemma IsCutFree.generalizeByNewVar_isCutFree {φ : Semiproposition L 1} + (hp : ¬φ.HasFreeVariable m) (hΔ : ∀ ψ ∈ Δ, ¬ψ.HasFreeVariable m) (d : ⊢ᴸᴷ¹ Δ + ⦃φ/[&m]⦄) : + IsCutFree (generalizeByNewVar hp hΔ d) ↔ IsCutFree d := by simp [generalizeByNewVar] + +end Derivation +end LK + +end FirstOrder + +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/Eq.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/Eq.lean new file mode 100644 index 000000000..8d70f61a7 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/Eq.lean @@ -0,0 +1,121 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Tarski.Eq +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.LK.Soundness + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace FFL + +namespace FirstOrder + +variable {L : Language} {ξ : Type*} [Semiformula.Operator.Eq L] + +lemma consequence_iff_eq {T : Theory L} [𝐄𝐐 L ≼ T] {σ : Sentence L} : + T ⊨[Tarski.Struc.{v, u} L] σ ↔ + (∀ (M : Type v) [Nonempty M] [Tarski.Structure L M] [Tarski.Structure.Eq L M], + M↓[L] ⊧* T → M↓[L] ⊧ σ) := + consequence_iff_eq_of_models_eq (fun _ _ _ hM ↦ models_of_subtheory hM) + +lemma consequence_iff_eq' {T : Theory L} [𝐄𝐐 L ≼ T] {σ : Sentence L} : + T ⊨[Tarski.Struc.{v, u} L] σ ↔ + (∀ (M : Type v) [Nonempty M] [Tarski.Structure L M] [Tarski.Structure.Eq L M] + [M↓[L] ⊧* T], M↓[L] ⊧ σ) := + by rw [consequence_iff_eq] + +lemma satisfiable_iff_eq {T : Theory L} [𝐄𝐐 L ≼ T] : + Semantics.Satisfiable (Tarski.Struc.{v, u} L) T ↔ + (∃ (M : Type v) (_ : Nonempty M) (_ : Tarski.Structure L M) (_ : Tarski.Structure.Eq L M), + M↓[L] ⊧* T) := + satisfiable_iff_eq_of_models_eq (fun _ _ _ hM ↦ models_of_subtheory hM) + +instance {T : Theory L} [𝐄𝐐 L ≼ T] (sat : Semantics.Satisfiable (Tarski.Struc.{v, u} L) T) : + (ModelOfSat sat)↓[L] ⊧* 𝐄𝐐 L := + models_of_subtheory (ModelOfSat.models sat) + +/-- The Model Of Sat Eq construction in `FFL.FirstOrder`. -/ +def ModelOfSatEq {T : Theory L} [𝐄𝐐 L ≼ T] + (sat : Semantics.Satisfiable (Tarski.Struc.{v, u} L) T) : Type _ := + Tarski.Structure.Eq.QuotEq L (ModelOfSat sat) + +namespace ModelOfSatEq + +variable {T : Theory L} [𝐄𝐐 L ≼ T] (sat : Semantics.Satisfiable (Tarski.Struc.{v, u} L) T) + +noncomputable instance : Nonempty (ModelOfSatEq sat) := + Tarski.Structure.Eq.QuotEq.inhabited + +noncomputable instance struc : Tarski.Structure L (ModelOfSatEq sat) := + Tarski.Structure.Eq.QuotEq.struc + +noncomputable instance : Tarski.Structure.Eq L (ModelOfSatEq sat) := + Tarski.Structure.Eq.QuotEq.structureEq + +lemma models : (ModelOfSatEq sat)↓[L] ⊧* T := + have e : ModelOfSatEq sat ≡ₑ[L] ModelOfSat sat := + Tarski.Structure.Eq.QuotEq.elementaryEquiv L (ModelOfSat sat) + e.modelsTheory.mpr (ModelOfSat.models _) + +instance mod : (ModelOfSatEq sat)↓[L] ⊧* T := + models sat + +open Semiterm Semiformula + +noncomputable instance [Operator.Zero L] : Zero (ModelOfSatEq sat) := + ⟨(@Operator.Zero.zero L _).val ![]⟩ + +instance strucZero [Operator.Zero L] : Tarski.Structure.Zero L (ModelOfSatEq sat) := + ⟨rfl⟩ + +noncomputable instance [Operator.One L] : One (ModelOfSatEq sat) := + ⟨(@Operator.One.one L _).val ![]⟩ + +instance [Operator.One L] : Tarski.Structure.One L (ModelOfSatEq sat) := + ⟨rfl⟩ + +noncomputable instance [Operator.Add L] : Add (ModelOfSatEq sat) := + ⟨fun x y ↦ (@Operator.Add.add L _).val ![x, y]⟩ + +instance [Operator.Add L] : Tarski.Structure.Add L (ModelOfSatEq sat) := + ⟨fun _ _ ↦ rfl⟩ + +noncomputable instance [Operator.Mul L] : Mul (ModelOfSatEq sat) := + ⟨fun x y ↦ (@Operator.Mul.mul L _).val ![x, y]⟩ + +instance [Operator.Mul L] : Tarski.Structure.Mul L (ModelOfSatEq sat) := + ⟨fun _ _ ↦ rfl⟩ + +instance [Operator.LT L] : LT (ModelOfSatEq sat) := + ⟨fun x y ↦ (@Operator.LT.lt L _).val ![x, y]⟩ + +instance [Operator.LT L] : Tarski.Structure.LT L (ModelOfSatEq sat) := + ⟨fun _ _ ↦ iff_of_eq rfl⟩ + +instance [Operator.Mem L] : Membership (ModelOfSatEq sat) (ModelOfSatEq sat) := + ⟨fun x y ↦ (@Operator.Mem.mem L _).val ![y, x]⟩ + +instance [Operator.Mem L] : Tarski.Structure.Mem L (ModelOfSatEq sat) := + ⟨fun _ _ ↦ iff_of_eq rfl⟩ + +end ModelOfSatEq + +end FirstOrder + +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/Hauptsatz.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/Hauptsatz.lean new file mode 100644 index 000000000..13bb4667f --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/Hauptsatz.lean @@ -0,0 +1,561 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.LJ.GoedelGentzen +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.LK.CutFree + +/-! Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# Hauptsatz of classical first-order logic + +Main reference: Jeremy Avigad, Algebraic proofs of cut elimination [Avi01] + -/ + +@[expose] public section + +namespace FFL +namespace FirstOrder +namespace LK +namespace Derivation + +variable {L : Language} + +/-- Data and laws for Positive in `FFL.FirstOrder.LK.Derivation`. -/ +inductive Positive (Ξ : LK.Sequent L) : LK.Sequent L → Type _ + | refl : Positive Ξ Ξ + | weakening : Positive Ξ Γ → Positive Ξ (Γ + ⦃φ⦄) + | contraction : Positive Ξ (Γ + ⦃φ, φ⦄) → Positive Ξ (Γ + ⦃φ⦄) + | or : Positive Ξ (Γ + ⦃φ, ψ⦄) → Positive Ξ (Γ + ⦃φ ⋎ ψ⦄) + | exs : Positive Ξ (Γ + ⦃φ/[t]⦄) → Positive Ξ (Γ + ⦃∃¹ φ⦄) + +/-- The «term ⟶⁺ » construction in `FFL.FirstOrder.LK.Derivation`. -/ +infix:45 " ⟶⁺ " => Positive + +namespace Positive + +variable {Ξ Γ Δ : LK.Sequent L} + +/-- The traversal construction in `FFL.FirstOrder.LK.Derivation.Positive`. -/ +def traversal [L.DecidableEq] {Γ} : + Ξ ⟶⁺ Γ → + (PointwiseComposition.Multiset.Traversal Ξ) → (PointwiseComposition.Multiset.Traversal Γ) + | refl, tΞ => tΞ + | weakening (φ := φ) d, tΞ => (d.traversal tΞ).succ φ + | contraction (φ := φ) d, tΞ => ((d.traversal tΞ).cast (by abel)).remove (a := φ) + | or (φ := φ) (ψ := ψ) d, tΞ => + (((d.traversal tΞ).cast (by abel)).remove (a := ψ)).remove (a := φ) |>.succ (φ ⋎ ψ) + | exs (φ := φ) d, tΞ => (d.traversal tΞ).remove.succ (∃¹ φ) + +instance : Structural (Positive Ξ) + where + weakening d := d.weakening + contraction d := d.contraction + +/-- The of Subset construction in `FFL.FirstOrder.LK.Derivation.Positive`. -/ +def ofSubset [L.DecidableEq] (tΞ : (PointwiseComposition.Multiset.Traversal Ξ)) + (tΓ : (PointwiseComposition.Multiset.Traversal Γ)) (ss : Ξ ⊆ Γ) : Ξ ⟶⁺ Γ := + Structural.ofSubset (F := Proposition L) (𝔇 := Positive Ξ) (Γ := Ξ) (Δ := Γ) tΞ tΓ .refl ss + +/-- The trans construction in `FFL.FirstOrder.LK.Derivation.Positive`. -/ +def trans {Ξ Γ Δ : LK.Sequent L} : Ξ ⟶⁺ Γ → Γ ⟶⁺ Δ → Ξ ⟶⁺ Δ + | b, or d => or (b.trans d) + | b, exs d => exs (b.trans d) + | b, weakening d => weakening (b.trans d) + | b, contraction d => contraction (b.trans d) + | b, refl => b + +/-- The cast construction in `FFL.FirstOrder.LK.Derivation.Positive`. -/ +def cast {Ξ Γ Ξ' Γ' : LK.Sequent L} (d : Ξ ⟶⁺ Γ) (hΞ : Ξ = Ξ' := by abel) + (hΓ : Γ = Γ' := by abel) : Ξ' ⟶⁺ Γ' := + hΞ ▸ hΓ ▸ d + +/-- The add Left construction in `FFL.FirstOrder.LK.Derivation.Positive`. -/ +def addLeft (Δ : LK.Sequent L) {Γ} : Ξ ⟶⁺ Γ → Δ + Ξ ⟶⁺ Δ + Γ + | or (Γ := Γ) (φ := φ) (ψ := ψ) d => + cast (.or (Ξ := Δ + Ξ) (Γ := Δ + Γ) (φ := φ) (ψ := ψ) (cast (addLeft Δ d))) + | exs (Γ := Γ) (φ := φ) (t := t) d => + cast (.exs (Ξ := Δ + Ξ) (Γ := Δ + Γ) (φ := φ) (t := t) (cast (addLeft Δ d))) + | weakening (φ := φ) d => cast (.weakening (φ := φ) (addLeft Δ d)) + | contraction (Γ := Γ) (φ := φ) d => + cast (.contraction (Γ := Δ + Γ) (φ := φ) (cast (addLeft Δ d) (hΞ := rfl) (hΓ := by abel))) + | .refl => .refl + +/-- The cons construction in `FFL.FirstOrder.LK.Derivation.Positive`. -/ +def cons (φ) (d : Ξ ⟶⁺ Γ) : Ξ + ⦃φ⦄ ⟶⁺ Γ + ⦃φ⦄ := + cast (addLeft ⦃φ⦄ d) + +/-- The add construction in `FFL.FirstOrder.LK.Derivation.Positive`. -/ +def add {Γ Δ Ξ Θ : LK.Sequent L} (d : Γ ⟶⁺ Δ) (b : Ξ ⟶⁺ Θ) : Γ + Ξ ⟶⁺ Δ + Θ := + (addLeft Γ b).trans (cast (addLeft Θ d)) + +/-- The graft construction in `FFL.FirstOrder.LK.Derivation.Positive`. -/ +def graft {Ξ Γ : LK.Sequent L} (b : ⊢ᴸᴷ¹ Ξ) : Ξ ⟶⁺ Γ → ⊢ᴸᴷ¹ Γ + | or d => .or (d.graft b) + | exs d => .exs (d.graft b) + | weakening d => .weakening (d.graft b) + | contraction d => .contraction (d.graft b) + | refl => b + +lemma graft_isCutFree_of_isCutFree {b : ⊢ᴸᴷ¹ Ξ} {d : Ξ ⟶⁺ Γ} (hb : LK.Derivation.IsCutFree b) : + LK.Derivation.IsCutFree (d.graft b) := by induction d <;> simp [graft, *] + +end Positive + +namespace Canonical + +open Semiformulaᵢ + +variable [L.DecidableEq] + +/-- Data and laws for Stronger Than in `FFL.FirstOrder.LK.Derivation.Canonical`. -/ +structure StrongerThan (q p : LK.Sequent L) where + /-- The val construction in `FFL.FirstOrder.LK.Derivation.Canonical.StrongerThan`. -/ + val : ∼p ⟶⁺ ∼q + +/-- The «term ≼ » construction in `FFL.FirstOrder.Derivation.Canonical`. -/ +scoped[PointwiseComposition.FFL.FirstOrder.Derivation.Canonical] + infix:60 " ≼ " => FFL.FirstOrder.LK.Derivation.Canonical.StrongerThan + +open scoped FFL.FirstOrder.Derivation.Canonical + +/-- The inst Min Sequent construction in `FFL.FirstOrder.LK.Derivation.Canonical`. -/ +@[instance_reducible] +def instMinSequent : Min (LK.Sequent L) := + ⟨fun p q ↦ p + q⟩ + +scoped[PointwiseComposition.FFL.FirstOrder.Derivation.Canonical] + attribute [instance] FFL.FirstOrder.LK.Derivation.Canonical.instMinSequent + +omit [L.DecidableEq] in +lemma inf_def (p q : LK.Sequent L) : p ⊓ q = p + q := + rfl + +omit [L.DecidableEq] in +@[simp] +lemma neg_inf_p_eq (p q : LK.Sequent L) : ∼(p ⊓ q) = ∼p ⊓ ∼q := + Multiset.map_add _ _ _ + +namespace StrongerThan + +/-- The refl construction in `FFL.FirstOrder.LK.Derivation.Canonical.StrongerThan`. -/ +protected def refl (p : LK.Sequent L) : p ≼ p := + ⟨.refl⟩ + +/-- The trans construction in `FFL.FirstOrder.LK.Derivation.Canonical.StrongerThan`. -/ +def trans {r q p : LK.Sequent L} (srq : r ≼ q) (sqp : q ≼ p) : r ≼ p := ⟨sqp.val.trans srq.val⟩ + + + + + + + +/-- The of Subset construction in `FFL.FirstOrder.LK.Derivation.Canonical.StrongerThan`. -/ +def ofSubset {q p : LK.Sequent L} (tp : (PointwiseComposition.Multiset.Traversal (∼p))) + (tq : (PointwiseComposition.Multiset.Traversal (∼q))) (h : q ⊇ p) : q ≼ p := + ⟨.ofSubset tp tq <| Multiset.map_subset_map h⟩ + +/-- The K left construction in `FFL.FirstOrder.LK.Derivation.Canonical.StrongerThan`. -/ +def KLeft {p : LK.Sequent L} (φ ψ : Proposition L) : p + ⦃φ ⋏ ψ⦄ ≼ p + ⦃φ⦄ := by + let d : ∼p + ⦃∼φ⦄ ⟶⁺ ∼p + ⦃∼φ ⋎ ∼ψ⦄ := + .or (.cast (.weakening (φ := ∼ψ) (.refl : ∼p + ⦃∼φ⦄ ⟶⁺ ∼p + ⦃∼φ⦄)) rfl); + exact ⟨d.cast (by simp) (by simp)⟩; + +/-- The K right construction in `FFL.FirstOrder.LK.Derivation.Canonical.StrongerThan`. -/ +def KRight {p : LK.Sequent L} (φ ψ : Proposition L) : p + ⦃φ ⋏ ψ⦄ ≼ p + ⦃ψ⦄ := by + let d : ∼p + ⦃∼ψ⦄ ⟶⁺ ∼p + ⦃∼φ ⋎ ∼ψ⦄ := + .or (.cast (.weakening (φ := ∼φ) (.refl : ∼p + ⦃∼ψ⦄ ⟶⁺ ∼p + ⦃∼ψ⦄)) rfl); + exact ⟨d.cast (by simp) (by simp)⟩; + +/-- The all construction in `FFL.FirstOrder.LK.Derivation.Canonical.StrongerThan`. -/ +def all {p : LK.Sequent L} (φ : Semiproposition L 1) (t) : p + ⦃∀¹ φ⦄ ≼ p + ⦃φ/[t]⦄ := by + let d : ∼p + ⦃(∼φ)/[t]⦄ ⟶⁺ ∼p + ⦃∃¹ ∼φ⦄ := .exs .refl; exact ⟨d.cast (by simp) (by simp)⟩; + +/-- The min Le Left construction in `FFL.FirstOrder.LK.Derivation.Canonical.StrongerThan`. -/ +def minLeLeft (p q : LK.Sequent L) (tq : (PointwiseComposition.Multiset.Traversal (∼q))) : + p ⊓ q ≼ p := + ⟨Positive.cast (Structural.weakenMany tq (.refl : ∼p ⟶⁺ ∼p)) rfl (by simp [inf_def])⟩ + +/-- The min Le Right construction in `FFL.FirstOrder.LK.Derivation.Canonical.StrongerThan`. -/ +def minLeRight (p q : LK.Sequent L) (tp : (PointwiseComposition.Multiset.Traversal (∼p))) : + p ⊓ q ≼ q := + ⟨Positive.cast (Structural.weakenMany tp (.refl : ∼q ⟶⁺ ∼q)) rfl + (by simp [inf_def, add_comm])⟩ + +/-- The le Min Right Of Le construction in +`FFL.FirstOrder.LK.Derivation.Canonical.StrongerThan`. -/ +def leMinRightOfLe {p q : LK.Sequent L} (s : q ≼ p) (tq : + (PointwiseComposition.Multiset.Traversal (∼q))) : q ≼ p ⊓ q := by + let d : ∼p + ∼q ⟶⁺ ∼q + ∼q := (s.val.addLeft (∼q)).cast; + let d' : ∼p + ∼q ⟶⁺ ∼q := + Positive.cast (Structural.contractMany (Δ := 0) tq (Positive.cast d rfl)) rfl; + exact ⟨d'.cast (by simp [inf_def]) rfl⟩; + + + + + + + +end StrongerThan + +/-- The Forces construction in `FFL.FirstOrder.LK.Derivation.Canonical`. -/ +def Forces (p : LK.Sequent L) : Propositionᵢ L → Type u + | ⊥ => { b : ⊢ᴸᴷ¹ ∼p // LK.Derivation.IsCutFree b } + | .rel R v => { b : ⊢ᴸᴷ¹ ∼p + ⦃.rel R v⦄ // LK.Derivation.IsCutFree b } + | φ ⋏ ψ => Forces p φ × Forces p ψ + | φ ⋎ ψ => Forces p φ ⊕ Forces p ψ + | φ ⇒ₗ ψ => (q : LK.Sequent L) → q ≼ p → Forces q φ → Forces q ψ + | ∀¹ φ => (t : SyntacticTerm L) → Forces p (φ/[t]) + | ∃¹ φ => (t : SyntacticTerm L) × Forces p (φ/[t]) +termination_by φ => φ.complexity + +/-- The all Forces construction in `FFL.FirstOrder.LK.Derivation.Canonical`. -/ +abbrev allForces (φ : Propositionᵢ L) := + (p : LK.Sequent L) → (PointwiseComposition.Multiset.Traversal (∼p)) → Forces p φ + +namespace Forces + +variable {p q : LK.Sequent L} + +/-- The «term ⊩ » construction in `FFL.FirstOrder.Derivation.Canonical.Forces`. -/ +scoped[PointwiseComposition.FFL.FirstOrder.Derivation.Canonical.Forces] + infix:45 " ⊩ " => FFL.FirstOrder.LK.Derivation.Canonical.Forces + +/-- The «term⊩ » construction in `FFL.FirstOrder.Derivation.Canonical.Forces`. -/ +scoped[PointwiseComposition.FFL.FirstOrder.Derivation.Canonical.Forces] + prefix:45 "⊩ " => FFL.FirstOrder.LK.Derivation.Canonical.allForces + +open scoped FFL.FirstOrder.Derivation.Canonical.Forces + +/-- The falsum Equiv construction in `FFL.FirstOrder.LK.Derivation.Canonical.Forces`. -/ +def falsumEquiv : p ⊩ ⊥ ≃ { b : ⊢ᴸᴷ¹ ∼p // LK.Derivation.IsCutFree b} := by + unfold Forces; exact .refl _ + +/-- The rel Equiv construction in `FFL.FirstOrder.LK.Derivation.Canonical.Forces`. -/ +def relEquiv {k} {R : L.Rel k} {v} : + p ⊩ .rel R v ≃ { b : ⊢ᴸᴷ¹ ∼p + ⦃.rel R v⦄ // LK.Derivation.IsCutFree b } := by + unfold Forces; exact .refl _ + +/-- The and Equiv construction in `FFL.FirstOrder.LK.Derivation.Canonical.Forces`. -/ +def andEquiv {φ ψ : Propositionᵢ L} : p ⊩ φ ⋏ ψ ≃ (p ⊩ φ) × (p ⊩ ψ) := by + conv => + lhs + unfold Forces + exact .refl _ + +/-- The or Equiv construction in `FFL.FirstOrder.LK.Derivation.Canonical.Forces`. -/ +def orEquiv {φ ψ : Propositionᵢ L} : p ⊩ φ ⋎ ψ ≃ (p ⊩ φ) ⊕ (p ⊩ ψ) := by + conv => + lhs + unfold Forces + exact .refl _ + +/-- The imply Equiv construction in `FFL.FirstOrder.LK.Derivation.Canonical.Forces`. -/ +def implyEquiv {φ ψ : Propositionᵢ L} : + p ⊩ φ ⇒ₗ ψ ≃ ((q : LK.Sequent L) → q ≼ p → q ⊩ φ → q ⊩ ψ) := by + conv => + lhs + unfold Forces + exact .refl _ + +/-- The all Equiv construction in `FFL.FirstOrder.LK.Derivation.Canonical.Forces`. -/ +def allEquiv {φ} : p ⊩ ∀¹ φ ≃ ((t : SyntacticTerm L) → Forces p (φ/[t])) := by + conv => + lhs + unfold Forces + exact .refl _ + +/-- The exs Equiv construction in `FFL.FirstOrder.LK.Derivation.Canonical.Forces`. -/ +def exsEquiv {φ} : p ⊩ ∃¹ φ ≃ ((t : SyntacticTerm L) × Forces p (φ/[t])) := by + conv => + lhs + unfold Forces + exact .refl _ + +/-- The cast construction in `FFL.FirstOrder.LK.Derivation.Canonical.Forces`. -/ +def cast {p : LK.Sequent L} (f : p ⊩ φ) (s : φ = ψ) : p ⊩ ψ := + s ▸ f + +/-- The monotone construction in `FFL.FirstOrder.LK.Derivation.Canonical.Forces`. -/ +def monotone {q p : LK.Sequent L} (s : q ≼ p) : {φ : Propositionᵢ L} → p ⊩ φ → q ⊩ φ + | ⊥, b => + let ⟨d, hd⟩ := b.falsumEquiv + falsumEquiv.symm ⟨s.val.graft d, Positive.graft_isCutFree_of_isCutFree hd⟩ + | .rel R v, b => + let ⟨d, hd⟩ := b.relEquiv + relEquiv.symm ⟨s.val.cons (.rel R v) |>.graft d, Positive.graft_isCutFree_of_isCutFree hd⟩ + | φ ⋏ ψ, b => andEquiv.symm ⟨monotone s b.andEquiv.1, monotone s b.andEquiv.2⟩ + | φ ⋎ ψ, b => orEquiv.symm <| b.orEquiv.rec (fun b ↦ .inl <| b.monotone s) (fun b ↦ .inr <| + b.monotone s) + | φ ⇒ₗ ψ, b => implyEquiv.symm fun r srq bφ ↦ b.implyEquiv r (srq.trans s) bφ + | ∀¹ φ, b => allEquiv.symm fun t ↦ (b.allEquiv t).monotone s + | ∃¹ φ, b => + let ⟨t, d⟩ : (t : SyntacticTerm L) × p ⊩ φ/[t] := b.exsEquiv + exsEquiv.symm ⟨t, d.monotone s⟩ + termination_by φ => φ.complexity + + + + + + + +/-- The explosion construction in `FFL.FirstOrder.LK.Derivation.Canonical.Forces`. -/ +def explosion {p : LK.Sequent L} (b : p ⊩ ⊥) : (φ : Propositionᵢ L) → p ⊩ φ + | ⊥ => b + | .rel R v => + let ⟨d, hd⟩ := b.falsumEquiv + relEquiv.symm ⟨d.weakening, hd.weakening⟩ + | φ ⋏ ψ => andEquiv.symm ⟨b.explosion φ, b.explosion ψ⟩ + | φ ⋎ ψ => orEquiv.symm <| .inl <| b.explosion φ + | φ ⇒ₗ ψ => implyEquiv.symm fun q sqp _ ↦ (b.monotone sqp).explosion ψ + | ∀¹ φ => allEquiv.symm fun t ↦ b.explosion (φ/[t]) + | ∃¹ φ => exsEquiv.symm ⟨default, b.explosion (φ/[default])⟩ +termination_by φ => φ.complexity + +/-- The imply Of construction in `FFL.FirstOrder.LK.Derivation.Canonical.Forces`. -/ +def implyOf {φ ψ : Propositionᵢ L} (tp : (PointwiseComposition.Multiset.Traversal (∼p))) + (b : + (q : LK.Sequent L) → (PointwiseComposition.Multiset.Traversal (∼q)) → q ⊩ φ → p ⊓ q ⊩ ψ) : + p ⊩ φ ⇒ₗ ψ := + implyEquiv.symm fun q sqp fφ ↦ + let tq := sqp.val.traversal tp + let fψ : p ⊓ q ⊩ ψ := b q tq fφ + fψ.monotone (StrongerThan.leMinRightOfLe sqp tq) + +open LawfulSyntacticRewriting + +/-- The modus Ponens construction in `FFL.FirstOrder.LK.Derivation.Canonical.Forces`. -/ +def modusPonens {φ ψ : Propositionᵢ L} (f : p ⊩ φ ⇒ₗ ψ) (g : p ⊩ φ) : p ⊩ ψ := + f.implyEquiv p (StrongerThan.refl p) g + +/-- The Context Forces construction in `FFL.FirstOrder.LK.Derivation.Canonical.Forces`. -/ +abbrev ContextForces (p : LK.Sequent L) (Γ : LJ.Sequent L) := + (φ : Propositionᵢ L) → φ ∈ Γ → p ⊩ φ + +namespace ContextForces + +variable {p q : LK.Sequent L} {Γ Δ : LJ.Sequent L} + +/-- The of Subset construction in +`FFL.FirstOrder.LK.Derivation.Canonical.Forces.ContextForces`. -/ +def ofSubset (b : ContextForces p Δ) (h : Γ ⊆ Δ) : ContextForces p Γ := fun φ hφ ↦ b φ (h hφ) + +/-- The monotone construction in +`FFL.FirstOrder.LK.Derivation.Canonical.Forces.ContextForces`. -/ +def monotone (b : ContextForces p Γ) (s : q ≼ p) : ContextForces q Γ := + fun φ hφ ↦ (b φ hφ).monotone s + + + + + + + +/-- Extend a forcing assignment by one formula (a routine semantic operation). -/ +def cons (b : ContextForces p Γ) (hφ : p ⊩ φ) : ContextForces p (Γ + ⦃φ⦄) := fun ψ hψ ↦ + if h : φ = ψ then hφ.cast h else b ψ (by simp_all [eq_comm]) + +end ContextForces + +/-- The Head Forces construction in `FFL.FirstOrder.LK.Derivation.Canonical.Forces`. -/ +def HeadForces (p : LK.Sequent L) : LJ.Head L → Type u + | none => p ⊩ ⊥ + | some φ => p ⊩ φ + +omit [L.DecidableEq] in +private lemma rewrite_shift_eq (t : SyntacticTerm L) (φ : Propositionᵢ L) : + Rew.rewrite (t :>ₙ fun x ↦ &x) ▹ Rewriting.shift φ = φ := by + rw [← TransitiveRewriting.comp_app, Rew.rewrite_comp_shift_eq_id, ReflectiveRewriting.id_app] + +/-- Soundness of LJ for the canonical Type-valued forcing interpretation. +- [Avi01, Section 3] +-/ +def sound {Γ : LJ.Sequent L} {Ξ : LJ.Head L} (d : Γ ⊢ᴸᴶ¹ Ξ) (p : LK.Sequent L) + (tp : (PointwiseComposition.Multiset.Traversal (∼p))) (b : ContextForces p Γ) : + HeadForces p Ξ := + match d with + | .identity R v => b (.rel R v) (by simp) + | .cut (φ := φ) (Γ := Γ) (Δ := Δ) dφ d => + let bΓ := b.ofSubset (by intro ψ hψ; simp_all) + let bΔ := b.ofSubset (by intro ψ hψ; simp_all) + sound d p tp <| bΔ.cons (sound dφ p tp bΓ) + | .contraction d => sound d p tp fun ψ hψ ↦ b ψ (by simp_all) + | .weakening d => sound d p tp (b.ofSubset Multiset.subset_add_left) + | .weakeningRight d => (sound d p tp b).explosion _ + | .verum => implyEquiv.symm fun _ _ h ↦ h + | .falsum => b ⊥ (by simp) + | .positiveImply d => + implyEquiv.symm fun q sqp bφ ↦ sound d q (sqp.val.traversal tp) <| (b.monotone sqp).cons bφ + | .negativeImply (φ := φ) (ψ := ψ) (Γ := Γ) (Δ := Δ) dφ d => + let bΓ := b.ofSubset (by intro θ hθ; simp_all) + let bΔ := b.ofSubset (by intro θ hθ; simp_all) + let bi : p ⊩ φ ⇒ₗ ψ := b _ (by simp) + sound d p tp <| bΔ.cons (bi.modusPonens <| sound dφ p tp bΓ) + | .positiveAnd dφ dψ => andEquiv.symm ⟨sound dφ p tp b, sound dψ p tp b⟩ + | .negativeAnd (φ := φ) (ψ := ψ) (Γ := Γ) d => + let bΓ : ContextForces p Γ := b.ofSubset Multiset.subset_add_left + let ⟨bφ, bψ⟩ := (b (φ ⋏ ψ) (by simp)).andEquiv + sound d p tp <| ((bΓ.cons bφ).cons bψ).ofSubset (by intro θ hθ; simpa [add_assoc] using hθ) + | .positiveOrLeft d => orEquiv.symm <| .inl <| sound d p tp b + | .positiveOrRight d => orEquiv.symm <| .inr <| sound d p tp b + | .negativeOr (φ := φ) (ψ := ψ) (Γ := Γ) dφ dψ => + let bΓ := b.ofSubset (by intro θ hθ; simp_all) + (b (φ ⋎ ψ) (by simp)).orEquiv.rec (fun bφ ↦ sound dφ p tp <| bΓ.cons bφ) + (fun bψ ↦ sound dψ p tp <| bΓ.cons bψ) + | .positiveForall (Γ := Γ) (φ := φ) d => + allEquiv.symm fun t ↦ + let f : ℕ → SyntacticTerm L := t :>ₙ fun x ↦ &x + let dt : Γ ⊢ᴸᴶ¹ some (φ/[t]) := + (d.rewrite f).cast (by simp [f, Rewriting.shifts, Multiset.map_map, rewrite_shift_eq]) + (by simp [f, LJ.Head.rewrite, rewrite_free_eq_subst]) + sound dt p tp b + | .negativeForall (φ := φ) (Γ := Γ) d => + let bΓ := b.ofSubset (by intro θ hθ; simp_all) + let bAll := (b (∀¹ φ) (by simp)).allEquiv _ + sound d p tp <| bΓ.cons bAll + | .positiveExists (t := t) d => exsEquiv.symm ⟨t, sound d p tp b⟩ + | .negativeExists (Γ := Γ) (Ξ := Ξ) (φ := φ) d => + let ⟨t, bt⟩ := (b (∃¹ φ) (by simp)).exsEquiv + let f : ℕ → SyntacticTerm L := t :>ₙ fun x ↦ &x + let dt : Γ + ⦃φ/[t]⦄ ⊢ᴸᴶ¹ Ξ := + (d.rewrite f).cast + (by + simp [f, Rewriting.shifts, Multiset.map_map, rewrite_shift_eq, rewrite_free_eq_subst]) + (by cases Ξ <;> simp [f, LJ.Head.shift, LJ.Head.rewrite, rewrite_shift_eq]) + let bΓ := b.ofSubset (by intro θ hθ; simp_all) + sound dt p tp <| bΓ.cons bt +termination_by d.height +decreasing_by + all_goals simp [LJ.Derivation.height] + all_goals try omega + all_goals + exact + Nat.lt_succ_iff.mpr <| + Nat.le_of_eq <| + (LJ.Derivation.height_cast _ _ _).trans + (LJ.Derivation.height_rewrite (t :>ₙ fun x ↦ &x) d) + +/-- The lj Sound construction in `FFL.FirstOrder.LK.Derivation.Canonical.Forces`. -/ +def ljSound {φ : Propositionᵢ L} (d : 𝐋𝐉¹ ⊢! φ) : ⊩ φ := fun p tp ↦ + sound d p tp fun _ h ↦ by simp at h + +/-- The rel Refl construction in `FFL.FirstOrder.LK.Derivation.Canonical.Forces`. -/ +def relRefl {k} (R : L.Rel k) (v : Fin k → SyntacticTerm L) : ⦃.rel R v⦄ ⊩ rel R v := + relEquiv.symm ⟨LK.Derivation.cast <| LK.Derivation.identity _ _, by simp⟩ + +/-- The or construction in `FFL.FirstOrder.LK.Derivation.Canonical.Forces.refl`. -/ +protected def refl.or {φ ψ : Proposition L} + (ihφ : ⦃φ⦄ ⊩ φᴺ) (ihψ : ⦃ψ⦄ ⊩ ψᴺ) : ⦃φ ⋎ ψ⦄ ⊩ (φ ⋎ ψ)ᴺ := + implyOf (.atom _) fun q tq dq ↦ + let ⟨dφ, dψ⟩ : q ⊩ ∼φᴺ × q ⊩ ∼ψᴺ := dq.andEquiv + let tφ : (PointwiseComposition.Multiset.Traversal (∼(⦃φ⦄ : LK.Sequent L))) := .atom _ + let tψ : (PointwiseComposition.Multiset.Traversal (∼(⦃ψ⦄ : LK.Sequent L))) := .atom _ + let bφ : ⦃φ⦄ ⊓ q ⊩ ⊥ := dφ.implyEquiv (⦃φ⦄ ⊓ q) + (.minLeRight _ _ tφ) (ihφ.monotone (.minLeLeft _ _ tq)) + let bψ : ⦃ψ⦄ ⊓ q ⊩ ⊥ := dψ.implyEquiv (⦃ψ⦄ ⊓ q) + (.minLeRight _ _ tψ) (ihψ.monotone (.minLeLeft _ _ tq)) + let ⟨bbφ, hbbφ⟩ := bφ.falsumEquiv + let ⟨bbψ, hbbψ⟩ := bψ.falsumEquiv + let bbφ' : ⊢ᴸᴷ¹ ∼q + ⦃∼φ⦄ := LK.Derivation.cast bbφ (by simp [inf_def]; abel) + let bbψ' : ⊢ᴸᴷ¹ ∼q + ⦃∼ψ⦄ := LK.Derivation.cast bbψ (by simp [inf_def]; abel) + let band : ⊢ᴸᴷ¹ ∼q + ⦃∼φ ⋏ ∼ψ⦄ := LK.Derivation.and bbφ' bbψ' + falsumEquiv.symm ⟨LK.Derivation.cast band (by simp [inf_def]; abel), by + simpa [band, bbφ', bbψ'] using And.intro hbbφ hbbψ⟩ + +-- Transparency is lowered so that rewriting under the recursive forcing definition remains stable. +/-- The exs construction in `FFL.FirstOrder.LK.Derivation.Canonical.Forces.refl`. -/ +protected def refl.exs {φ : Semiproposition L 1} (d : ∀ x, ⦃φ/[&x]⦄ ⊩ (φ/[&x])ᴺ) : + ⦃∃¹ φ⦄ ⊩ (∃¹ φ)ᴺ := + implyOf (.atom _) fun q tq f ↦ + let x := LK.Sequent.newVar (∼q + ⦃∀¹ ∼φ⦄) + let ih : ⦃φ/[&x]⦄ ⊩ φᴺ/[&x] := cast (d x) (by simp [Semiformula.subst_doubleNegation]) + let b : ⦃φ/[&x]⦄ ⊓ q ⊩ ⊥ := + let tφ : (PointwiseComposition.Multiset.Traversal (∼(⦃φ/[&x]⦄ : LK.Sequent L))) := .atom _ + (f.allEquiv &x).implyEquiv (⦃φ/[&x]⦄ ⊓ q) (StrongerThan.minLeRight _ _ tφ) + (ih.monotone (StrongerThan.minLeLeft _ _ tq)) + let ⟨b, hb⟩ := b.falsumEquiv + let hp : ¬(∼φ).HasFreeVariable x := + by + have : ¬(∀¹ ∼φ).HasFreeVariable x := LK.Sequent.not_hasFreeVariable_newVar (by simp) + simpa using this + let hq : ∀ ψ ∈ ∼q, ¬ψ.HasFreeVariable x := fun ψ hψ ↦ + LK.Sequent.not_hasFreeVariable_newVar (by simp [hψ]) + let b' : ⊢ᴸᴷ¹ ∼q + ⦃(∼φ)/[&x]⦄ := LK.Derivation.cast b (by simp [inf_def]; abel) + let ba : ⊢ᴸᴷ¹ ∼q + ⦃∀¹ ∼φ⦄ := LK.Derivation.generalizeByNewVar hp hq b' + falsumEquiv.symm + ⟨LK.Derivation.cast ba (by simp [inf_def]; abel), by simpa [ba, b'] using hb⟩ + +/-- The refl construction in `FFL.FirstOrder.LK.Derivation.Canonical.Forces`. -/ +protected def refl : (φ : Proposition L) → ⦃φ⦄ ⊩ φᴺ + | ⊤ => implyEquiv.symm fun q sqp dφ ↦ dφ + | ⊥ => by + change ⦃⊥⦄ ⊩ ⊥ + refine falsumEquiv.symm ?_ + refine ⟨LK.Derivation.cast LK.Derivation.verum (by simp), ?_⟩ + simp + | .rel R v => + implyOf (.atom _) fun q tq dq ↦ + let tr : (PointwiseComposition.Multiset.Traversal (∼(⦃.rel R v⦄ : LK.Sequent L))) := + .atom _ + let b : ⦃.rel R v⦄ ⊓ q ⊩ rel R v := (relRefl R v).monotone (StrongerThan.minLeLeft _ _ tq) + dq.implyEquiv (⦃.rel R v⦄ ⊓ q) (StrongerThan.minLeRight _ _ tr) b + | .nrel R v => + implyOf (.atom _) fun q _ dq ↦ + let ⟨d, hd⟩ := dq.relEquiv + falsumEquiv.symm ⟨LK.Derivation.cast d (by simp [inf_def]; abel), by simpa using hd⟩ + | φ ⋏ ψ => + let ihφ : ⦃φ⦄ ⊩ φᴺ := Forces.refl φ + let ihψ : ⦃ψ⦄ ⊩ ψᴺ := Forces.refl ψ + andEquiv.symm + ⟨by simpa using ihφ.monotone (.KLeft (p := 0) φ ψ), by + simpa using ihψ.monotone (.KRight (p := 0) φ ψ)⟩ + | φ ⋎ ψ => refl.or (Forces.refl φ) (Forces.refl ψ) + | ∀¹ φ => + allEquiv.symm fun t ↦ + let b : ⦃φ/[t]⦄ ⊩ φᴺ/[t] := by + simpa [Semiformula.rew_doubleNegation] using Forces.refl (φ/[t]) + by simpa using b.monotone (StrongerThan.all (p := 0) φ t) + | ∃¹ φ => refl.exs fun x ↦ Forces.refl (φ/[&x]) +termination_by φ => φ.complexity + +end Forces + +/-- The hauptsatz construction in `FFL.FirstOrder.LK.Derivation.Canonical`. -/ +def hauptsatz {Γ : LK.Sequent L} : ⊢ᴸᴷ¹ Γ → { d : ⊢ᴸᴷ¹ Γ // LK.Derivation.IsCutFree d } := + fun d ↦ + let t := d.traversal + let tNegΓ : (PointwiseComposition.Multiset.Traversal (∼Γ)) := t.map (∼·) + have f : ((ψ : Propositionᵢ L) → ψ ∈ (∼Γ)ᴺ → Forces (∼Γ) ψ) → Forces (∼Γ) ⊥ := + Forces.sound d.gödelGentzen (∼Γ) (t.cast (by simp)) + have g : (ψ : Propositionᵢ L) → ψ ∈ (∼Γ)ᴺ → Forces (∼Γ) ψ := fun φ hφ ↦ + have φ₀ := + tNegΓ.getPreimage (f := fun θ : Proposition L ↦ θᴺ) + (by simpa [LK.Sequent.doubleNegation] using hφ) + have h : Forces (∼Γ) (φ₀.val)ᴺ := + (Forces.refl φ₀.val).monotone <| + StrongerThan.ofSubset (.atom _) (t.cast (by simp)) (by simpa using φ₀.property.1) + h.cast φ₀.property.2 + have ⟨b, hb⟩ := (f g).falsumEquiv + ⟨LK.Derivation.cast b (by simp), by simpa using hb⟩ + +end Canonical + +end Derivation +end LK +end FirstOrder +end FFL +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/Simplified.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/Simplified.lean new file mode 100644 index 000000000..8b6de77ca --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/Simplified.lean @@ -0,0 +1,258 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.LK.Basic + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +/-! +# Alternative definition of proof -/ + +namespace FFL +namespace FirstOrder + +variable {L : Language} [L.DecidableEq] + +section derivation2 + +/-- Data and laws for Derivation in `FFL.FirstOrder.LK2`. -/ +inductive LK2.Derivation (T : Theory L) : Finset (Proposition L) → Type _ + | closed (Γ) (φ : Proposition L) : φ ∈ Γ → ∼φ ∈ Γ → LK2.Derivation T Γ + | axm {Γ} (φ : Sentence L) : φ ∈ T → (φ : Proposition L) ∈ Γ → LK2.Derivation T Γ + | verum {Γ} : ⊤ ∈ Γ → LK2.Derivation T Γ + | + and {Γ} {φ ψ : Proposition L} : + φ ⋏ ψ ∈ Γ → + LK2.Derivation T (insert φ Γ) → LK2.Derivation T (insert ψ Γ) → LK2.Derivation T Γ + | + or {Γ} {φ ψ : Proposition L} : + φ ⋎ ψ ∈ Γ → LK2.Derivation T (insert φ (insert ψ Γ)) → LK2.Derivation T Γ + | + all {Γ} {φ : Semiproposition L 1} : + ∀¹ φ ∈ Γ → + LK2.Derivation T (insert (Rewriting.free φ) (Γ.image Rewriting.shift)) → + LK2.Derivation T Γ + | + exs {Γ} {φ : Semiproposition L 1} : + ∃¹ φ ∈ Γ → (t : SyntacticTerm L) → LK2.Derivation T (insert (φ/[t]) Γ) → LK2.Derivation T Γ + | wk {Δ Γ} : LK2.Derivation T Δ → Δ ⊆ Γ → LK2.Derivation T Γ + | shift {Γ} : LK2.Derivation T Γ → LK2.Derivation T (Γ.image Rewriting.shift) + | + cut {Γ φ} : + LK2.Derivation T (insert φ Γ) → LK2.Derivation T (insert (∼φ) Γ) → LK2.Derivation T Γ + +/-- The «term ⟹₂ » construction in `FFL.FirstOrder`. -/ +scoped infix:45 " ⟹₂" => LK2.Derivation + +/-- The Derivable construction in `FFL.FirstOrder.LK2`. -/ +abbrev LK2.Derivable (T : Theory L) (Γ : Finset (Proposition L)) := + Nonempty (T ⟹₂Γ) + +/-- The «term ⟹₂! » construction in `FFL.FirstOrder`. -/ +scoped infix:45 " ⟹₂! " => LK2.Derivable + +/-- The Proof2 construction in `FFL.FirstOrder.Theory`. -/ +abbrev _root_.PointwiseComposition.FFL.FirstOrder.Theory.Proof2 (T : Theory L) + (φ : Proposition L) := + T ⟹₂{ φ } + +/-- The «term ⊢₂! » construction in `FFL.FirstOrder`. -/ +scoped infix:45 " ⊢₂! " => Theory.Proof2 + +variable {T : Theory L} {Γ : LK.Sequent L} {φ : Proposition L} + +lemma shifts_toFinset_eq_image_shift (Γ : LK.Sequent L) : + Γ⁺.toFinset = Γ.toFinset.image Rewriting.shift := by ext φ; simp [Rewriting.shifts] + +/-- The to Derivation2 construction in `FFL.FirstOrder.LK.Derivation`. -/ +def LK.Derivation.toDerivation2 (T) {Γ : LK.Sequent L} : ⊢ᴸᴷ¹ Γ → T ⟹₂Γ.toFinset + | LK.Derivation.identity R v => + LK2.Derivation.closed _ (Semiformula.rel R v) (by simp) (by simp) + | LK.Derivation.verum => LK2.Derivation.verum (by simp) + | LK.Derivation.and (Γ := Γ) (φ := φ) (ψ := ψ) dp dq => + LK2.Derivation.and (φ := φ) (ψ := ψ) (by simp) + (LK2.Derivation.wk (LK.Derivation.toDerivation2 T dp) (by intro x hx; simp_all; tauto)) + (LK2.Derivation.wk (LK.Derivation.toDerivation2 T dq) (by intro x hx; simp_all; tauto)) + | LK.Derivation.or (Γ := Γ) (φ := φ) (ψ := ψ) dpq => + LK2.Derivation.or (φ := φ) (ψ := ψ) (by simp) + (LK2.Derivation.wk (LK.Derivation.toDerivation2 T dpq) (by intro x hx; simp_all; tauto)) + | LK.Derivation.all (Γ := Γ) (φ := φ) dp => + LK2.Derivation.all (φ := φ) (by simp) + (LK2.Derivation.wk (LK.Derivation.toDerivation2 T dp) + (by + intro x hx + simp [shifts_toFinset_eq_image_shift] at hx ⊢ + aesop)) + | LK.Derivation.exs (Γ := Γ) (φ := φ) (t := t) dp => + LK2.Derivation.exs (φ := φ) (by simp) t + (LK2.Derivation.wk (LK.Derivation.toDerivation2 T dp) (by intro x hx; simp_all; tauto)) + | LK.Derivation.contraction d => + LK2.Derivation.wk (LK.Derivation.toDerivation2 T d) (by intro x hx; simpa using hx) + | LK.Derivation.weakening d => + LK2.Derivation.wk (LK.Derivation.toDerivation2 T d) (by intro x hx; simp_all) + | LK.Derivation.cut (Γ := Γ) (Δ := Δ) (φ := φ) d₁ d₂ => + LK2.Derivation.cut (φ := φ) + (LK2.Derivation.wk (LK.Derivation.toDerivation2 T d₁) (by intro x hx; simp_all; tauto)) + (LK2.Derivation.wk (LK.Derivation.toDerivation2 T d₂) (by intro x hx; simp_all; tauto)) + +namespace LK2 +namespace Derivation + +/-- Data and laws for Proof Data in `FFL.FirstOrder.LK2.Derivation`. -/ +structure ProofData (T : Theory L) (Γ : Finset (Proposition L)) where + /-- The axioms construction in `FFL.FirstOrder.LK2.Derivation.ProofData`. -/ + axioms : Multiset (Sentence L) + axioms_mem : ∀ ψ ∈ axioms, ψ ∈ T + /-- The derivation construction in `FFL.FirstOrder.LK2.Derivation.ProofData`. -/ + derivation : ⊢ᴸᴷ¹ Γ.1 + ∼LK.Sequent.embed axioms + +/-- The cast construction in `FFL.FirstOrder.LK2.Derivation`. -/ +noncomputable def cast {Γ Δ : Finset (Proposition L)} (d : T ⟹₂Γ) (h : Γ = Δ := by simp) : + T ⟹₂Δ := + h ▸ d + +omit [L.DecidableEq] in +lemma shifts_tilde_embed (A : Multiset (Sentence L)) : + (∼LK.Sequent.embed A)⁺ = ∼LK.Sequent.embed A := by + simp [Rewriting.shifts, LK.Sequent.embed, Multiset.tilde_def] + +/-- The cut Many Proof construction in `FFL.FirstOrder.LK2.Derivation`. -/ +@[reducible] noncomputable def cutManyProof (A : Multiset (Sentence L)) + (hA : ∀ ψ ∈ A, ψ ∈ T) + (d : T ⟹₂(insert (φ : Proposition L) (∼LK.Sequent.embed A).toFinset)) : T ⟹₂ {φ} := + go A.toList (by simpa using hA) <| LK2.Derivation.cast d (by ext x; simp) where + -- Multiset induction cannot eliminate into the Type-valued derivation family. + /-- The go construction in `FFL.FirstOrder.LK2.Derivation.cutManyProof`. -/ + go : (l : List (Sentence L)) → (∀ ψ ∈ l, ψ ∈ T) → + T ⟹₂(insert (φ : Proposition L) (∼LK.Sequent.embed (l : Multiset _)).toFinset) → + T ⟹₂ {φ} + | [], _, d => LK2.Derivation.cast d (by simp) + | ψ :: l, hl, d => + have ax : T ⟹₂ insert (ψ : Proposition L) + (insert φ (∼LK.Sequent.embed (l : Multiset _)).toFinset) := + LK2.Derivation.axm ψ (hl ψ (by simp)) (by simp) + have dn : T ⟹₂ insert (∼(ψ : Proposition L)) + (insert φ (∼LK.Sequent.embed (l : Multiset _)).toFinset) := by + refine LK2.Derivation.cast d ?_ + ext x + have hneg : ∼x = Rewriting.emb ψ ↔ x = ∼Rewriting.emb ψ := by grind + simp [LK.Sequent.embed, hneg, or_left_comm] + have c : T ⟹₂ insert φ (∼LK.Sequent.embed (l : Multiset _)).toFinset := by + exact LK2.Derivation.cast (LK2.Derivation.cut ax dn) (by ext x; simp) + go l (by simp_all) c + +/-- The to Proof Data construction in `FFL.FirstOrder.LK2.Derivation`. -/ +noncomputable def toProofData {Γ : Finset (Proposition L)} : T ⟹₂Γ → ProofData T Γ + | closed _ φ hp hn => + ⟨0, by simp, + (LK.Derivation.eta φ).contra default + (by + intro x hx + rcases Multiset.mem_add.mp hx with hx | hx <;> simp_all)⟩ + | axm φ hT hΓ => + ⟨⦃φ⦄, by simp [hT], + (LK.Derivation.eta (φ : Proposition L)).contra default + (by + intro x hx + rcases Multiset.mem_add.mp hx with hx | hx <;> simp_all)⟩ + | verum h => ⟨0, by simp, LK.Derivation.verum.contra default (by intro x hx; simp_all)⟩ + | and (φ := φ) (ψ := ψ) h dφ dψ => + by + rcases toProofData dφ with ⟨A, hA, bφ⟩ + rcases toProofData dψ with ⟨B, hB, bψ⟩ + refine ⟨A + B, by simp; grind, ?_⟩ + have bφ' : ⊢ᴸᴷ¹ (Γ.1 + ∼LK.Sequent.embed (A + B)) + ⦃φ⦄ := + bφ.contra default (by intro x hx; simp_all [LK.Sequent.embed]; aesop) + have bψ' : ⊢ᴸᴷ¹ (Γ.1 + ∼LK.Sequent.embed (A + B)) + ⦃ψ⦄ := + bψ.contra default (by intro x hx; simp_all [LK.Sequent.embed]; aesop) + exact Structural.absorb (LK.Derivation.and bφ' bψ') (Multiset.mem_add.mpr <| Or.inl h) + | or (φ := φ) (ψ := ψ) h d => + by + rcases toProofData d with ⟨A, hA, b⟩ + refine ⟨A, hA, ?_⟩ + have b' : ⊢ᴸᴷ¹ (Γ.1 + ∼LK.Sequent.embed A) + ⦃φ, ψ⦄ := + b.contra default (by intro x hx; simp_all; aesop) + exact Structural.absorb (LK.Derivation.or b') (Multiset.mem_add.mpr <| Or.inl h) + | all (φ := φ) h d => by + rcases toProofData d with ⟨A, hA, b⟩ + refine ⟨A, hA, ?_⟩ + have b' : ⊢ᴸᴷ¹ (Γ.1 + ∼LK.Sequent.embed A)⁺ + ⦃Rewriting.free φ⦄ := + b.contra default + (by + rw [Rewriting.shifts_add, shifts_tilde_embed] + intro x hx + simp [Rewriting.shifts] at hx ⊢ + aesop) + exact Structural.absorb (LK.Derivation.all b') (Multiset.mem_add.mpr <| Or.inl h) + | exs (φ := φ) h t d => by + rcases toProofData d with ⟨A, hA, b⟩ + refine ⟨A, hA, ?_⟩ + have b' : ⊢ᴸᴷ¹ (Γ.1 + ∼LK.Sequent.embed A) + ⦃φ/[t]⦄ := + b.contra default (by intro x hx; simp_all; aesop) + exact Structural.absorb (LK.Derivation.exs (t := t) b') (Multiset.mem_add.mpr <| Or.inl h) + | wk d h => by + rcases toProofData d with ⟨A, hA, b⟩ + exact ⟨A, hA, b.contra default (by intro x hx; simp_all; aesop)⟩ + | shift (Γ := Γ) d => by + rcases toProofData d with ⟨A, hA, b⟩ + refine ⟨A, hA, b.shift.contra default ?_⟩ + rw [Rewriting.shifts_add, shifts_tilde_embed] + intro x hx + simpa [Rewriting.shifts] using hx + | cut (φ := φ) d dn => by + rcases toProofData d with ⟨A, hA, b⟩ + rcases toProofData dn with ⟨B, hB, bn⟩ + refine ⟨A + B, by simp; grind, ?_⟩ + have b' : ⊢ᴸᴷ¹ (Γ.1 + ∼LK.Sequent.embed (A + B)) + ⦃φ⦄ := + b.contra default (by intro x hx; simp_all [LK.Sequent.embed]; aesop) + have bn' : ⊢ᴸᴷ¹ (Γ.1 + ∼LK.Sequent.embed (A + B)) + ⦃∼φ⦄ := + bn.contra default (by intro x hx; simp_all [LK.Sequent.embed]; aesop) + exact + (LK.Derivation.cut (Γ := Γ.1 + ∼LK.Sequent.embed (A + B)) (Δ := + Γ.1 + ∼LK.Sequent.embed (A + B)) (φ := φ) b' bn').contra + default (by intro x hx; simp_all) + +end Derivation +end LK2 + +namespace Theory + +/-- The to Proof2 construction in `FFL.FirstOrder.Theory.Proof`. -/ +noncomputable def Proof.toProof2 {φ : Sentence L} (b : T ⊢! φ) : T ⊢₂! (φ : Proposition L) := + LK2.Derivation.cutManyProof b.axioms b.axioms_mem <| + LK2.Derivation.cast (LK.Derivation.toDerivation2 T b.derivation) + (by ext x; simp [LK.Sequent.embed, Multiset.map_tilde_comm]) + +/-- The to Proof construction in `FFL.FirstOrder.Theory.Proof2`. -/ +noncomputable def Proof2.toProof {φ : Sentence L} (d : T ⊢₂! (φ : Proposition L)) : T ⊢! φ := + by + rcases LK2.Derivation.toProofData d with ⟨A, hA, b⟩ + exact + ⟨A, hA, + LK.Derivation.cast b + (by simp [LK.Sequent.embed, Multiset.atom_eq_singleton, Multiset.map_tilde_comm])⟩ + +end Theory + +lemma provable_iff_derivable2 {φ : Sentence L} : T ⊢ φ ↔ Nonempty (T ⊢₂! (φ : Proposition L)) := + by exact ⟨fun h ↦ ⟨h.get.toProof2⟩, fun ⟨h⟩ ↦ ⟨h.toProof⟩⟩ + +end derivation2 + +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/Soundness.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/Soundness.lean new file mode 100644 index 000000000..abdebc036 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/Soundness.lean @@ -0,0 +1,163 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Tarski.Basic +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.LK.Basic + +/-! Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +/-! # Soundness theorem for first-order classical logic -/ + +namespace FFL +namespace FirstOrder + +open Semiformula + +variable {L : Language} + +namespace LK +namespace Derivation + +lemma sound {M : Type*} [s : Tarski.Structure L M] [Nonempty M] (f : ℕ → M) {Γ : LK.Sequent L} : + ⊢ᴸᴷ¹ Γ → ∃ φ ∈ Γ, φ.Evalf f + | identity r v => by + by_cases h : s.rel r (Semiterm.val ![] f ∘ v) + · exact ⟨rel r v, by simp, h⟩ + · exact ⟨nrel r v, by simp, h⟩ + | verum => ⟨⊤, by simp⟩ + | or (Γ := Γ) (φ := φ) (ψ := ψ) d => by + rcases sound f d with ⟨r, hr, hhr⟩ + rcases Multiset.mem_add.mp hr with hr | hr + · exact ⟨r, by simp [hr], hhr⟩ + · rcases Multiset.mem_add.mp hr with hr | hr + · have : r = φ := by simpa using hr + subst r + exact ⟨φ ⋎ ψ, by simp, by simp [hhr]⟩ + · have : r = ψ := by simpa using hr + subst r + exact ⟨φ ⋎ ψ, by simp, by simp [hhr]⟩ + | and (Γ := Γ) (φ := φ) (ψ := ψ) dp dq => by + have : (∃ r ∈ Γ, Evalf f r) ∨ Evalf f φ := by simpa using sound f dp + rcases this with (⟨r, hr, hhr⟩ | hp) + · exact ⟨r, by simp [hr], hhr⟩ + · have : (∃ r ∈ Γ, Evalf f r) ∨ Evalf f ψ := by simpa using sound f dq + rcases this with (⟨r, hr, hhr⟩ | hq) + · exact ⟨r, by simp [hr], hhr⟩ + · exact ⟨φ ⋏ ψ, by simp, by simp [hp, hq]⟩ + | all (Γ := Γ) (φ := φ) d => by + have : (∃ ψ ∈ Γ, Evalf f ψ) ∨ ∀ a : M, Eval ![a] f φ := by + simpa [Rewriting.shifts, Matrix.vecConsLast_vecEmpty, forall_or_left] + using fun a : M ↦ sound (a :>ₙ f) d + rcases this with (⟨ψ, hq, hhq⟩ | hp) + · exact ⟨ψ, by simp [hq], hhq⟩ + · exact ⟨∀¹ φ, by simp, hp⟩ + | exs (Γ := Γ) (φ := φ) (t := t) d => by + have : (∃ φ ∈ Γ, Evalf f φ) ∨ Eval ![t.val ![] f] f φ := by + simpa [eval_substs, Matrix.constant_eq_singleton] using sound f d + rcases this with (⟨ψ, hq, hhq⟩ | hp) + · exact ⟨ψ, by simp [hq], hhq⟩ + · exact ⟨∃¹ φ, by simp, t.val ![] f, hp⟩ + | contraction d => by simpa using sound f d + | weakening d => by + obtain ⟨φ, hp, h⟩ := sound f d; + exact ⟨φ, Multiset.mem_add.mpr (.inl hp), h⟩; + | cut (Γ := Γ) (Δ := Δ) (φ := φ) d dn => by + have h : (∃ ψ ∈ Γ, Evalf f ψ) ∨ Evalf f φ := by simpa using sound f d + have hn : (∃ ψ ∈ Δ, Evalf f ψ) ∨ ¬Evalf f φ := by simpa using sound f dn + rcases h with (⟨ψ, h, hq⟩ | h) + · exact ⟨ψ, by simp [h], hq⟩ + · rcases hn with (⟨ψ, hn, hq⟩ | hn) + · exact ⟨ψ, by simp [hn], hq⟩ + · contradiction + +@[simp] +lemma nil_empty : IsEmpty (⊢ᴸᴷ¹ (0 : LK.Sequent L)) := + by + refine ⟨fun b ↦ ?_⟩ + simpa using sound (fun _ ↦ ()) b + +end Derivation +end LK + +theorem LK.Proof.sound {M : Type*} [s : Tarski.Structure L M] [Nonempty M] {φ : Proposition L} + (f : ℕ → M) : 𝐋𝐊¹ ⊢ φ → φ.Evalf f := fun b ↦ by simpa using LK.Derivation.sound f b.get + +variable {T U : Theory L} + +namespace Theory + +theorem Proof.sound_proposition {M : Type*} [s : Tarski.Structure L M] [Nonempty M] : + T ⊢ φ → M↓[L] ⊧* T → φ.Realize M := fun b H ↦ + by + rcases Proof.provable_iff.mp b with ⟨Γ, hΓ, ⟨b⟩⟩ + let f : ℕ → M := fun _ ↦ Nonempty.some inferInstance + have : φ.Realize M ∨ ∃ ψ, ∼ψ ∈ LK.Sequent.embed Γ ∧ ψ.Evalf f := by simpa using b.sound f + rcases this with (h | ⟨ψ, hψ, h⟩) + · assumption + · have : ∃ χ : Sentence L, ∼χ ∈ Γ ∧ ↑χ = ψ := + by + have : ∃ χ ∈ Γ, χ = ∼ψ := by simpa [LK.Sequent.embed] using hψ + rcases this with ⟨χ, hχ, e⟩ + refine ⟨∼χ, by simpa using hχ, by simp [e]⟩ + rcases this with ⟨χ, hχ, rfl⟩ + have : χ.Realize M := by simpa using h + have : ¬χ.Realize M := by simpa [models_iff] using H.models _ (hΓ _ hχ) + contradiction + +/-- Soundness theorem for first-order logic. -/ +theorem Proof.sound {φ : Sentence L} : T ⊢ φ → T ⊨[Tarski.Struc.{v, u} L] φ := fun b s hS ↦ by + simpa [struc_models_iff_models (s := s), models_iff] using Proof.sound_proposition b hS + +theorem Proof.sound_small : T ⊢ φ → T ⊨ φ := + Proof.sound + +instance (T : Theory L) : Sound T (Semantics.models (Tarski.Struc.{v, u} L) T) := + ⟨Theory.Proof.sound⟩ + +lemma consistent_of_satisfiable (h : Semantics.Satisfiable (Tarski.Struc.{v, u} L) T) : + Entailment.Consistent T := + Sound.consistent_of_satisfiable h + +end Theory + +section model + +variable (T) (M : Type*) [Nonempty M] [Tarski.Structure L M] + +lemma consistent_of_model [hM : M↓[L] ⊧* T] : Entailment.Consistent T := + Theory.consistent_of_satisfiable ⟨M↓[L], hM⟩ + +variable {M} + +lemma unprovable_of_countermodel [hM : M↓[L] ⊧* T] {φ} : M↓[L] ⊭ φ → T ⊬ φ := + by + contrapose!; intro h + exact Theory.Proof.sound h hM + +variable {T} + +lemma models_of_provable (hT : M↓[L] ⊧* T) {φ : Sentence L} (h : T ⊢ φ) : M↓[L] ⊧ φ := + consequence_iff.mp (Theory.Proof.sound h) M inferInstance + +lemma models_of_subtheory [T ≼ U] : M↓[L] ⊧* U → M↓[L] ⊧* T := fun hM ↦ + ⟨fun _ hφ ↦ Theory.Proof.sound (Entailment.WeakerThan.pbl (Entailment.by_axm hφ)) hM⟩ + +end model + +end FirstOrder + +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Classical/BinderNotation.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Classical/BinderNotation.lean new file mode 100644 index 000000000..c8e905b88 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Classical/BinderNotation.lean @@ -0,0 +1,1184 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Syntax.Classical.BinderSemantics + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +open _root_.Lean Lean Elab PrettyPrinter Delaborator SubExpr + +namespace Lean +namespace TSyntax + +open _root_.Lean.TSyntax + +/-- The fresh Ident construction in `Lean.TSyntax`. -/ +meta def freshIdent [Monad m] [MonadQuotation m] : m (TSyntax `ident) := do + let name ← Term.mkFreshBinderName + return ⟨mkIdent name⟩ + +end TSyntax +end Lean + +namespace FFL +namespace FirstOrder + +namespace BinderNotation + +/-- The fin Succ Itr construction in `FFL.FirstOrder.BinderNotation`. -/ +@[simp] +abbrev finSuccItr {n} (i : Fin n) : (m : ℕ) → Fin (n + m) + | 0 => i + | m + 1 => (finSuccItr i m).succ + +open Semiterm Semiformula + +/-! +### (Literal) Notation for terms -/ + +/-- The first order term construction in `Lean.Parser.Category`. -/ +declare_syntax_cat firstOrderTerm + +/-- The quote type construction in `Lean.Parser.Category.first_order`. -/ +declare_syntax_cat firstOrder.quoteType + +/-- The quote type Lit construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :max "lit" : firstOrder.quoteType + +/-- The quote type Faf construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :max "faf" : firstOrder.quoteType + +/-- The «term Quoteterm( )[ | | ]» construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax "quoteterm(" firstOrder.quoteType ")[" ident* " | " ident* " | " firstOrderTerm:0 "]" : + term + +/-- The «first order term( )» construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax "(" firstOrderTerm ")" : firstOrderTerm + +/-- The first order term construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :max ident : firstOrderTerm + +/-- The «first order term# » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :max "#" term:max : firstOrderTerm + +/-- The «first order term& » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :max "&" term:max : firstOrderTerm + +/-- The «first order term! ⋯» construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :80 "!" term:max firstOrderTerm:81* (" ⋯")? : firstOrderTerm + +/-- The first order term!! construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :80 "!!" term:max : firstOrderTerm + +/-- The ! ⋯» construction in `FFL.FirstOrder.BinderNotation.«firstOrderTerm`. -/ +syntax :80 ".!" term:max firstOrderTerm:81* (" ⋯")? : firstOrderTerm + +/-- The !! » construction in `FFL.FirstOrder.BinderNotation.«firstOrderTerm`. -/ +syntax :80 ".!!" term:max : firstOrderTerm + +/-- The first order term 1 construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax num : firstOrderTerm + +/-- The «first order term↑ » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :max "↑" term:max : firstOrderTerm + +/-- The «first order term⋆» construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :max "⋆" : firstOrderTerm + +/-- The «first order term + » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :50 firstOrderTerm:50 " + " firstOrderTerm:51 : firstOrderTerm + +/-- The «first order term * » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :60 firstOrderTerm:60 " * " firstOrderTerm:61 : firstOrderTerm + +/-- The «first order term ^ » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :65 firstOrderTerm:65 " ^ " firstOrderTerm:66 : firstOrderTerm + +/-- The «first order term ^' » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :70 firstOrderTerm " ^' " num : firstOrderTerm + +/-- The «first order term ²» construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :max firstOrderTerm "²" : firstOrderTerm + +/-- The «first order term ³» construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :max firstOrderTerm "³" : firstOrderTerm + +/-- The «first order term ⁴» construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :max firstOrderTerm "⁴" : firstOrderTerm + +/-- The «first order term⌜ ⌝» construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :max "⌜" term:max "⌝" : firstOrderTerm + +/-- The first order term Exp construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :67 "exp " firstOrderTerm:68 : firstOrderTerm + +macro_rules + | `(quoteterm($type)[$binders* | $fbinders* | ($e)]) => + `(quoteterm($type)[$binders* | $fbinders* | $e]) + +macro_rules + | `(quoteterm(lit)[ $binders* | $fbinders* | $x:ident]) => do + match binders.idxOf? x with + | none => + match fbinders.idxOf? x with + | none => Macro.throwErrorAt x "error: variable did not found." + | some x => + let i := Syntax.mkNumLit (toString x) + `(&$i) + | some x => + let i := Syntax.mkNumLit (toString x) + `(#$i) + | `(quoteterm(lit)[ $_* | $_* | #$x:term ]) => `(#$x) + | `(quoteterm(lit)[ $_* | $_* | &$x:term ]) => `(&$x) + | `(quoteterm(lit)[ $_* | $_* | $m:num ]) => `(Semiterm.numeral $m) + | `(quoteterm(lit)[ $_* | $_* | ↑$m:term ]) => `(Semiterm.numeral $m) + | `(quoteterm(lit)[ $_* | $_* | ⌜$x:term⌝ ]) => `(⌜$x⌝) + | `(quoteterm(lit)[ $_* | $_* | ⋆ ]) => `(Operator.const Operator.Star.star) + | `(quoteterm(lit)[ $binders* | $fbinders* | $e₁ + $e₂ ]) => + `(Semiterm.Operator.Add.add.operator ![quoteterm(lit)[ $binders* | $fbinders* | $e₁ ], + quoteterm(lit)[ $binders* | $fbinders* | $e₂ ]]) + | `(quoteterm(lit)[ $binders* | $fbinders* | $e₁ * $e₂ ]) => + `(Semiterm.Operator.Mul.mul.operator ![quoteterm(lit)[ $binders* | $fbinders* | $e₁ ], + quoteterm(lit)[ $binders* | $fbinders* | $e₂ ]]) + | `(quoteterm(lit)[ $binders* | $fbinders* | $e₁ ^ $e₂ ]) => + `(Semiterm.Operator.Pow.pow.operator ![quoteterm(lit)[ $binders* | $fbinders* | $e₁ ], + quoteterm(lit)[ $binders* | $fbinders* | $e₂ ]]) + | `(quoteterm(lit)[ $binders* | $fbinders* | $e ^' $n ]) => `((Semiterm.Operator.npow _ + $n).operator ![quoteterm(lit)[ $binders* | $fbinders* | $e ]]) + | `(quoteterm(lit)[ $binders* | $fbinders* | $e² ]) => `((Semiterm.Operator.npow _ + 2).operator ![quoteterm(lit)[ $binders* | $fbinders* | $e ]]) + | `(quoteterm(lit)[ $binders* | $fbinders* | $e³ ]) => `((Semiterm.Operator.npow _ + 3).operator ![quoteterm(lit)[ $binders* | $fbinders* | $e ]]) + | `(quoteterm(lit)[ $binders* | $fbinders* | $e⁴ ]) => `((Semiterm.Operator.npow _ + 4).operator ![quoteterm(lit)[ $binders* | $fbinders* | $e ]]) + | `(quoteterm(lit)[ $binders* | $fbinders* | exp $e ]) => + `(Semiterm.Operator.Exp.exp.operator ![quoteterm(lit)[ $binders* | $fbinders* | $e ]]) + | `(quoteterm(lit)[ $_* | $_* | !!$t:term ]) => `($t) + | `(quoteterm(lit)[ $_* | $_* | .!!$t:term ]) => `(Rew.emb $t) + + + + + + + +macro_rules + | `(quoteterm(lit)[$binders* | $fbinders* | !$t:term$vs:firstOrderTerm*]) => do + let v ← + vs.foldrM (β := Lean.TSyntax _) (init := ← `(![])) + (fun a s => `(quoteterm(lit)[$binders* | $fbinders* | $a] :> $s)) + `(Rew.subst $v $t) + | `(quoteterm(lit)[$binders* | $fbinders* | !$t:term$vs:firstOrderTerm* ⋯]) => do + let length := Syntax.mkNumLit (toString binders.size) + let v ← + vs.foldrM (β := Lean.TSyntax _) (init := ← `(fun x ↦ #(finSuccItr x $length))) + (fun a s ↦ `(quoteterm(lit)[$binders* | $fbinders* | $a] :> $s)) + `(Rew.subst $v $t) + | `(quoteterm(lit)[$binders* | $fbinders* | .!$t:term$vs:firstOrderTerm*]) => do + let v ← + vs.foldrM (β := Lean.TSyntax _) (init := ← `(![])) + (fun a s ↦ `(quoteterm(lit)[$binders* | $fbinders* | $a] :> $s)) + `(Rew.embSubsts $v $t) + | `(quoteterm(lit)[$binders* | $fbinders* | .!$t:term$vs:firstOrderTerm* ⋯]) => do + let length := Syntax.mkNumLit (toString binders.size) + let v ← + vs.foldrM (β := Lean.TSyntax _) (init := ← `(fun x ↦ #(finSuccItr x $length))) + (fun a s ↦ `(quoteterm(lit)[$binders* | $fbinders* | $a] :> $s)) + `(Rew.embSubsts $v $t) + +/-- The «term‘ ’» construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax "‘" firstOrderTerm:0 "’" : term + +/-- A term with free variables. -/ +syntax "‘" ident* "| " firstOrderTerm:0 "’" : term + +/-- A term with bound variables. -/ +syntax "‘" ident* ". " firstOrderTerm:0 "’" : term + +macro_rules + | `(‘$e:firstOrderTerm’) => `(quoteterm(lit)[ | | $e]) + | `(‘$fbinders*| $e:firstOrderTerm’) => `(quoteterm(lit)[ | $fbinders* | $e]) + | `(‘$binders*. $e:firstOrderTerm’) => `(quoteterm(lit)[$binders* | | $e]) + +section delab + +/-- The unexpander Nat Lit construction in `FFL.FirstOrder.BinderNotation`. -/ +@[app_unexpander Semiterm.Operator.numeral] +meta def unexpanderNatLit : Unexpander + | `($_ $_ $z:num) => `($z:num) + | _ => throw () + + + + + + + +/-- The unexpander Operator Const construction in `FFL.FirstOrder.BinderNotation`. -/ +@[app_unexpander Semiterm.Operator.const] +meta def unexpanderOperatorConst : Unexpander + | `($_ $z:num) => `(‘ $z:num ’) + | _ => throw () + + + + + + + +/-- The unexpander Add construction in `FFL.FirstOrder.BinderNotation`. -/ +@[app_unexpander Semiterm.Operator.Add.add] +meta def unexpanderAdd : Unexpander + | `($_) => `(op(+)) + +/-- The unexpander Mul construction in `FFL.FirstOrder.BinderNotation`. -/ +@[app_unexpander Semiterm.Operator.Mul.mul] +meta def unexpanderMul : Unexpander + | `($_) => `(op(*)) + +/-- The unexpand Func Arith construction in `FFL.FirstOrder.BinderNotation`. -/ +@[app_unexpander Semiterm.Operator.operator] +meta def unexpandFuncArith : Unexpander + | `($_ op(+) ![‘$t:firstOrderTerm’, ‘$u:firstOrderTerm’ ]) => `(‘($t + $u )’) + | `($_ op(+) ![‘$t:firstOrderTerm’, #$x ]) => `(‘($t + #$x )’) + | `($_ op(+) ![‘$t:firstOrderTerm’, &$x ]) => `(‘($t + &$x )’) + | `($_ op(+) ![‘$t:firstOrderTerm’, ↑$m:num ]) => `(‘($t + $m:num )’) + | `($_ op(+) ![‘$t:firstOrderTerm’, $u:term ]) => `(‘($t + !!$u )’) + | `($_ op(+) ![#$x, ‘$u:firstOrderTerm’ ]) => `(‘(#$x + $u )’) + | `($_ op(+) ![#$x, #$y ]) => `(‘(#$x + #$y )’) + | `($_ op(+) ![#$x, &$y ]) => `(‘(#$x + &$y )’) + | `($_ op(+) ![#$x, ↑$m:num ]) => `(‘(#$x + $m:num )’) + | `($_ op(+) ![#$x, $u ]) => `(‘(#$x + !!$u )’) + | `($_ op(+) ![&$x, ‘$u:firstOrderTerm’ ]) => `(‘(&$x + $u )’) + | `($_ op(+) ![&$x, #$y ]) => `(‘(&$x + #$y )’) + | `($_ op(+) ![&$x, &$y ]) => `(‘(&$x + &$y )’) + | `($_ op(+) ![&$x, ↑$m:num ]) => `(‘(&$x + $m:num )’) + | `($_ op(+) ![&$x, $u ]) => `(‘(&$x + !!$u )’) + | `($_ op(+) ![↑$n:num, ‘$u:firstOrderTerm’ ]) => `(‘($n:num + $u )’) + | `($_ op(+) ![↑$n:num, #$y ]) => `(‘($n:num + #$y )’) + | `($_ op(+) ![↑$n:num, &$y ]) => `(‘($n:num + &$y )’) + | `($_ op(+) ![↑$n:num, ↑$m:num ]) => `(‘($n:num + $m:num )’) + | `($_ op(+) ![↑$n:num, $u ]) => `(‘($n:num + !!$u )’) + | `($_ op(+) ![$t:term, ‘$u:firstOrderTerm’ ]) => `(‘(!!$t + $u )’) + | `($_ op(+) ![$t:term, #$y ]) => `(‘(!!$t + #$y )’) + | `($_ op(+) ![$t:term, &$y ]) => `(‘(!!$t + &$y )’) + | `($_ op(+) ![$t:term, ↑$m:num ]) => `(‘(!!$t + $m:num )’) + | `($_ op(+) ![$t:term, $u ]) => `(‘(!!$t + !!$u )’) + | `($_ op(*) ![‘$t:firstOrderTerm’, ‘$u:firstOrderTerm’ ]) => `(‘($t * $u )’) + | `($_ op(*) ![‘$t:firstOrderTerm’, #$x ]) => `(‘($t * #$x )’) + | `($_ op(*) ![‘$t:firstOrderTerm’, &$x ]) => `(‘($t * &$x )’) + | `($_ op(*) ![‘$t:firstOrderTerm’, ↑$m:num ]) => `(‘($t * $m:num )’) + | `($_ op(*) ![‘$t:firstOrderTerm’, $u:term ]) => `(‘($t * !!$u )’) + | `($_ op(*) ![#$x, ‘$u:firstOrderTerm’ ]) => `(‘(#$x * $u )’) + | `($_ op(*) ![#$x, #$y ]) => `(‘(#$x * #$y )’) + | `($_ op(*) ![#$x, &$y ]) => `(‘(#$x * &$y )’) + | `($_ op(*) ![#$x, ↑$m:num ]) => `(‘(#$x * $m:num )’) + | `($_ op(*) ![#$x, $u ]) => `(‘(#$x * !!$u )’) + | `($_ op(*) ![&$x, ‘$u:firstOrderTerm’ ]) => `(‘(&$x * $u )’) + | `($_ op(*) ![&$x, #$y ]) => `(‘(&$x * #$y )’) + | `($_ op(*) ![&$x, &$y ]) => `(‘(&$x * &$y )’) + | `($_ op(*) ![&$x, ↑$m:num ]) => `(‘(&$x * $m:num )’) + | `($_ op(*) ![&$x, $u ]) => `(‘(&$x * !!$u )’) + | `($_ op(*) ![↑$n:num, ‘$u:firstOrderTerm’ ]) => `(‘($n:num * $u )’) + | `($_ op(*) ![↑$n:num, #$y ]) => `(‘($n:num * #$y )’) + | `($_ op(*) ![↑$n:num, &$y ]) => `(‘($n:num * &$y )’) + | `($_ op(*) ![↑$n:num, ↑$m:num ]) => `(‘($n:num * $m:num )’) + | `($_ op(*) ![↑$n:num, $u ]) => `(‘($n:num * !!$u )’) + | `($_ op(*) ![$t:term, ‘$u:firstOrderTerm’ ]) => `(‘(!!$t * $u )’) + | `($_ op(*) ![$t:term, #$y ]) => `(‘(!!$t * #$y )’) + | `($_ op(*) ![$t:term, &$y ]) => `(‘(!!$t * &$y )’) + | `($_ op(*) ![$t:term, ↑$m:num ]) => `(‘(!!$t * $m:num )’) + | `($_ op(*) ![$t:term, $u ]) => `(‘(!!$t * !!$u )’) + | _ => throw () + + + + + + + +/-- The unexpand Numeral construction in `FFL.FirstOrder.BinderNotation`. -/ +@[app_unexpander Semiterm.numeral] +meta def unexpandNumeral : Unexpander + | `($_ $n:num) => `(‘$n:num’) + | _ => throw () + + + + + + + +end delab + +/-! +### Notation for formulae -/ + +open Semiformula + +/-- The first order formula construction in `Lean.Parser.Category`. -/ +declare_syntax_cat firstOrderFormula + +/-- The «term Quoteformula( )[ | | ]» construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax "quoteformula(" firstOrder.quoteType ")[" ident* " | " ident* " | " firstOrderFormula:0 + "]" : term + +/-- The «first order formula( )» construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax "(" firstOrderFormula ")" : firstOrderFormula + +/-- The «first order formula Of term[ ]» construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :60 "of_term[" firstOrderTerm:61 "]" : firstOrderFormula + +/-- The «first order formula! ⋯» construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :60 "!" term:max firstOrderTerm:61* ("⋯")? : firstOrderFormula + +/-- The first order formula!! construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :60 "!!" term:max : firstOrderFormula + +/-- The ! ⋯» construction in `FFL.FirstOrder.BinderNotation.«firstOrderFormula`. -/ +syntax :60 ".!" term:max firstOrderTerm:61* ("⋯")? : firstOrderFormula + +/-- The !! » construction in `FFL.FirstOrder.BinderNotation.«firstOrderFormula`. -/ +syntax :60 ".!!" term:max : firstOrderFormula + +/-- The «first order formula⊤» construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax "⊤" : firstOrderFormula + +/-- The «first order formula⊥» construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax "⊥" : firstOrderFormula + +/-- The «first order formula ∧ » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :32 firstOrderFormula:33 " ∧ " firstOrderFormula:32 : firstOrderFormula + +/-- The «first order formula ∨ » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :30 firstOrderFormula:31 " ∨ " firstOrderFormula:30 : firstOrderFormula + +/-- The «first order formula¬ » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :max "¬" firstOrderFormula:35 : firstOrderFormula + +/-- The «first order formula → » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :10 firstOrderFormula:9 " → " firstOrderFormula:10 : firstOrderFormula + +/-- The «first order formula ↔ » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :5 firstOrderFormula " ↔ " firstOrderFormula : firstOrderFormula + +/-- The «first order formula⋀ , » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :max "⋀ " ident ", " firstOrderFormula:0 : firstOrderFormula + +/-- The «first order formula⋁ , » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :max "⋁ " ident ", " firstOrderFormula:0 : firstOrderFormula + +/-- The «first order formula⋀ < , » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :max "⋀ " ident " < " term ", " firstOrderFormula:0 : firstOrderFormula + +/-- The «first order formula⋁ < , » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :max "⋁ " ident " < " term ", " firstOrderFormula:0 : firstOrderFormula + +/-- The «first order formula∀ , » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :max "∀ " ident+ ", " firstOrderFormula:0 : firstOrderFormula + +/-- The «first order formula∃ , » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :max "∃ " ident+ ", " firstOrderFormula:0 : firstOrderFormula + +/-- The «first order formula∀¹ » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :max "∀¹ " firstOrderFormula:0 : firstOrderFormula + +/-- The «first order formula∃¹ » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :max "∃¹ " firstOrderFormula:0 : firstOrderFormula + +/-- The «first order formula∀¹[ ] » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :max "∀¹[" firstOrderFormula "] " firstOrderFormula:0 : firstOrderFormula + +/-- The «first order formula∃¹[ ] » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :max "∃¹[" firstOrderFormula "] " firstOrderFormula:0 : firstOrderFormula + +macro_rules + | `(quoteformula($type)[ $binders* | $fbinders* | ($e) ]) => `(quoteformula($type)[ + $binders* | $fbinders* | $e ]) + | `(quoteformula($type)[ $_* | $_* | !!$φ:term ]) => `($φ) + | `(quoteformula($type)[ $_* | $_* | .!!$φ:term ]) => `(Rewriting.emb $φ) + | `(quoteformula($type)[ $_* | $_* | ⊤ ]) => `(⊤) + | `(quoteformula($type)[ $_* | $_* | ⊥ ]) => `(⊥) + | `(quoteformula($type)[ $binders* | $fbinders* | $φ ∧ $ψ ]) => `(@HWedge.hWedge _ _ _ + Wedge.instHWedge quoteformula($type)[ $binders* | $fbinders* | $φ ] quoteformula($type)[ + $binders* | $fbinders* | $ψ ]) + | `(quoteformula($type)[ $binders* | $fbinders* | $φ ∨ $ψ ]) => `(@HVee.hVee _ _ _ + Vee.instHVee quoteformula($type)[ $binders* | $fbinders* | $φ ] quoteformula($type)[ + $binders* | $fbinders* | $ψ ]) + | `(quoteformula($type)[ $binders* | $fbinders* | ¬$φ ]) => `(@HTilde.hTilde _ _ + Tilde.instHTilde quoteformula($type)[ $binders* | $fbinders* | $φ ]) + | `(quoteformula($type)[ $binders* | $fbinders* | $φ → $ψ ]) => `(@HArrow.hArrow _ _ _ + Arrow.instHArrow quoteformula($type)[ $binders* | $fbinders* | $φ ] quoteformula($type)[ + $binders* | $fbinders* | $ψ ]) + | `(quoteformula($type)[ $binders* | $fbinders* | $φ ↔ $ψ ]) => `(quoteformula($type)[ + $binders* | $fbinders* | $φ ] ⇔ₗ quoteformula($type)[ $binders* | $fbinders* | $ψ ]) + | `(quoteformula($type)[ $binders* | $fbinders* | ⋀ $i, $φ ]) => `(Matrix.conj fun $i ↦ + quoteformula($type)[ $binders* | $fbinders* | $φ ]) + | `(quoteformula($type)[ $binders* | $fbinders* | ⋁ $i, $φ ]) => `(Matrix.disj fun $i ↦ + quoteformula($type)[ $binders* | $fbinders* | $φ ]) + | `(quoteformula($type)[ $binders* | $fbinders* | ⋀ $i < $t, $φ ]) => `(conjLt (fun $i ↦ + quoteformula($type)[ $binders* | $fbinders* | $φ ]) $t) + | `(quoteformula($type)[ $binders* | $fbinders* | ⋁ $i < $t, $φ ]) => `(disjLt (fun $i ↦ + quoteformula($type)[ $binders* | $fbinders* | $φ ]) $t) + | `(quoteformula($type)[ $binders* | $fbinders* | ∀ $xs*, $φ ]) => do + let xs := xs.reverse + let binders' : TSyntaxArray `ident ← xs.foldrM + (fun z binders' ↦ do + if binders.elem z then Macro.throwErrorAt z "error: variable is duplicated." else + return binders'.insertIdx 0 z) + binders + let s : TSyntax `term ← xs.size.rec `(quoteformula($type)[ $binders'* | $fbinders* | $φ ]) + (fun _ ψ ↦ ψ >>= fun ψ ↦ `(∀¹ $ψ)) + return s + | `(quoteformula($type)[ $binders* | $fbinders* | ∃ $xs*, $φ ]) => do + let xs := xs.reverse + let binders' : TSyntaxArray `ident ← xs.foldrM + (fun z binders' ↦ do + if binders.elem z then Macro.throwErrorAt z "error: variable is duplicated." else + return binders'.insertIdx 0 z) + binders + let s : TSyntax `term ← xs.size.rec `(quoteformula($type)[ $binders'* | $fbinders* | $φ ]) + (fun _ ψ ↦ ψ >>= fun ψ ↦ `(∃¹ $ψ)) + return s + | `(quoteformula($type)[ $binders* | $fbinders* | ∀¹ $φ ]) => do + let v := mkIdent (Name.mkSimple ("var" ++ toString binders.size)) + let binders' := binders.insertIdx 0 v + `(∀¹ quoteformula($type)[ $binders'* | $fbinders* | $φ ]) + | `(quoteformula($type)[ $binders* | $fbinders* | ∃¹ $φ ]) => do + let v := mkIdent (Name.mkSimple ("var" ++ toString binders.size)) + let binders' := binders.insertIdx 0 v + `(∃¹ quoteformula($type)[ $binders'* | $fbinders* | $φ ]) + | `(quoteformula($type)[ $binders* | $fbinders* | ∀¹[ $φ ] $ψ ]) => do + let v := mkIdent (Name.mkSimple ("var" ++ toString binders.size)) + let binders' := binders.insertIdx 0 v + `(∀¹[quoteformula($type)[ $binders'* | $fbinders* | $φ ]] quoteformula($type)[ $binders'* | + $fbinders* | $ψ ]) + | `(quoteformula($type)[ $binders* | $fbinders* | ∃¹[ $φ ] $ψ ]) => do + let v := mkIdent (Name.mkSimple ("var" ++ toString binders.size)) + let binders' := binders.insertIdx 0 v + `(∃¹[quoteformula($type)[ $binders'* | $fbinders* | $φ ]] quoteformula($type)[ $binders'* | + $fbinders* | $ψ ]) + + + + + + + +/-- A formula in literal notation. For a formula `φ`, write `!φ` to include `φ` in the formula. +Identifiers may be written after `!φ` as its bound variables. + +`⋯` adds enough unnamed bound variables to fill up the arity of `φ`, with indices starting after +the last named identifier. For example, assume `φ` is a `Semiformula L k`, and consider the +formula `“x y z. !φ x y ⋯”`. Here `x`, `y`, and `z` are the bound variables `#0`, `#1`, and `#2` +respectively. Then `!φ x y ⋯` will add `k - 2` new bound variables, and expand to `!φ #0 #1 #3 +#4 ... #(k + 1)`. +-/ +macro_rules + | `(quoteformula(lit)[ $binders* | $fbinders* | !$φ:term $vs:firstOrderTerm* ]) => do + let v ← vs.foldrM (β := Lean.TSyntax _) (init := ← `(![])) (fun a s ↦ `(quoteterm(lit)[ + $binders* | $fbinders* | $a ] :> $s)) + `($φ ↜ $v) + | `(quoteformula(lit)[ $binders* | $fbinders* | !$φ:term $vs:firstOrderTerm* ⋯ ]) => + do + let length := Syntax.mkNumLit (toString binders.size) + let v ← vs.foldrM (β := Lean.TSyntax _) (init := ← `(fun x ↦ #(finSuccItr x $length))) + (fun a s ↦ `(quoteterm(lit)[ $binders* | $fbinders* | $a] :> $s)) + `($φ ↜ $v) + + + + + + + +/-- The «term“ | ”» construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax "“" ident* "| " firstOrderFormula:0 "”" : term + +/-- The ”» construction in `FFL.FirstOrder.BinderNotation.«term“_`. -/ +syntax "“" ident* ". " firstOrderFormula:0 "”" : term + +/-- The «term“ ”» construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax "“" firstOrderFormula:0 "”" : term + +macro_rules + | `(“$e:firstOrderFormula”) => `(quoteformula(lit)[ | | $e]) + | `(“$binders*. $e:firstOrderFormula”) => `(quoteformula(lit)[$binders* | | $e]) + | `(“$fbinders*| $e:firstOrderFormula”) => `(quoteformula(lit)[ | $fbinders* | $e]) + +/-- The «first order formula = » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :45 firstOrderTerm:45 " = " firstOrderTerm:0 : firstOrderFormula + +/-- The «first order formula < » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :45 firstOrderTerm:45 " < " firstOrderTerm:0 : firstOrderFormula + +/-- The «first order formula > » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :45 firstOrderTerm:45 " > " firstOrderTerm:0 : firstOrderFormula + +/-- The «first order formula ≤ » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :45 firstOrderTerm:45 " ≤ " firstOrderTerm:0 : firstOrderFormula + +/-- The «first order formula ≥ » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :45 firstOrderTerm:45 " ≥ " firstOrderTerm:0 : firstOrderFormula + +/-- The «first order formula ∈ » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :45 firstOrderTerm:45 " ∈ " firstOrderTerm:0 : firstOrderFormula + +/-- The «first order formula ∋ » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :45 firstOrderTerm:45 " ∋ " firstOrderTerm:0 : firstOrderFormula + +/-- The «first order formula ≠ » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :45 firstOrderTerm:45 " ≠ " firstOrderTerm:0 : firstOrderFormula + +/-- The «first order formula ≮ » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :45 firstOrderTerm:45 " ≮ " firstOrderTerm:0 : firstOrderFormula + +/-- The «first order formula ≰ » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :45 firstOrderTerm:45 " ≰ " firstOrderTerm:0 : firstOrderFormula + +/-- The «first order formula ∉ » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :45 firstOrderTerm:45 " ∉ " firstOrderTerm:0 : firstOrderFormula + +/-- The «first order formula∀ < , » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :max "∀ " ident " < " firstOrderTerm ", " firstOrderFormula:0 : firstOrderFormula + +/-- The «first order formula∀ ≤ , » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :max "∀ " ident " ≤ " firstOrderTerm ", " firstOrderFormula:0 : firstOrderFormula + +/-- The «first order formula∀ ∈ , » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :max "∀ " ident " ∈ " firstOrderTerm ", " firstOrderFormula:0 : firstOrderFormula + +/-- The «first order formula∃ < , » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :max "∃ " ident " < " firstOrderTerm ", " firstOrderFormula:0 : firstOrderFormula + +/-- The «first order formula∃ ≤ , » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :max "∃ " ident " ≤ " firstOrderTerm ", " firstOrderFormula:0 : firstOrderFormula + +/-- The «first order formula∃ ∈ , » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :max "∃ " ident " ∈ " firstOrderTerm ", " firstOrderFormula:0 : firstOrderFormula + +macro_rules + | `(quoteformula($type)[$binders* | $fbinders* | $t:firstOrderTerm > $u:firstOrderTerm]) => + `(quoteformula($type)[$binders* | $fbinders* | $u:firstOrderTerm < $t:firstOrderTerm]) + | `(quoteformula($type)[$binders* | $fbinders* | $t:firstOrderTerm ≥ $u:firstOrderTerm]) => + `(quoteformula($type)[$binders* | $fbinders* | $u:firstOrderTerm ≤ $t:firstOrderTerm]) + | `(quoteformula($type)[$binders* | $fbinders* | $t:firstOrderTerm ∋ $u:firstOrderTerm]) => + `(quoteformula($type)[$binders* | $fbinders* | $u:firstOrderTerm ∈ $t:firstOrderTerm]) + +macro_rules + | `(quoteformula(lit)[$binders* | $fbinders* | $t:firstOrderTerm = $u:firstOrderTerm]) => + `(Semiformula.Operator.operator Operator.Eq.eq + ![quoteterm(lit)[$binders* | $fbinders* | $t], + quoteterm(lit)[$binders* | $fbinders* | $u]]) + | `(quoteformula(lit)[$binders* | $fbinders* | $t:firstOrderTerm < $u:firstOrderTerm]) => + `(Semiformula.Operator.operator Operator.LT.lt + ![quoteterm(lit)[$binders* | $fbinders* | $t], + quoteterm(lit)[$binders* | $fbinders* | $u]]) + | `(quoteformula(lit)[$binders* | $fbinders* | $t:firstOrderTerm ≤ $u:firstOrderTerm]) => + `(Semiformula.Operator.operator Operator.LE.le + ![quoteterm(lit)[$binders* | $fbinders* | $t], + quoteterm(lit)[$binders* | $fbinders* | $u]]) + | `(quoteformula(lit)[$binders* | $fbinders* | $t:firstOrderTerm ∈ $u:firstOrderTerm]) => + `(Semiformula.Operator.operator Operator.Mem.mem + ![quoteterm(lit)[$binders* | $fbinders* | $t], + quoteterm(lit)[$binders* | $fbinders* | $u]]) + | `(quoteformula(lit)[$binders* | $fbinders* | $t:firstOrderTerm ≠ $u:firstOrderTerm]) => + `(@HTilde.hTilde _ _ Tilde.instHTilde + (Semiformula.Operator.operator Operator.Eq.eq + ![quoteterm(lit)[$binders* | $fbinders* | $t], + quoteterm(lit)[$binders* | $fbinders* | $u]])) + | `(quoteformula(lit)[$binders* | $fbinders* | $t:firstOrderTerm ≮ $u:firstOrderTerm]) => + `(@HTilde.hTilde _ _ Tilde.instHTilde + (Semiformula.Operator.operator Operator.LT.lt + ![quoteterm(lit)[$binders* | $fbinders* | $t], + quoteterm(lit)[$binders* | $fbinders* | $u]])) + | `(quoteformula(lit)[$binders* | $fbinders* | $t:firstOrderTerm ≰ $u:firstOrderTerm]) => + `(@HTilde.hTilde _ _ Tilde.instHTilde + (Semiformula.Operator.operator Operator.LE.le + ![quoteterm(lit)[$binders* | $fbinders* | $t], + quoteterm(lit)[$binders* | $fbinders* | $u]])) + | `(quoteformula(lit)[$binders* | $fbinders* | $t:firstOrderTerm ∉ $u:firstOrderTerm]) => + `(@HTilde.hTilde _ _ Tilde.instHTilde + (Semiformula.Operator.operator Operator.Mem.mem + ![quoteterm(lit)[$binders* | $fbinders* | $t], + quoteterm(lit)[$binders* | $fbinders* | $u]])) + +macro_rules + | `(quoteformula(lit)[$binders* | $fbinders* | ∀ $x < $t, $φ]) => do + if binders.elem x then + Macro.throwErrorAt x "error: variable is duplicated." + else + `(Semiformula.ballLT quoteterm(lit)[$binders* | $fbinders* | $t] + quoteformula(lit)[$x$binders* | $fbinders* | $φ]) + | `(quoteformula(lit)[$binders* | $fbinders* | ∀ $x ≤ $t, $φ]) => do + if binders.elem x then + Macro.throwErrorAt x "error: variable is duplicated." + else + `(Semiformula.ballLE quoteterm(lit)[$binders* | $fbinders* | $t] + quoteformula(lit)[$x$binders* | $fbinders* | $φ]) + | `(quoteformula(lit)[$binders* | $fbinders* | ∀ $x ∈ $t, $φ]) => do + if binders.elem x then + Macro.throwErrorAt x "error: variable is duplicated." + else + `(Semiformula.ballMem quoteterm(lit)[$binders* | $fbinders* | $t] + quoteformula(lit)[$x$binders* | $fbinders* | $φ]) + | `(quoteformula(lit)[$binders* | $fbinders* | ∃ $x < $t, $φ]) => do + if binders.elem x then + Macro.throwErrorAt x "error: variable is duplicated." + else + `(Semiformula.bexsLT quoteterm(lit)[$binders* | $fbinders* | $t] + quoteformula(lit)[$x$binders* | $fbinders* | $φ]) + | `(quoteformula(lit)[$binders* | $fbinders* | ∃ $x ≤ $t, $φ]) => do + if binders.elem x then + Macro.throwErrorAt x "error: variable is duplicated." + else + `(Semiformula.bexsLE quoteterm(lit)[$binders* | $fbinders* | $t] + quoteformula(lit)[$x$binders* | $fbinders* | $φ]) + | `(quoteformula(lit)[$binders* | $fbinders* | ∃ $x ∈ $t, $φ]) => do + if binders.elem x then + Macro.throwErrorAt x "error: variable is duplicated." + else + `(Semiformula.bexsMem quoteterm(lit)[$binders* | $fbinders* | $t] + quoteformula(lit)[$x$binders* | $fbinders* | $φ]) + +section delab + +/-- The unexpander Eq construction in `FFL.FirstOrder.BinderNotation`. -/ +@[app_unexpander Language.Eq.eq] +meta def unexpanderEq : Unexpander + | `($_) => `(op(=)) + +/-- The unexpander Le construction in `FFL.FirstOrder.BinderNotation`. -/ +@[app_unexpander Language.LT.lt] +meta def unexpanderLe : Unexpander + | `($_) => `(op(<)) + +/-- The unexpand And construction in `FFL.FirstOrder.BinderNotation`. -/ +@[app_unexpander Wedge.wedge] +meta def unexpandAnd : Unexpander + | `($_ “ $φ:firstOrderFormula ” “ $ψ:firstOrderFormula ”) => `(“ ($φ ∧ $ψ) ”) + | `($_ “ $φ:firstOrderFormula ” $u:term ) => `(“ ($φ ∧ !$u) ”) + | `($_ $t:term “ $ψ:firstOrderFormula ”) => `(“ (!$t ∧ $ψ) ”) + | _ => throw () + + + + + + + +/-- The unexpand Or construction in `FFL.FirstOrder.BinderNotation`. -/ +@[app_unexpander Vee.vee] +meta def unexpandOr : Unexpander + | `($_ “ $φ:firstOrderFormula ” “ $ψ:firstOrderFormula ”) => `(“ ($φ ∨ $ψ) ”) + | `($_ “ $φ:firstOrderFormula ” $u:term ) => `(“ ($φ ∨ !$u) ”) + | `($_ $t:term “ $ψ:firstOrderFormula ”) => `(“ (!$t ∨ $ψ) ”) + | _ => throw () + + + + + + + +/-- The unexpand Neg construction in `FFL.FirstOrder.BinderNotation`. -/ +@[app_unexpander Tilde.tilde] +meta def unexpandNeg : Unexpander + | `($_ “ $φ:firstOrderFormula ”) => `(“ ¬$φ ”) + | _ => throw () + + + + + + + +/-- The unexpand Univ construction in `FFL.FirstOrder.BinderNotation`. -/ +@[app_unexpander UnivQuantifier.all] +meta def unexpandUniv : Unexpander + | `($_ “ $φ:firstOrderFormula ”) => `(“ ∀¹ $φ:firstOrderFormula ”) + | _ => throw () + + + + + + + +/-- The unexpand Ex construction in `FFL.FirstOrder.BinderNotation`. -/ +@[app_unexpander ExsQuantifier.exs] +meta def unexpandEx : Unexpander + | `($_ “ $φ:firstOrderFormula”) => `(“ ∃¹ $φ:firstOrderFormula ”) + | _ => throw () + + + + + + + +/-- The unexpand Ball construction in `FFL.FirstOrder.BinderNotation`. -/ +@[app_unexpander ball] +meta def unexpandBall : Unexpander + | `($_ “ $φ:firstOrderFormula ” “ $ψ:firstOrderFormula ”) => `(“ (∀¹[$φ] $ψ) ”) + | `($_ “ $φ:firstOrderFormula ” $u:term ) => `(“ (∀¹[$φ] !$u) ”) + | `($_ $t:term “ $ψ:firstOrderFormula ”) => `(“ (∀¹[!$t] $ψ) ”) + | _ => throw () + + + + + + + +/-- The unexpand Bex construction in `FFL.FirstOrder.BinderNotation`. -/ +@[app_unexpander bexs] +meta def unexpandBex : Unexpander + | `($_ “ $φ:firstOrderFormula ” “ $ψ:firstOrderFormula ”) => `(“ (∃¹[$φ] $ψ) ”) + | `($_ “ $φ:firstOrderFormula ” $u:term ) => `(“ (∃¹[$φ] !$u) ”) + | `($_ $t:term “ $ψ:firstOrderFormula ”) => `(“ (∃¹[!$t] $ψ) ”) + | _ => throw () + + + + + + + +/-- The unexpand Arrow construction in `FFL.FirstOrder.BinderNotation`. -/ +@[app_unexpander Arrow.arrow] +meta def unexpandArrow : Unexpander + | `($_ “ $φ:firstOrderFormula ” “ $ψ:firstOrderFormula”) => `(“ ($φ → $ψ) ”) + | `($_ “ $φ:firstOrderFormula ” $u:term ) => `(“ ($φ → !$u) ”) + | `($_ $t:term “ $ψ:firstOrderFormula”) => `(“ (!$t → $ψ) ”) + | _ => throw () + + + + + + + +/-- The unexpand Iff construction in `FFL.FirstOrder.BinderNotation`. -/ +@[app_unexpander LogicalConnective.iff] +meta def unexpandIff : Unexpander + | `($_ “ $φ:firstOrderFormula” “ $ψ:firstOrderFormula”) => `(“ ($φ ↔ $ψ) ”) + | `($_ “ $φ:firstOrderFormula” $u:term ) => `(“ ($φ ↔ !$u) ”) + | `($_ $t:term “ $ψ:firstOrderFormula”) => `(“ (!$t ↔ $ψ) ”) + | _ => throw () + + + + + + + +/-- The unexpand Op Arith construction in `FFL.FirstOrder.BinderNotation`. -/ +@[app_unexpander Semiformula.Operator.operator] +meta def unexpandOpArith : Unexpander + | `($_ op(=) ![‘ $t:firstOrderTerm ’, ‘ $u:firstOrderTerm ’]) => `(“ $t:firstOrderTerm = $u + ”) + | `($_ op(=) ![‘ $t:firstOrderTerm ’, #$y:term ]) => `(“ $t:firstOrderTerm = + #$y ”) + | `($_ op(=) ![‘ $t:firstOrderTerm ’, &$y:term ]) => `(“ $t:firstOrderTerm = + &$y ”) + | `($_ op(=) ![‘ $t:firstOrderTerm ’, ↑$m:num ]) => `(“ $t:firstOrderTerm = + $m:num ”) + | `($_ op(=) ![‘ $t:firstOrderTerm ’, $u ]) => `(“ $t:firstOrderTerm = + !!$u ”) + | `($_ op(=) ![#$x:term, ‘ $u:firstOrderTerm ’]) => `(“ #$x = + $u ”) + | `($_ op(=) ![#$x:term, #$y:term ]) => `(“ #$x + = #$y ”) + | `($_ op(=) ![#$x:term, &$y:term ]) => `(“ #$x + = &$y ”) + | `($_ op(=) ![#$x:term, ↑$m:num ]) => `(“ #$x + = $m:num ”) + | `($_ op(=) ![#$x:term, $u ]) => `(“ #$x + = !!$u ”) + | `($_ op(=) ![&$x:term, ‘ $u:firstOrderTerm ’]) => `(“ &$x = + $u ”) + | `($_ op(=) ![&$x:term, #$y:term ]) => `(“ &$x + = #$y ”) + | `($_ op(=) ![&$x:term, &$y:term ]) => `(“ &$x + = &$y ”) + | `($_ op(=) ![&$x:term, ↑$m:num ]) => `(“ &$x + = $m:num ”) + | `($_ op(=) ![&$x:term, $u ]) => `(“ &$x + = !!$u ”) + | `($_ op(=) ![↑$n:num, ‘ $u:firstOrderTerm ’]) => `(“ $n:num = + $u ”) + | `($_ op(=) ![↑$n:num, #$y:term ]) => `(“ $n:num + = #$y ”) + | `($_ op(=) ![↑$n:num, &$y:term ]) => `(“ $n:num + = &$y ”) + | `($_ op(=) ![↑$n:num, ↑$m:num ]) => `(“ $n:num + = $m:num ”) + | `($_ op(=) ![↑$n:num, $u ]) => `(“ $n:num + = !!$u ”) + | `($_ op(=) ![$t:term, ‘ $u:firstOrderTerm ’]) => `(“ !!$t = + $u ”) + | `($_ op(=) ![$t:term, #$y:term ]) => `(“ !!$t + = #$y ”) + | `($_ op(=) ![$t:term, &$y:term ]) => `(“ !!$t + = &$y ”) + | `($_ op(=) ![$t:term, ↑$m:num ]) => `(“ !!$t + = $m:num ”) + | `($_ op(=) ![$t:term, $u ]) => `(“ !!$t + = !!$u ”) + | `($_ op(<) ![‘ $t:firstOrderTerm ’, ‘ $u:firstOrderTerm ’]) => `(“ $t:firstOrderTerm < $u + ”) + | `($_ op(<) ![‘ $t:firstOrderTerm ’, #$y:term ]) => `(“ $t:firstOrderTerm < + #$y ”) + | `($_ op(<) ![‘ $t:firstOrderTerm ’, &$y:term ]) => `(“ $t:firstOrderTerm < + &$y ”) + | `($_ op(<) ![‘ $t:firstOrderTerm ’, ↑$m:num ]) => `(“ $t:firstOrderTerm < + $m:num ”) + | `($_ op(<) ![‘ $t:firstOrderTerm ’, $u ]) => `(“ $t:firstOrderTerm < + !!$u ”) + | `($_ op(<) ![#$x:term, ‘ $u:firstOrderTerm ’]) => `(“ #$x < + $u ”) + | `($_ op(<) ![#$x:term, #$y:term ]) => `(“ #$x + < #$y ”) + | `($_ op(<) ![#$x:term, &$y:term ]) => `(“ #$x + < &$y ”) + | `($_ op(<) ![#$x:term, ↑$m:num ]) => `(“ #$x + < $m:num ”) + | `($_ op(<) ![#$x:term, $u ]) => `(“ #$x + < !!$u ”) + | `($_ op(<) ![&$x:term, ‘ $u:firstOrderTerm ’]) => `(“ &$x < + $u ”) + | `($_ op(<) ![&$x:term, #$y:term ]) => `(“ &$x + < #$y ”) + | `($_ op(<) ![&$x:term, &$y:term ]) => `(“ &$x + < &$y ”) + | `($_ op(<) ![&$x:term, ↑$m:num ]) => `(“ &$x + < $m:num ”) + | `($_ op(<) ![&$x:term, $u ]) => `(“ &$x + < !!$u ”) + | `($_ op(<) ![↑$n:num, ‘ $u:firstOrderTerm ’]) => `(“ $n:num < + $u ”) + | `($_ op(<) ![↑$n:num, #$y:term ]) => `(“ $n:num + < #$y ”) + | `($_ op(<) ![↑$n:num, &$y:term ]) => `(“ $n:num + < &$y ”) + | `($_ op(<) ![↑$n:num, ↑$m:num ]) => `(“ $n:num + < $m:num ”) + | `($_ op(<) ![↑$n:num, $u ]) => `(“ $n:num + < !!$u ”) + | `($_ op(<) ![$t:term, ‘ $u:firstOrderTerm ’]) => `(“ !!$t < + $u ”) + | `($_ op(<) ![$t:term, #$y:term ]) => `(“ !!$t + < #$y ”) + | `($_ op(<) ![$t:term, &$y:term ]) => `(“ !!$t + < &$y ”) + | `($_ op(<) ![$t:term, ↑$m:num ]) => `(“ !!$t + < $m:num ”) + | `($_ op(<) ![$t:term, $u ]) => `(“ !!$t + < !!$u ”) + | `($_ op(≤) ![‘ $t:firstOrderTerm ’, ‘ $u:firstOrderTerm ’]) => `(“ $t:firstOrderTerm ≤ $u + ”) + | `($_ op(≤) ![‘ $t:firstOrderTerm ’, #$y:term ]) => `(“ $t:firstOrderTerm ≤ + #$y ”) + | `($_ op(≤) ![‘ $t:firstOrderTerm ’, &$y:term ]) => `(“ $t:firstOrderTerm ≤ + &$y ”) + | `($_ op(≤) ![‘ $t:firstOrderTerm ’, ↑$m:num ]) => `(“ $t:firstOrderTerm ≤ + $m:num ”) + | `($_ op(≤) ![‘ $t:firstOrderTerm ’, $u ]) => `(“ $t:firstOrderTerm ≤ + !!$u ”) + | `($_ op(≤) ![#$x:term, ‘ $u:firstOrderTerm ’]) => `(“ #$x ≤ + $u ”) + | `($_ op(≤) ![#$x:term, #$y:term ]) => `(“ #$x + ≤ #$y ”) + | `($_ op(≤) ![#$x:term, &$y:term ]) => `(“ #$x + ≤ &$y ”) + | `($_ op(≤) ![#$x:term, ↑$m:num ]) => `(“ #$x + ≤ $m:num ”) + | `($_ op(≤) ![#$x:term, $u ]) => `(“ #$x + ≤ !!$u ”) + | `($_ op(≤) ![&$x:term, ‘ $u:firstOrderTerm ’]) => `(“ &$x ≤ + $u ”) + | `($_ op(≤) ![&$x:term, #$y:term ]) => `(“ &$x + ≤ #$y ”) + | `($_ op(≤) ![&$x:term, &$y:term ]) => `(“ &$x + ≤ &$y ”) + | `($_ op(≤) ![&$x:term, ↑$m:num ]) => `(“ &$x + ≤ $m:num ”) + | `($_ op(≤) ![&$x:term, $u ]) => `(“ &$x + ≤ !!$u ”) + | `($_ op(≤) ![↑$n:num, ‘ $u:firstOrderTerm ’]) => `(“ $n:num ≤ + $u ”) + | `($_ op(≤) ![↑$n:num, #$y:term ]) => `(“ $n:num + ≤ #$y ”) + | `($_ op(≤) ![↑$n:num, &$y:term ]) => `(“ $n:num + ≤ &$y ”) + | `($_ op(≤) ![↑$n:num, ↑$m:num ]) => `(“ $n:num + ≤ $m:num ”) + | `($_ op(≤) ![↑$n:num, $u ]) => `(“ $n:num + ≤ !!$u ”) + | `($_ op(≤) ![$t:term, ‘ $u:firstOrderTerm ’]) => `(“ !!$t ≤ + $u ”) + | `($_ op(≤) ![$t:term, #$y:term ]) => `(“ !!$t + ≤ #$y ”) + | `($_ op(≤) ![$t:term, &$y:term ]) => `(“ !!$t + ≤ &$y ”) + | `($_ op(≤) ![$t:term, ↑$m:num ]) => `(“ !!$t + ≤ $m:num ”) + | `($_ op(≤) ![$t:term, $u ]) => `(“ !!$t + ≤ !!$u ”) + | `($_ op(∈) ![‘ $t:firstOrderTerm ’, ‘ $u:firstOrderTerm ’]) => `(“ $t:firstOrderTerm ∈ $u + ”) + | `($_ op(∈) ![‘ $t:firstOrderTerm ’, #$y:term ]) => `(“ $t:firstOrderTerm ∈ + #$y ”) + | `($_ op(∈) ![‘ $t:firstOrderTerm ’, &$y:term ]) => `(“ $t:firstOrderTerm ∈ + &$y ”) + | `($_ op(∈) ![‘ $t:firstOrderTerm ’, ↑$m:num ]) => `(“ $t:firstOrderTerm ∈ + $m:num ”) + | `($_ op(∈) ![‘ $t:firstOrderTerm ’, $u ]) => `(“ $t:firstOrderTerm ∈ + !!$u ”) + | `($_ op(∈) ![#$x:term, ‘ $u:firstOrderTerm ’]) => `(“ #$x ∈ + $u ”) + | `($_ op(∈) ![#$x:term, #$y:term ]) => `(“ #$x + ∈ #$y ”) + | `($_ op(∈) ![#$x:term, &$y:term ]) => `(“ #$x + ∈ &$y ”) + | `($_ op(∈) ![#$x:term, ↑$m:num ]) => `(“ #$x + ∈ $m:num ”) + | `($_ op(∈) ![#$x:term, $u ]) => `(“ #$x + ∈ !!$u ”) + | `($_ op(∈) ![&$x:term, ‘ $u:firstOrderTerm ’]) => `(“ &$x ∈ + $u ”) + | `($_ op(∈) ![&$x:term, #$y:term ]) => `(“ &$x + ∈ #$y ”) + | `($_ op(∈) ![&$x:term, &$y:term ]) => `(“ &$x + ∈ &$y ”) + | `($_ op(∈) ![&$x:term, ↑$m:num ]) => `(“ &$x + ∈ $m:num ”) + | `($_ op(∈) ![&$x:term, $u ]) => `(“ &$x + ∈ !!$u ”) + | `($_ op(∈) ![↑$n:num, ‘ $u:firstOrderTerm ’]) => `(“ $n:num ∈ + $u ”) + | `($_ op(∈) ![↑$n:num, #$y:term ]) => `(“ $n:num + ∈ #$y ”) + | `($_ op(∈) ![↑$n:num, &$y:term ]) => `(“ $n:num + ∈ &$y ”) + | `($_ op(∈) ![↑$n:num, ↑$m:num ]) => `(“ $n:num + ∈ $m:num ”) + | `($_ op(∈) ![↑$n:num, $u ]) => `(“ $n:num + ∈ !!$u ”) + | `($_ op(∈) ![$t:term, ‘ $u:firstOrderTerm ’]) => `(“ !!$t ∈ + $u ”) + | `($_ op(∈) ![$t:term, #$y:term ]) => `(“ !!$t + ∈ #$y ”) + | `($_ op(∈) ![$t:term, &$y:term ]) => `(“ !!$t + ∈ &$y ”) + | `($_ op(∈) ![$t:term, ↑$m:num ]) => `(“ !!$t + ∈ $m:num ”) + | `($_ op(∈) ![$t:term, $u ]) => `(“ !!$t + ∈ !!$u ”) + | _ => throw () + + + + + + + +end delab + +/-! +### Notation for formula as term -/ + +macro_rules + | `(quoteformula(faf)[$binders* | $fbinders* | !$φ:term$vs:firstOrderTerm*]) => do + let Ψ ← + vs.foldrM (β := Lean.TSyntax _) (init := ← `(![])) fun a s ↦ do + let x : TSyntax `ident ← PointwiseComposition.Lean.TSyntax.freshIdent + `(quoteterm(faf)[$x$binders* | $fbinders* | $a] :> $s) + `(($φ).nestFormulae $Ψ) + | `(quoteformula(faf)[$binders* | $fbinders* | !$φ:term$vs:firstOrderTerm*⋯]) => do + let length := Syntax.mkNumLit (toString binders.size) + let Ψ ← + vs.foldrM (β := Lean.TSyntax _) (init := ← `(fun x ↦ #(finSuccItr x $length))) fun a s ↦ + do + let x : TSyntax `ident ← PointwiseComposition.Lean.TSyntax.freshIdent + `(quoteterm(faf)[$x$binders* | $fbinders* | $a] :> $s) + `(($φ).nestFormulae $Ψ) + +macro_rules + | `(quoteterm(faf)[$binders* | $fbinders* | $x:ident]) => do + match binders.idxOf? x with + | none => + match fbinders.idxOf? x with + | none => + Macro.throwErrorAt x "error: variable does not appeared." + | some x => + let i := Syntax.mkNumLit (toString x) + `(“#0 = &$i”) + | some x => + let i := Syntax.mkNumLit (toString x) + `(“#0 = #$i”) + | `(quoteterm(faf)[$binders* | $fbinders* | !$f:term$vs:firstOrderTerm*]) => do + let Ψ ← + vs.foldrM (β := Lean.TSyntax _) (init := ← `(![])) fun a s ↦ do + `(quoteterm(faf)[$binders* | $fbinders* | $a] :> $s) + `(($f).nestFormulaeFunc $Ψ) + | `(quoteterm(faf)[$binders* | $fbinders* | !$f:term$vs:firstOrderTerm* ⋯]) => do + let length := Syntax.mkNumLit (toString binders.size) + let Ψ ← + vs.foldrM (β := Lean.TSyntax _) (init := ← `(fun x ↦ “#0 = #(finSuccItr x $length)”)) + fun a s ↦ do + `(quoteterm(faf)[$binders* | $fbinders* | $a] :> $s) + `(($f).nestFormulaeFunc $Ψ) + +macro_rules + | `(quoteformula(faf)[$binders* | $fbinders* | $t:firstOrderTerm = $u:firstOrderTerm]) => do + let x₁ : TSyntax `ident ← PointwiseComposition.Lean.TSyntax.freshIdent + let x₂ : TSyntax `ident ← PointwiseComposition.Lean.TSyntax.freshIdent + `(∀¹ + (quoteterm(faf)[$x₁$binders* | $fbinders* | $t] ⇒ₗ + ∀¹ (quoteterm(faf)[$x₁$x₂$binders* | $fbinders* | $u] ⇒ₗ (“#1 = #0”)))) + | `(quoteformula(faf)[$binders* | $fbinders* | $t:firstOrderTerm ≠ $u:firstOrderTerm]) => do + let x₁ : TSyntax `ident ← PointwiseComposition.Lean.TSyntax.freshIdent + let x₂ : TSyntax `ident ← PointwiseComposition.Lean.TSyntax.freshIdent + `(∀¹ + (quoteterm(faf)[$x₁$binders* | $fbinders* | $t] ⇒ₗ + ∀¹ (quoteterm(faf)[$x₁$x₂$binders* | $fbinders* | $u] ⇒ₗ (“#1 ≠ #0”)))) + | `(quoteformula(faf)[$binders* | $fbinders* | $t:firstOrderTerm < $u:firstOrderTerm]) => do + let x₁ : TSyntax `ident ← PointwiseComposition.Lean.TSyntax.freshIdent + let x₂ : TSyntax `ident ← PointwiseComposition.Lean.TSyntax.freshIdent + `(∀¹ + (quoteterm(faf)[$x₁$binders* | $fbinders* | $t] ⇒ₗ + ∀¹ (quoteterm(faf)[$x₁$x₂$binders* | $fbinders* | $u] ⇒ₗ (“#1 < #0”)))) + | `(quoteformula(faf)[$binders* | $fbinders* | $t:firstOrderTerm ≮ $u:firstOrderTerm]) => do + let x₁ : TSyntax `ident ← PointwiseComposition.Lean.TSyntax.freshIdent + let x₂ : TSyntax `ident ← PointwiseComposition.Lean.TSyntax.freshIdent + `(∀¹ + (quoteterm(faf)[$x₁$binders* | $fbinders* | $t] ⇒ₗ + ∀¹ (quoteterm(faf)[$x₁$x₂$binders* | $fbinders* | $u] ⇒ₗ (“#1 ≮ #0”)))) + | `(quoteformula(faf)[$binders* | $fbinders* | $t:firstOrderTerm ≤ $u:firstOrderTerm]) => do + let x₁ : TSyntax `ident ← PointwiseComposition.Lean.TSyntax.freshIdent + let x₂ : TSyntax `ident ← PointwiseComposition.Lean.TSyntax.freshIdent + `(∀¹ + (quoteterm(faf)[$x₁$binders* | $fbinders* | $t] ⇒ₗ + ∀¹ (quoteterm(faf)[$x₁$x₂$binders* | $fbinders* | $u] ⇒ₗ (“#1 ≤ #0”)))) + | `(quoteformula(faf)[$binders* | $fbinders* | $t:firstOrderTerm ≰ $u:firstOrderTerm]) => do + let x₁ : TSyntax `ident ← PointwiseComposition.Lean.TSyntax.freshIdent + let x₂ : TSyntax `ident ← PointwiseComposition.Lean.TSyntax.freshIdent + `(∀¹ + (quoteterm(faf)[$x₁$binders* | $fbinders* | $t] ⇒ₗ + ∀¹ (quoteterm(faf)[$x₁$x₂$binders* | $fbinders* | $u] ⇒ₗ (“#1 ≰ #0”)))) + | `(quoteformula(faf)[$binders* | $fbinders* | $t:firstOrderTerm ∈ $u:firstOrderTerm]) => do + let x₁ : TSyntax `ident ← PointwiseComposition.Lean.TSyntax.freshIdent + let x₂ : TSyntax `ident ← PointwiseComposition.Lean.TSyntax.freshIdent + `(∀¹ + (quoteterm(faf)[$x₁$binders* | $fbinders* | $t] ⇒ₗ + ∀¹ (quoteterm(faf)[$x₁$x₂$binders* | $fbinders* | $u] ⇒ₗ (“#1 ∈ #0”)))) + | `(quoteformula(faf)[$binders* | $fbinders* | $t:firstOrderTerm ∉ $u:firstOrderTerm]) => do + let x₁ : TSyntax `ident ← PointwiseComposition.Lean.TSyntax.freshIdent + let x₂ : TSyntax `ident ← PointwiseComposition.Lean.TSyntax.freshIdent + `(∀¹ + (quoteterm(faf)[$x₁$binders* | $fbinders* | $t] ⇒ₗ + ∀¹ (quoteterm(faf)[$x₁$x₂$binders* | $fbinders* | $u] ⇒ₗ (“#1 ∉ #0”)))) + +macro_rules + | `(quoteformula(faf)[$binders* | $fbinders* | ∀ $x < $t, $φ]) => do + if binders.elem x then + Macro.throwErrorAt x "error: variable is duplicated." + else + let vt : TSyntax `ident ← PointwiseComposition.Lean.TSyntax.freshIdent + `(∀¹ + (quoteterm(faf)[$vt$binders* | $fbinders* | $t] ⇒ₗ + Semiformula.ballLT #0 quoteformula(faf)[$x$vt$binders* | $fbinders* | $φ])) + | `(quoteformula(faf)[$binders* | $fbinders* | ∀ $x ≤ $t, $φ]) => do + if binders.elem x then + Macro.throwErrorAt x "error: variable is duplicated." + else + let vt : TSyntax `ident ← PointwiseComposition.Lean.TSyntax.freshIdent + `(∀¹ + (quoteterm(faf)[$vt$binders* | $fbinders* | $t] ⇒ₗ + Semiformula.ballLE #0 quoteformula(faf)[$x$binders* | $fbinders* | $φ])) + | `(quoteformula(faf)[$binders* | $fbinders* | ∀ $x ∈ $t, $φ]) => do + if binders.elem x then + Macro.throwErrorAt x "error: variable is duplicated." + else + let vt : TSyntax `ident ← PointwiseComposition.Lean.TSyntax.freshIdent + `(∀¹ + (quoteterm(faf)[$vt$binders* | $fbinders* | $t] ⇒ₗ + Semiformula.ballMem #0 quoteformula(faf)[$x$vt$binders* | $fbinders* | $φ])) + | `(quoteformula(faf)[$binders* | $fbinders* | ∃ $x < $t, $φ]) => do + if binders.elem x then + Macro.throwErrorAt x "error: variable is duplicated." + else + let vt : TSyntax `ident ← PointwiseComposition.Lean.TSyntax.freshIdent + `(∀¹ + (quoteterm(faf)[$vt$binders* | $fbinders* | $t] ⇒ₗ + Semiformula.bexsLT #0 quoteformula(faf)[$x$vt$binders* | $fbinders* | $φ])) + | `(quoteformula(faf)[$binders* | $fbinders* | ∃ $x ≤ $t, $φ]) => do + if binders.elem x then + Macro.throwErrorAt x "error: variable is duplicated." + else + let vt : TSyntax `ident ← PointwiseComposition.Lean.TSyntax.freshIdent + `(∀¹ + (quoteterm(faf)[$vt$binders* | $fbinders* | $t] ⇒ₗ + Semiformula.bexsLE #0 quoteformula(faf)[$x$vt$binders* | $fbinders* | $φ])) + | `(quoteformula(faf)[$binders* | $fbinders* | ∃ $x ∈ $t, $φ]) => do + if binders.elem x then + Macro.throwErrorAt x "error: variable is duplicated." + else + let vt : TSyntax `ident ← PointwiseComposition.Lean.TSyntax.freshIdent + `(∀¹ + (quoteterm(faf)[$vt$binders* | $fbinders* | $t] ⇒ₗ + Semiformula.bexsMem #0 quoteformula(faf)[$x$vt$binders* | $fbinders* | $φ])) + +/-- The «term F‘ ’» construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax "f‘" firstOrderTerm:0 "’" : term + +/-- The «term F‘ | ’» construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax "f‘" ident* "| " firstOrderTerm:0 "’" : term + +/-- The ’» construction in `FFL.FirstOrder.BinderNotation.«termF‘_`. -/ +syntax "f‘" ident* ". " firstOrderTerm:0 "’" : term + +macro_rules + | `(f‘$e:firstOrderTerm’) => `(quoteterm(faf)[ | | $e]) + | `(f‘$fbinders*| $e:firstOrderTerm’) => `(quoteterm(faf)[ | $fbinders* | $e]) + | `(f‘$binders*. $e:firstOrderTerm’) => `(quoteterm(faf)[$binders* | | $e]) + +/-- The «term F“ | ”» construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax "f“" ident* "| " firstOrderFormula:0 "”" : term + +/-- The ”» construction in `FFL.FirstOrder.BinderNotation.«termF“_`. -/ +syntax "f“" ident* ". " firstOrderFormula:0 "”" : term + +/-- The «term F“ ”» construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax "f“" firstOrderFormula:0 "”" : term + +/-- +A formula in formula-as-function notation. Use `f“⋯. ⋯”` for bound variables, and `f“⋯ | ⋯”` for +free variables. -/ +macro_rules + | `(f“$e:firstOrderFormula”) => `(quoteformula(faf)[ | | $e]) + | `(f“$fbinders*| $e:firstOrderFormula”) => `(quoteformula(faf)[ | $fbinders* | $e]) + | `(f“$binders*. $e:firstOrderFormula”) => `(quoteformula(faf)[$binders* | | $e]) + +end BinderNotation + +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Classical/BinderSemantics.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Classical/BinderSemantics.lean new file mode 100644 index 000000000..ac7c86afa --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Classical/BinderSemantics.lean @@ -0,0 +1,212 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Tarski.Operator +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Fin.Matrix + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace FFL +namespace FirstOrder + +namespace Semiformula + +variable {L : Language} {ξ : Type*} + +/-- +`nestFormulae φ(x₁,…,xₙ) ![Ψ₁(x₁,y₁,…,yₘ), …, Ψₙ(xₙ,y₁,…,yₘ)]` is the formula `∀ x₁, …, xₙ +((Ψ₁(x₁,y₁,…,yₘ) ∧ … ∧ Ψₙ(xₙ,y₁,…,yₘ)) → φ(x₁,…,xₙ))`. + +Here, each formula `Ψᵢ` has `m + 1` bound variables, one for expressing a predicate of an `xᵢ`, +and `m` remaining ones. In the resulting formula, the bound variables are the `m` remaining +bound variables, while all of the original `n` bound variables of `φ` get bounded to a `∀` +quantifier. + +Intuitively, nestFormulae gives `R(f₁(y₁,…,yₘ), …, fₙ(y₁,…,yₘ))`, the result of substituting +functions `f₁, … fₙ` into a relation `R`, using the defining formulae of their graphs (`xᵢ = +fᵢ(y₁,…,yₘ)` iff `Ψᵢ(xᵢ,y₁,…,yₘ)`, and `R(x₁,…,xₙ)` iff `φ(x₁,…,xₙ)`). -/ +def nestFormulae (φ : Semiformula L ξ n) (Ψ : Fin n → Semiformula L ξ (m + 1)) : + Semiformula L ξ m := + let σ : Semiformula L ξ (m + n) := + (Matrix.conj fun i : Fin n ↦ + Rewriting.subst (Ψ i) (#((Fin.addCast m i)) :> fun j ↦ #(j.addNat n))) ⇒ₗ + Rewriting.subst φ fun i ↦ #((Fin.addCast m i)) + ∀¹^[n] σ + +/-- +`nestFormulaeFunc φ(x,x₁,…,xₙ) ![Ψ₁(x₁,y₁,…,yₘ), …, Ψₙ(xₙ,y₁,…,yₘ)]` is the formula `∀ x₁, …, xₙ +((Ψ₁(x₁,y₁,…,yₘ) ∧ … ∧ Ψₙ(xₙ,y₁,…,yₘ)) → φ(x,x₁,…,xₙ))`. + +Here, each formula `Ψᵢ` has `m + 1` bound variables, one for expressing a predicate of an `xᵢ`, +and `m` remaining ones. In the resulting formula, the bound variables are the `m` remaining +bound variables plus `x`, while all of the original bound variables `x₁,…,xₙ` get bounded to a +`∀` quantifier. + +Intuitively, nestFormulaeFunc gives `F(f₁(y₁,…,yₘ), …, fₙ(y₁,…,yₘ))`, the result of substituting +functions `f₁, … fₙ` into a function `F`, using the defining formulae of their graphs (`xᵢ = +fᵢ(y₁,…,yₘ)` iff `Ψᵢ(xᵢ,y₁,…,yₘ)`, and `x = F(x₁,…,xₙ)` iff `φ(x,x₁,…,xₙ)`). -/ +def nestFormulaeFunc (φ : Semiformula L ξ (n + 1)) (Ψ : Fin n → Semiformula L ξ (m + 1)) : + Semiformula L ξ (m + 1) := + let σ : Semiformula L ξ ((m + 1) + n) := + (Matrix.conj fun i : Fin n ↦ + Rewriting.subst (Ψ i) (#((Fin.addCast m.succ i)) :> fun j ↦ #(j.succ.addNat n))) ⇒ₗ + Rewriting.subst φ (#((0 : Fin (m + 1)).addNat n) :> fun i ↦ #((Fin.addCast m.succ i))) + ∀¹^[n] σ + +variable {M : Type*} [s : Tarski.Structure L M] {f : ξ → M} + +lemma eval_nestFormulae {φ : Semiformula L ξ n} {Ψ : Fin n → Semiformula L ξ (m + 1)} : + Eval e f (φ.nestFormulae Ψ) ↔ + ∀ v : Fin n → M, (∀ i, Eval (v i :> e) f (Ψ i)) → Eval v f φ := + by simp [nestFormulae, Matrix.comp_vecCons', Function.comp_def] + +@[simp] +lemma eval_nestFormulae₀ {φ : Semiformula L ξ 0} : + Eval e f (φ.nestFormulae ![]) ↔ Eval ![] f φ := by simp [eval_nestFormulae, Matrix.empty_eq] + +@[simp] +lemma eval_nestFormulae₁ {φ : Semiformula L ξ 1} {ψ : Semiformula L ξ (m + 1)} : + Eval e f (φ.nestFormulae ![ψ]) ↔ ∀ x : M, Eval (x :> e) f ψ → Eval ![x] f φ := by + simp [eval_nestFormulae, Matrix.vecForall_iff, Matrix.empty_eq] + +@[simp] +lemma eval_nestFormulae₂ {φ : Semiformula L ξ 2} {ψ₁ ψ₂ : Semiformula L ξ (m + 1)} : + Eval e f (φ.nestFormulae ![ψ₁, ψ₂]) ↔ + ∀ x₁, Eval (x₁ :> e) f ψ₁ → ∀ x₂, Eval (x₂ :> e) f ψ₂ → Eval ![x₁, x₂] f φ := + by + suffices + (∀ x₁ x₂, Eval (x₁ :> e) f ψ₁ → Eval (x₂ :> e) f ψ₂ → Eval ![x₁, x₂] f φ) ↔ + ∀ x₁, Eval (x₁ :> e) f ψ₁ → ∀ x₂, Eval (x₂ :> e) f ψ₂ → Eval ![x₁, x₂] f φ + by simpa [eval_nestFormulae, Matrix.vecForall_iff, Matrix.empty_eq, Fin.forall_fin_two] + grind + +@[simp] +lemma eval_nestFormulae₃ {φ : Semiformula L ξ 3} {ψ₁ ψ₂ ψ₃ : Semiformula L ξ (m + 1)} : + Eval e f (φ.nestFormulae ![ψ₁, ψ₂, ψ₃]) ↔ + ∀ x₁, + Eval (x₁ :> e) f ψ₁ → + ∀ x₂, Eval (x₂ :> e) f ψ₂ → ∀ x₃, Eval (x₃ :> e) f ψ₃ → Eval ![x₁, x₂, x₃] f φ := + by + suffices + (∀ x₁ x₂ x₃, + Eval (x₁ :> e) f ψ₁ → + Eval (x₂ :> e) f ψ₂ → Eval (x₃ :> e) f ψ₃ → Eval ![x₁, x₂, x₃] f φ) ↔ + ∀ x₁, + Eval (x₁ :> e) f ψ₁ → + ∀ x₂, Eval (x₂ :> e) f ψ₂ → ∀ x₃, Eval (x₃ :> e) f ψ₃ → Eval ![x₁, x₂, x₃] f φ + by simpa [eval_nestFormulae, Matrix.vecForall_iff, Matrix.empty_eq, Fin.forall_fin_succ] + grind + +@[simp] +lemma eval_nestFormulae₄ {φ : Semiformula L ξ 4} {ψ₁ ψ₂ ψ₃ ψ₄ : Semiformula L ξ (m + 1)} : + Eval e f (φ.nestFormulae ![ψ₁, ψ₂, ψ₃, ψ₄]) ↔ + ∀ x₁, + Eval (x₁ :> e) f ψ₁ → + ∀ x₂, + Eval (x₂ :> e) f ψ₂ → + ∀ x₃, + Eval (x₃ :> e) f ψ₃ → ∀ x₄, Eval (x₄ :> e) f ψ₄ → Eval ![x₁, x₂, x₃, x₄] f φ := + by + suffices + (∀ x₁ x₂ x₃ x₄, + Eval (x₁ :> e) f ψ₁ → + Eval (x₂ :> e) f ψ₂ → + Eval (x₃ :> e) f ψ₃ → Eval (x₄ :> e) f ψ₄ → Eval ![x₁, x₂, x₃, x₄] f φ) ↔ + (∀ x₁, + Eval (x₁ :> e) f ψ₁ → + ∀ x₂, + Eval (x₂ :> e) f ψ₂ → + ∀ x₃, + Eval (x₃ :> e) f ψ₃ → ∀ x₄, Eval (x₄ :> e) f ψ₄ → Eval ![x₁, x₂, x₃, x₄] f φ) + by simpa [eval_nestFormulae, Matrix.vecForall_iff, Matrix.empty_eq, Fin.forall_fin_succ] + grind + +lemma eval_nestFormulaeFunc {φ : Semiformula L ξ (n + 1)} + {Ψ : Fin n → Semiformula L ξ (m + 1)} : + Eval (z :> e) f (φ.nestFormulaeFunc Ψ) ↔ + ∀ v : Fin n → M, (∀ i, Eval (v i :> e) f (Ψ i)) → Eval (z :> v) f φ := + by simp [nestFormulaeFunc, Matrix.comp_vecCons', Function.comp_def] + +@[simp] +lemma eval_nestFormulaeFunc₀ {φ : Semiformula L ξ 1} : + Eval (z :> e) f (φ.nestFormulaeFunc ![]) ↔ Eval ![z] f φ := by + simp [eval_nestFormulaeFunc, Matrix.empty_eq] + +@[simp] +lemma eval_nestFormulaeFunc₁ {φ : Semiformula L ξ 2} {ψ : Semiformula L ξ (m + 1)} : + Eval (z :> e) f (φ.nestFormulaeFunc ![ψ]) ↔ ∀ x, Eval (x :> e) f ψ → Eval ![z, x] f φ := by + simp [eval_nestFormulaeFunc, Matrix.vecForall_iff, Matrix.empty_eq] + +@[simp] +lemma eval_nestFormulaeFunc₂ {φ : Semiformula L ξ 3} {ψ₁ ψ₂ : Semiformula L ξ (m + 1)} : + Eval (z :> e) f (φ.nestFormulaeFunc ![ψ₁, ψ₂]) ↔ + ∀ x₁, Eval (x₁ :> e) f ψ₁ → ∀ x₂, Eval (x₂ :> e) f ψ₂ → Eval ![z, x₁, x₂] f φ := + by + suffices + (∀ x₁ x₂, Eval (x₁ :> e) f ψ₁ → Eval (x₂ :> e) f ψ₂ → Eval ![z, x₁, x₂] f φ) ↔ + ∀ x₁, Eval (x₁ :> e) f ψ₁ → ∀ x₂, Eval (x₂ :> e) f ψ₂ → Eval ![z, x₁, x₂] f φ + by simpa [eval_nestFormulaeFunc, Matrix.vecForall_iff, Matrix.empty_eq, Fin.forall_fin_two] + grind + +@[simp] +lemma eval_nestFormulaeFunc₃ {φ : Semiformula L ξ 4} {ψ₁ ψ₂ ψ₃ : Semiformula L ξ (m + 1)} : + Eval (z :> e) f (φ.nestFormulaeFunc ![ψ₁, ψ₂, ψ₃]) ↔ + ∀ x₁, + Eval (x₁ :> e) f ψ₁ → + ∀ x₂, Eval (x₂ :> e) f ψ₂ → ∀ x₃, Eval (x₃ :> e) f ψ₃ → Eval ![z, x₁, x₂, x₃] f φ := + by + suffices + (∀ x₁ x₂ x₃, + Eval (x₁ :> e) f ψ₁ → + Eval (x₂ :> e) f ψ₂ → Eval (x₃ :> e) f ψ₃ → Eval ![z, x₁, x₂, x₃] f φ) ↔ + ∀ x₁, + Eval (x₁ :> e) f ψ₁ → + ∀ x₂, Eval (x₂ :> e) f ψ₂ → ∀ x₃, Eval (x₃ :> e) f ψ₃ → Eval ![z, x₁, x₂, x₃] f φ + by simpa [eval_nestFormulaeFunc, Matrix.vecForall_iff, Matrix.empty_eq, Fin.forall_fin_succ] + grind + +@[simp] +lemma eval_nestFormulaeFunc₄ {φ : Semiformula L ξ 5} {ψ₁ ψ₂ ψ₃ ψ₄ : Semiformula L ξ (m + 1)} : + Eval (z :> e) f (φ.nestFormulaeFunc ![ψ₁, ψ₂, ψ₃, ψ₄]) ↔ + ∀ x₁, + Eval (x₁ :> e) f ψ₁ → + ∀ x₂, + Eval (x₂ :> e) f ψ₂ → + ∀ x₃, + Eval (x₃ :> e) f ψ₃ → + ∀ x₄, Eval (x₄ :> e) f ψ₄ → Eval ![z, x₁, x₂, x₃, x₄] f φ := + by + suffices + (∀ x₁ x₂ x₃ x₄, + Eval (x₁ :> e) f ψ₁ → + Eval (x₂ :> e) f ψ₂ → + Eval (x₃ :> e) f ψ₃ → Eval (x₄ :> e) f ψ₄ → Eval ![z, x₁, x₂, x₃, x₄] f φ) ↔ + (∀ x₁, + Eval (x₁ :> e) f ψ₁ → + ∀ x₂, + Eval (x₂ :> e) f ψ₂ → + ∀ x₃, + Eval (x₃ :> e) f ψ₃ → ∀ x₄, Eval (x₄ :> e) f ψ₄ → Eval ![z, x₁, x₂, x₃, x₄] f φ) + by simpa [eval_nestFormulaeFunc, Matrix.vecForall_iff, Matrix.empty_eq, Fin.forall_fin_succ] + grind + +end Semiformula + +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Classical/Coding.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Classical/Coding.lean new file mode 100644 index 000000000..afe7d3c2e --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Classical/Coding.lean @@ -0,0 +1,279 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Syntax.Classical.BinderNotation +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Nat.Matrix + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace FFL +namespace FirstOrder + +variable {L : Language} [(k : ℕ) → Encodable (L.Func k)] + +variable {ξ : Type*} [Encodable ξ] + +open Encodable + +namespace Semiterm + +/-- The to Nat construction in `FFL.FirstOrder.Semiterm`. -/ +def toNat {n : ℕ} : Semiterm L ξ n → ℕ + | #z => Nat.pair 0 z + 1 + | &x => Nat.pair 1 (encode x) + 1 + | func (arity := arity) f v => + (Nat.pair 2 <| + Nat.pair arity <| Nat.pair (encode f) <| Matrix.vecToNat fun i ↦ toNat (v i)) + + 1 + +def ofNat (n : ℕ) : ℕ → Option (Semiterm L ξ n) + | 0 => none + | e + 1 => + match e.unpair.1 with + | 0 => if h : e.unpair.2 < n then some #⟨e.unpair.2, h⟩ else none + | 1 => (decode e.unpair.2).map (&·) + | 2 => + let arity := e.unpair.2.unpair.1 + let ef := e.unpair.2.unpair.2.unpair.1 + let ev := e.unpair.2.unpair.2.unpair.2 + match hv : (PointwiseComposition.Nat.natToVec ev) arity with + | some v' => + (decode ef).bind fun f : L.Func arity ↦ + (Matrix.getM fun i ↦ + have : v' i < e + 1 := + Nat.lt_succ_iff.mpr <| + le_trans (le_of_lt <| Nat.lt_of_eq_natToVec hv i) <| + le_trans (Nat.unpair_right_le _) <| + le_trans (Nat.unpair_right_le _) <| Nat.unpair_right_le _ + ofNat n (v' i)).map + fun v : Fin arity → Semiterm L ξ n ↦ func f v + | none => none + | _ => none + +lemma ofNat_toNat {n : ℕ} : ∀ t : Semiterm L ξ n, ofNat n (toNat t) = some t + | #z => by simp [toNat, ofNat] + | &x => by simp [toNat, ofNat] + | func f v => + by + suffices (Matrix.getM fun i ↦ ofNat n (v i).toNat) = some v + by + simp only [toNat, ofNat, Nat.unpair_pair] + rw [Nat.unpair_pair, Nat.unpair_pair, Nat.unpair_pair, Nat.natToVec_vecToNat] + simpa + have : (fun i ↦ ofNat n (toNat (v i))) = (fun i ↦ pure (v i)) := + funext <| fun i ↦ ofNat_toNat (v i) + simp [this] + +instance encodable : Encodable (Semiterm L ξ n) + where + encode := toNat + decode := ofNat n + encodek := ofNat_toNat + +lemma encode_eq_toNat (t : Semiterm L ξ n) : encode t = toNat t := + rfl + +lemma toNat_func {k} (f : L.Func k) (v : Fin k → Semiterm L ξ n) : + toNat (func f v) = + (Nat.pair 2 <| Nat.pair k <| Nat.pair (encode f) <| Matrix.vecToNat fun i ↦ toNat (v i)) + + 1 := + rfl + +@[simp] +lemma encode_emb (t : ClosedSemiterm L n) : encode (Rew.emb t : Semiterm L ξ n) = encode t := + by + simp only [encode_eq_toNat] + induction t + · simp [toNat] + · contradiction + · simp [Rew.func, toNat_func, *] + +end Semiterm + +namespace Semiformula + +variable [(k : ℕ) → Encodable (L.Rel k)] + +/-- The to Nat construction in `FFL.FirstOrder.Semiformula`. -/ +def toNat {n : ℕ} : Semiformula L ξ n → ℕ + | rel (arity := arity) R v => + (Nat.pair 0 <| arity.pair <| (encode R).pair <| Matrix.vecToNat fun i ↦ encode (v i)) + 1 + | nrel (arity := arity) R v => + (Nat.pair 1 <| arity.pair <| (encode R).pair <| Matrix.vecToNat fun i ↦ encode (v i)) + 1 + | ⊤ => (Nat.pair 2 0) + 1 + | ⊥ => (Nat.pair 3 0) + 1 + | φ ⋏ ψ => (Nat.pair 4 <| φ.toNat.pair ψ.toNat) + 1 + | φ ⋎ ψ => (Nat.pair 5 <| φ.toNat.pair ψ.toNat) + 1 + | ∀¹ φ => (Nat.pair 6 <| φ.toNat) + 1 + | ∃¹ φ => (Nat.pair 7 <| φ.toNat) + 1 + +def ofNat : (n : ℕ) → ℕ → Option (Semiformula L ξ n) + | _, 0 => none + | n, e + 1 => + let idx := e.unpair.1 + let c := e.unpair.2 + match idx with + | 0 => + let arity := c.unpair.1 + let eR := c.unpair.2.unpair.1 + let ev := c.unpair.2.unpair.2 + match (PointwiseComposition.Nat.natToVec ev) arity with + | some v' => + (decode eR).bind fun R : L.Rel arity ↦ + (Matrix.getM fun i ↦ decode (v' i)).map fun v : Fin arity → Semiterm L ξ n ↦ rel R v + | none => none + | 1 => + let arity := c.unpair.1 + let eR := c.unpair.2.unpair.1 + let ev := c.unpair.2.unpair.2 + match (PointwiseComposition.Nat.natToVec ev) arity with + | some v' => + (decode eR).bind fun R : L.Rel arity ↦ + (Matrix.getM fun i ↦ decode (v' i)).map fun v : Fin arity → Semiterm L ξ n ↦ nrel R v + | none => none + | 2 => some ⊤ + | 3 => some ⊥ + | 4 => + have : c.unpair.1 < e + 1 := + Nat.lt_succ_iff.mpr <| le_trans (Nat.unpair_left_le _) <| Nat.unpair_right_le _ + have : c.unpair.2 < e + 1 := + Nat.lt_succ_iff.mpr <| le_trans (Nat.unpair_right_le _) <| Nat.unpair_right_le _ + do + let φ ← ofNat n c.unpair.1 + let ψ ← ofNat n c.unpair.2 + return φ ⋏ ψ + | 5 => + have : c.unpair.1 < e + 1 := + Nat.lt_succ_iff.mpr <| le_trans (Nat.unpair_left_le _) <| Nat.unpair_right_le _ + have : c.unpair.2 < e + 1 := + Nat.lt_succ_iff.mpr <| le_trans (Nat.unpair_right_le _) <| Nat.unpair_right_le _ + do + let φ ← ofNat n c.unpair.1 + let ψ ← ofNat n c.unpair.2 + return φ ⋎ ψ + | 6 => + have : c < e + 1 := Nat.lt_succ_iff.mpr <| Nat.unpair_right_le _ + do + let φ ← ofNat (n + 1) c + return ∀¹ φ + | 7 => + have : c < e + 1 := Nat.lt_succ_iff.mpr <| Nat.unpair_right_le _ + do + let φ ← ofNat (n + 1) c + return ∃¹ φ + | _ => none + +lemma ofNat_toNat {n : ℕ} : ∀ φ : Semiformula L ξ n, ofNat n (toNat φ) = some φ + | rel R v => by + simp only [toNat, ofNat, Nat.unpair_pair] + rw [Nat.unpair_pair, Nat.unpair_pair] + simp + | nrel R v => by + simp only [toNat, ofNat, Nat.unpair_pair] + rw [Nat.unpair_pair, Nat.unpair_pair] + simp + | ⊤ => by simp [toNat, ofNat] + | ⊥ => by simp [toNat, ofNat] + | φ ⋎ ψ => by simp [toNat, ofNat, ofNat_toNat φ, ofNat_toNat ψ] + | φ ⋏ ψ => by simp [toNat, ofNat, ofNat_toNat φ, ofNat_toNat ψ] + | ∀¹ φ => by simp [toNat, ofNat, ofNat_toNat φ] + | ∃¹ φ => by simp [toNat, ofNat, ofNat_toNat φ] + +instance encodable : Encodable (Semiformula L ξ n) + where + encode := toNat + decode := ofNat n + encodek := ofNat_toNat + +open Encodable + +lemma encode_eq_toNat (φ : Semiformula L ξ n) : encode φ = toNat φ := + rfl + +lemma encode_rel {arity : ℕ} (R : L.Rel arity) (v : Fin arity → Semiterm L ξ n) : + encode (Semiformula.rel R v) = + (Nat.pair 0 <| arity.pair <| (encode R).pair <| Matrix.vecToNat fun i ↦ encode (v i)) + + 1 := + rfl + +lemma encode_nrel {arity : ℕ} (R : L.Rel arity) (v : Fin arity → Semiterm L ξ n) : + encode (Semiformula.nrel R v) = + (Nat.pair 1 <| arity.pair <| (encode R).pair <| Matrix.vecToNat fun i ↦ encode (v i)) + + 1 := + rfl + +lemma encode_verum : encode (⊤ : Semiformula L ξ n) = (Nat.pair 2 0) + 1 := + rfl + +lemma encode_falsum : encode (⊥ : Semiformula L ξ n) = (Nat.pair 3 0) + 1 := + rfl + +lemma encode_and (φ ψ : Semiformula L ξ n) : + encode (φ ⋏ ψ) = (Nat.pair 4 <| φ.toNat.pair ψ.toNat) + 1 := + rfl + +lemma encode_or (φ ψ : Semiformula L ξ n) : + encode (φ ⋎ ψ) = (Nat.pair 5 <| φ.toNat.pair ψ.toNat) + 1 := + rfl + +lemma encode_all (φ : Semiformula L ξ (n + 1)) : encode (∀¹ φ) = (Nat.pair 6 <| φ.toNat) + 1 := + rfl + +lemma encode_ex (φ : Semiformula L ξ (n + 1)) : encode (∃¹ φ) = (Nat.pair 7 <| φ.toNat) + 1 := + rfl + +@[simp] +lemma encode_emb (σ : Semisentence L n) : + encode (Rewriting.emb σ : Semiformula L ξ n) = encode σ := by + induction σ using rec' <;> + simp [encode_rel, encode_nrel, encode_verum, encode_falsum, encode_and, encode_or, + encode_all, encode_ex, ← encode_eq_toNat, *] + +@[simp] +lemma encode_inj_sentence {σ : Semisentence L n} {φ : Semiformula L ξ n} : + encode φ = encode σ ↔ φ = Rewriting.emb σ := + by + constructor + · intro h; apply encode_inj.mp; simpa + · rintro rfl; simp + +@[simp] +lemma encode_inj_sentence' {σ : Semisentence L n} {φ : Semiformula L ξ n} : + encode σ = encode φ ↔ φ = Rewriting.emb σ := by rw [← encode_inj_sentence, eq_comm] + +end Semiformula + +section + +variable {L : Language} [L.Encodable] + +instance Semiterm.countable [Countable ξ] : Countable (Semiterm L ξ n) := + by + have : Encodable ξ := Encodable.ofCountable ξ + exact Encodable.countable + +instance Semiformula.countable [Countable ξ] : Countable (Semiformula L ξ n) := + by + have : Encodable ξ := Encodable.ofCountable ξ + exact Encodable.countable + +end + +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Classical/Eq.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Classical/Eq.lean new file mode 100644 index 000000000..9425d1c52 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Classical/Eq.lean @@ -0,0 +1,164 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Syntax.Classical.BinderNotation +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Finset.Card + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace Matrix + +open _root_.Matrix + +variable {α : Type*} + +/-- The iget construction in `Matrix`. -/ +def iget [Inhabited α] (v : Fin k → α) (x : ℕ) : α := + if h : x < k then v ⟨x, h⟩ else default + +end Matrix + +namespace FFL + +namespace FirstOrder + +variable {L : Language} {ξ : Type*} [Semiformula.Operator.Eq L] + +namespace Theory + +section Eq + +variable (L) + +/-- The refl construction in `FFL.FirstOrder.Theory.Eq`. -/ +abbrev Eq.refl : Sentence L := + “∀ x, x = x” + +/-- The symm construction in `FFL.FirstOrder.Theory.Eq`. -/ +abbrev Eq.symm : Sentence L := + “∀ x y, x = y → y = x” + +/-- The trans construction in `FFL.FirstOrder.Theory.Eq`. -/ +abbrev Eq.trans : Sentence L := + “∀ x y z, x = y → y = z → x = z” + +variable {L} + +/-- The func Ext construction in `FFL.FirstOrder.Theory.Eq`. -/ +abbrev Eq.funcExt {k} (f : L.Func k) : Sentence L := + let σ : Semisentence L (k + k) := + (Matrix.conj fun i : Fin k ↦ “#((Fin.addCast k i)) = #(i.addNat k)”) ⇒ₗ + op(=).operator + ![Semiterm.func f (fun i ↦ #((Fin.addCast k i))), + Semiterm.func f (fun i ↦ #(i.addNat k))] + ∀¹* σ + +/-- The rel Ext construction in `FFL.FirstOrder.Theory.Eq`. -/ +abbrev Eq.relExt {k} (r : L.Rel k) : Sentence L := + let σ : Semisentence L (k + k) := + (Matrix.conj fun i : Fin k ↦ “#((Fin.addCast k i)) = #(i.addNat k)”) ⇒ₗ + Semiformula.rel r (fun i ↦ #((Fin.addCast k i))) ⇒ₗ + Semiformula.rel r (fun i ↦ #(i.addNat k)) + ∀¹* σ + +variable (L) + +/-- Data and laws for 𝐄𝐐 in `𝐄𝐐`. -/ +inductive eqAxiom : Theory L + | refl : eqAxiom (Eq.refl L) + | symm : eqAxiom (Eq.symm L) + | trans : eqAxiom (Eq.trans L) + | funcExt {k} (f : L.Func k) : eqAxiom (Eq.funcExt f) + | relExt {k} (r : L.Rel k) : eqAxiom (Eq.relExt r) + +/-- The «term𝐄𝐐» construction in `FFL.FirstOrder.Theory`. -/ +notation "𝐄𝐐" => eqAxiom + +variable {L} + +lemma Eq.defeq : + 𝐄𝐐 L = + {Eq.refl L, Eq.symm L, Eq.trans L} ∪ + Set.range (fun f : (k : ℕ) × L.Func k ↦ Eq.funcExt f.2) ∪ + Set.range (fun f : (k : ℕ) × L.Rel k ↦ Eq.relExt f.2) := + by + ext φ; constructor + · rintro ⟨⟩ + case refl => simp + case symm => simp + case trans => simp + case funcExt k f => left; right; exact ⟨⟨k, f⟩, rfl⟩ + case relExt k r => right; exact ⟨⟨k, r⟩, rfl⟩ + · rintro (((rfl | rfl | rfl) | ⟨f, rfl⟩) | ⟨r, rfl⟩) + · exact eqAxiom.refl + · exact eqAxiom.symm + · exact eqAxiom.trans + · exact eqAxiom.funcExt _ + · exact eqAxiom.relExt _ + +@[simp] +lemma EqAxiom.finite [L.Finite] : Set.Finite (𝐄𝐐 L) := + by + have : Fintype ((k : ℕ) × L.Func k) := Language.Finite.func + have : Fintype ((k : ℕ) × L.Rel k) := Language.Finite.rel + rw [Eq.defeq] + simp [Set.finite_range] + +end Eq + +end Theory + +namespace Semiformula + +/-- The exists Unique construction in `FFL.FirstOrder.Semiformula`. -/ +def existsUnique {ξ} (φ : Semiformula L ξ (n + 1)) : Semiformula L ξ n := + “∃ y, !φ y⋯ ∧ ∀ z, !φ z⋯ → z = y” + +/-- The «term∃¹! » construction in `FFL.FirstOrder.Semiformula`. -/ +prefix:64 "∃¹! " => existsUnique + +end Semiformula + +namespace BinderNotation + +open _root_.Lean Lean PrettyPrinter Delaborator SubExpr + +/-- The «first order formula∃! » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :max "∃! " firstOrderFormula:0 : firstOrderFormula + +/-- The «first order formula∃! , » construction in `FFL.FirstOrder.BinderNotation`. -/ +syntax :max "∃! " ident ", " firstOrderFormula:0 : firstOrderFormula + +macro_rules + | `(quoteformula($type)[$binders* | $fbinders* | ∃! $φ:firstOrderFormula]) => do + let v := mkIdent (Name.mkSimple ("var" ++ toString binders.size)) + let binders' := binders.insertIdx 0 v + `(∃¹! quoteformula($type)[$binders'* | $fbinders* | $φ]) + | `(quoteformula($type)[$binders* | $fbinders* | ∃! $x, $φ]) => do + if binders.elem x then + Macro.throwErrorAt x "error: variable is duplicated." + else + let binders' := binders.insertIdx 0 x + `(∃¹! quoteformula($type)[$binders'* | $fbinders* | $φ]) + +end BinderNotation + +end FirstOrder + +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Classical/Formula.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Classical/Formula.lean new file mode 100644 index 000000000..33d1cb344 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Classical/Formula.lean @@ -0,0 +1,861 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.Syntax.Predicate.Term +public import LeanPool.PointwiseComposition.Foundation.Syntax.Predicate.Quantifier +public import Mathlib.Data.Nat.Cast.Order.Basic + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +/-! +# Formulas of first-order logic + +This file defines the formulas of first-order logic. + +`φ : Semiformula L ξ n` is a (semi-)formula of language `L` with bounded variables of `Fin n` +and free variables of `ξ`. +The quantification is represented by de Bruijn index. + +-/ + +namespace FFL +namespace FirstOrder + +/-- +A semiformula of language `L`. Free variables are of type `ξ`, and bound variables are +implemented as de Bruijn indices, of a type `Fin n` separate from free variables. +-/ +inductive Semiformula (L : Language) (ξ : Type*) : ℕ → Type _ where + | verum : Semiformula L ξ n + | falsum : Semiformula L ξ n + | rel : {arity : ℕ} → L.Rel arity → (Fin arity → Semiterm L ξ n) → Semiformula L ξ n + | nrel : {arity : ℕ} → L.Rel arity → (Fin arity → Semiterm L ξ n) → Semiformula L ξ n + | and : Semiformula L ξ n → Semiformula L ξ n → Semiformula L ξ n + | or : Semiformula L ξ n → Semiformula L ξ n → Semiformula L ξ n + | all : Semiformula L ξ (n + 1) → Semiformula L ξ n + | exs : Semiformula L ξ (n + 1) → Semiformula L ξ n + +/-- The Formula construction in `FFL.FirstOrder`. -/ +abbrev Formula (L : Language) (ξ : Type*) := + Semiformula L ξ 0 + +/-- The Sentence construction in `FFL.FirstOrder`. -/ +abbrev Sentence (L : Language) := + Formula L Empty + +/-- The Semisentence construction in `FFL.FirstOrder`. -/ +abbrev Semisentence (L : Language) (n : ℕ) := + Semiformula L Empty n + +/-- The Semiproposition construction in `FFL.FirstOrder`. -/ +abbrev Semiproposition (L : Language) (n : ℕ) := + Semiformula L ℕ n + +/-- The Proposition construction in `FFL.FirstOrder`. -/ +abbrev Proposition (L : Language) := + Semiproposition L 0 + +namespace Semiformula + +variable {L : Language} {L₁ : Language} {L₂ : Language} {L₃ : Language} {ξ ξ₁ ξ₂ ξ₃ : Type*} + {n n₁ n₂ n₂ m m₁ m₂ m₃ : ℕ} + +/-- The neg construction in `FFL.FirstOrder.Semiformula`. -/ +def neg {n} : Semiformula L ξ n → Semiformula L ξ n + | verum => falsum + | falsum => verum + | rel r v => nrel r v + | nrel r v => rel r v + | and φ ψ => or (neg φ) (neg ψ) + | or φ ψ => and (neg φ) (neg ψ) + | all φ => exs (neg φ) + | exs φ => all (neg φ) + +lemma neg_neg (φ : Semiformula L ξ n) : neg (neg φ) = φ := by induction φ <;> simp [*, neg] + +instance : LogicalConnective (Semiformula L ξ n) + where + arrow := fun φ ψ => or (neg φ) ψ + wedge := and + vee := or + tilde := neg + +instance : LogicalNeutral (Semiformula L ξ n) + where + top := verum + bot := falsum + +instance : TildeInvolutive (Semiformula L ξ n) where tilde_involutive := neg_neg + +instance : LogicalConnective.DeMorgan (Semiformula L ξ n) + where + imply := fun _ _ => rfl + and := fun _ _ => rfl + or := fun _ _ => rfl + +instance : LogicalNeutral.DeMorgan (Semiformula L ξ n) + where + verum := rfl + falsum := rfl + +instance : Quantifier (Semiformula L ξ) + where + all := all + exs := exs + +section ToString + +variable [∀ k, ToString (L.Func k)] [∀ k, ToString (L.Rel k)] [ToString ξ] + +/-- The to Str construction in `FFL.FirstOrder.Semiformula`. -/ +def toStr {n} : Semiformula L ξ n → String + | ⊤ => "\\top" + | ⊥ => "\\bot" + | rel (arity := 0) r _ => "{" ++ toString r ++ "}" + | rel (arity := _ + 1) r v => + "{" ++ toString r ++ "} \\left(" ++ String.vecToStr (fun i => toString (v i)) ++ "\\right)" + | nrel (arity := 0) r _ => "\\lnot {" ++ toString r ++ "}" + | nrel (arity := _ + 1) r v => + "\\lnot {" ++ toString r ++ "} \\left(" ++ String.vecToStr (fun i => toString (v i)) ++ + "\\right)" + | φ ⋏ ψ => "\\left(" ++ toStr φ ++ " \\land " ++ toStr ψ ++ "\\right)" + | φ ⋎ ψ => "\\left(" ++ toStr φ ++ " \\lor " ++ toStr ψ ++ "\\right)" + | ∀¹ φ => "(\\forall x_{" ++ toString n ++ "}) " ++ toStr φ + | ∃¹ φ => "(\\exists x_{" ++ toString n ++ "}) " ++ toStr φ + +instance : Repr (Semiformula L ξ n) := + ⟨fun t _ ↦ toStr t⟩ + +instance : ToString (Semiformula L ξ n) := + ⟨toStr⟩ + +end ToString + +@[simp] +lemma neg_rel {k} (r : L.Rel k) (v : Fin k → Semiterm L ξ n) : ∼(rel r v) = nrel r v := + rfl + +@[simp] +lemma neg_nrel {k} (r : L.Rel k) (v : Fin k → Semiterm L ξ n) : ∼(nrel r v) = rel r v := + rfl + +@[simp] +lemma neg_all (φ : Semiformula L ξ (n + 1)) : ∼(∀¹ φ) = ∃¹ ∼φ := + rfl + +@[simp] +lemma neg_ex (φ : Semiformula L ξ (n + 1)) : ∼(∃¹ φ) = ∀¹ ∼φ := + rfl + +/-- +`φ.toPrenex Γ s` prefixes `φ` with `s` alternating quantifiers, the outermost one being `Γ`. -/ +abbrev toPrenex (Γ : Polarity) (s : ℕ) (φ : Semiformula L ξ (n + s)) : Semiformula L ξ n := + Polarity.quantItr Γ s φ + +@[simp] +lemma neg_quant (Γ : Polarity) (φ : Semiformula L ξ (n + 1)) : + ∼(Γ.quant φ) = Γ.alt.quant (∼φ) := by rcases Γ <;> rfl + +@[simp] +lemma neg_toPrenex (Γ : Polarity) (s : ℕ) (φ : Semiformula L ξ (n + s)) : + ∼(φ.toPrenex Γ s) = (∼φ).toPrenex Γ.alt s := by + induction s generalizing n with + | zero => rfl + | succ s + ih => + change ∼(Polarity.quantItr Γ (s + 1) φ) = Polarity.quantItr Γ.alt (s + 1) (∼φ) + rw [Polarity.quantItr_succ', ih, neg_quant, Polarity.quantItr_succ'] + rw [← Polarity.altItr_succ, Polarity.altItr_succ'] + +lemma neg_inj (φ ψ : Semiformula L ξ n) : ∼φ = ∼ψ ↔ φ = ψ := + by + constructor + · intro h; simpa using congr_arg (∼·) h + · exact congr_arg _ + +@[simp] +lemma neg_allClosure (φ : Semiformula L ξ n) : ∼(∀¹* φ) = ∃¹* ∼φ := by + induction n <;> simp [allClosure, exsClosure, *] + +@[simp] +lemma neg_exsClosure (φ : Semiformula L ξ n) : ∼(∃¹* φ) = ∀¹* ∼φ := by + induction n <;> simp [allClosure, exsClosure, *] + +lemma neg_eq (φ : Semiformula L ξ n) : ∼φ = neg φ := + rfl + +lemma imp_eq (φ ψ : Semiformula L ξ n) : φ ⇒ₗ ψ = ∼φ ⋎ ψ := + rfl + +lemma iff_eq (φ ψ : Semiformula L ξ n) : φ ⇔ₗ ψ = (∼φ ⋎ ψ) ⋏ (∼ψ ⋎ φ) := + rfl + +lemma ball_eq (φ ψ : Semiformula L ξ (n + 1)) : (∀¹[φ] ψ) = ∀¹ (φ ⇒ₗ ψ) := + rfl + +lemma bexs_eq (φ ψ : Semiformula L ξ (n + 1)) : (∃¹[φ] ψ) = ∃¹ (φ ⋏ ψ) := + rfl + +@[simp] +lemma neg_ball (φ ψ : Semiformula L ξ (n + 1)) : ∼(∀¹[φ] ψ) = ∃¹[φ] ∼ψ := by + simp [ball, bexs, imp_eq] + +@[simp] +lemma neg_bexs (φ ψ : Semiformula L ξ (n + 1)) : ∼(∃¹[φ] ψ) = ∀¹[φ] ∼ψ := by + simp [ball, bexs, imp_eq] + +@[simp] +lemma and_inj (φ₁ ψ₁ φ₂ ψ₂ : Semiformula L ξ n) : φ₁ ⋏ φ₂ = ψ₁ ⋏ ψ₂ ↔ φ₁ = ψ₁ ∧ φ₂ = ψ₂ := + Iff.of_eq <| and.injEq _ _ _ _ + +@[simp] +lemma or_inj (φ₁ ψ₁ φ₂ ψ₂ : Semiformula L ξ n) : φ₁ ⋎ φ₂ = ψ₁ ⋎ ψ₂ ↔ φ₁ = ψ₁ ∧ φ₂ = ψ₂ := + Iff.of_eq <| or.injEq _ _ _ _ + +@[simp] +lemma all_inj (φ ψ : Semiformula L ξ (n + 1)) : ∀¹ φ = ∀¹ ψ ↔ φ = ψ := + Iff.of_eq <| all.injEq _ _ + +@[simp] +lemma exs_inj (φ ψ : Semiformula L ξ (n + 1)) : ∃¹ φ = ∃¹ ψ ↔ φ = ψ := + Iff.of_eq <| exs.injEq _ _ + +@[simp] +lemma allClosure_inj (φ ψ : Semiformula L ξ n) : ∀¹* φ = ∀¹* ψ ↔ φ = ψ := by + induction n <;> simp [*, allClosure_succ] + +@[simp] +lemma exsClosure_inj (φ ψ : Semiformula L ξ n) : ∃¹* φ = ∃¹* ψ ↔ φ = ψ := by + induction n <;> simp [*, exsClosure_succ] + +@[simp] +lemma allItr_inj {k} (φ ψ : Semiformula L ξ (n + k)) : ∀¹^[k] φ = ∀¹^[k] ψ ↔ φ = ψ := by + induction k <;> simp [*, allItr_succ] + +@[simp] +lemma exsItr_inj {k} (φ ψ : Semiformula L ξ (n + k)) : ∃¹^[k] φ = ∃¹^[k] ψ ↔ φ = ψ := by + induction k <;> simp [*, exsItr_succ] + +@[simp] +lemma imp_inj {φ₁ φ₂ ψ₁ ψ₂ : Semiformula L ξ n} : φ₁ ⇒ₗ φ₂ = ψ₁ ⇒ₗ ψ₂ ↔ φ₁ = ψ₁ ∧ φ₂ = ψ₂ := by + simp [imp_eq] + +/-- The rel! construction in `FFL.FirstOrder.Semiformula`. -/ +abbrev relProof (L : Language) (k) (r : L.Rel k) (v : Fin k → Semiterm L ξ n) := + rel r v + +/-- The nrel! construction in `FFL.FirstOrder.Semiformula`. -/ +abbrev nrelProof (L : Language) (k) (r : L.Rel k) (v : Fin k → Semiterm L ξ n) := + nrel r v + +/-- The complexity of a semiformula, taking max at logical connectives. +-/ +def complexity {n : ℕ} : Semiformula L ξ n → ℕ + | ⊤ => 0 + | ⊥ => 0 + | rel _ _ => 0 + | nrel _ _ => 0 + | φ ⋏ ψ => max φ.complexity ψ.complexity + 1 + | φ ⋎ ψ => max φ.complexity ψ.complexity + 1 + | ∀¹ φ => φ.complexity + 1 + | ∃¹ φ => φ.complexity + 1 + +@[simp] +lemma complexity_top : complexity (⊤ : Semiformula L ξ n) = 0 := + rfl + +@[simp] +lemma complexity_bot : complexity (⊥ : Semiformula L ξ n) = 0 := + rfl + +@[simp] +lemma complexity_rel {k} (r : L.Rel k) (v : Fin k → Semiterm L ξ n) : + complexity (rel r v) = 0 := + rfl + +@[simp] +lemma complexity_nrel {k} (r : L.Rel k) (v : Fin k → Semiterm L ξ n) : + complexity (nrel r v) = 0 := + rfl + +@[simp] +lemma complexity_and (φ ψ : Semiformula L ξ n) : + complexity (φ ⋏ ψ) = max φ.complexity ψ.complexity + 1 := + rfl + +@[simp] +lemma complexity_and' (φ ψ : Semiformula L ξ n) : + complexity (and φ ψ) = max φ.complexity ψ.complexity + 1 := + rfl + +@[simp] +lemma complexity_or (φ ψ : Semiformula L ξ n) : + complexity (φ ⋎ ψ) = max φ.complexity ψ.complexity + 1 := + rfl + +@[simp] +lemma complexity_or' (φ ψ : Semiformula L ξ n) : + complexity (or φ ψ) = max φ.complexity ψ.complexity + 1 := + rfl + +@[simp] +lemma complexity_all (φ : Semiformula L ξ (n + 1)) : complexity (∀¹ φ) = φ.complexity + 1 := + rfl + +@[simp] +lemma complexity_all' (φ : Semiformula L ξ (n + 1)) : complexity (all φ) = φ.complexity + 1 := + rfl + +@[simp] +lemma complexity_exs (φ : Semiformula L ξ (n + 1)) : complexity (∃¹ φ) = φ.complexity + 1 := + rfl + +@[simp] +lemma complexity_exs' (φ : Semiformula L ξ (n + 1)) : complexity (exs φ) = φ.complexity + 1 := + rfl + +/-- The cases' construction in `FFL.FirstOrder.Semiformula`. -/ +@[elab_as_elim] +def cases' {C : ∀ n, Semiformula L ξ n → Sort w} (hverum : ∀ {n : ℕ}, C n ⊤) + (hfalsum : ∀ {n : ℕ}, C n ⊥) + (hrel : ∀ {n k : ℕ} (r : L.Rel k) (v : Fin k → Semiterm L ξ n), C n (rel r v)) + (hnrel : ∀ {n k : ℕ} (r : L.Rel k) (v : Fin k → Semiterm L ξ n), C n (nrel r v)) + (hand : ∀ {n : ℕ} (φ ψ : Semiformula L ξ n), C n (φ ⋏ ψ)) + (hor : ∀ {n : ℕ} (φ ψ : Semiformula L ξ n), C n (φ ⋎ ψ)) + (hall : ∀ {n : ℕ} (φ : Semiformula L ξ (n + 1)), C n (∀¹ φ)) + (hexs : ∀ {n : ℕ} (φ : Semiformula L ξ (n + 1)), C n (∃¹ φ)) {n : ℕ} : + (φ : Semiformula L ξ n) → C n φ + | verum => hverum + | falsum => hfalsum + | rel r v => hrel r v + | nrel r v => hnrel r v + | and φ ψ => hand φ ψ + | or φ ψ => hor φ ψ + | ∀¹ φ => hall φ + | ∃¹ φ => hexs φ + +/-- The rec' construction in `FFL.FirstOrder.Semiformula`. -/ +@[elab_as_elim] +def rec' {C : ∀ n, Semiformula L ξ n → Sort w} (hverum : ∀ {n : ℕ}, C n ⊤) + (hfalsum : ∀ {n : ℕ}, C n ⊥) + (hrel : ∀ {n k : ℕ} (r : L.Rel k) (v : Fin k → Semiterm L ξ n), C n (rel r v)) + (hnrel : ∀ {n k : ℕ} (r : L.Rel k) (v : Fin k → Semiterm L ξ n), C n (nrel r v)) + (hand : ∀ {n : ℕ} (φ ψ : Semiformula L ξ n), C n φ → C n ψ → C n (φ ⋏ ψ)) + (hor : ∀ {n : ℕ} (φ ψ : Semiformula L ξ n), C n φ → C n ψ → C n (φ ⋎ ψ)) + (hall : ∀ {n : ℕ} (φ : Semiformula L ξ (n + 1)), C (n + 1) φ → C n (∀¹ φ)) + (hexs : ∀ {n : ℕ} (φ : Semiformula L ξ (n + 1)), C (n + 1) φ → C n (∃¹ φ)) {n : ℕ} : + (φ : Semiformula L ξ n) → C n φ + | verum => hverum + | falsum => hfalsum + | rel r v => hrel r v + | nrel r v => hnrel r v + | and φ ψ => + hand φ ψ (rec' hverum hfalsum hrel hnrel hand hor hall hexs φ) + (rec' hverum hfalsum hrel hnrel hand hor hall hexs ψ) + | or φ ψ => + hor φ ψ (rec' hverum hfalsum hrel hnrel hand hor hall hexs φ) + (rec' hverum hfalsum hrel hnrel hand hor hall hexs ψ) + | ∀¹ φ => hall φ (rec' hverum hfalsum hrel hnrel hand hor hall hexs φ) + | ∃¹ φ => hexs φ (rec' hverum hfalsum hrel hnrel hand hor hall hexs φ) + +@[simp] +lemma complexity_neg (φ : Semiformula L ξ n) : complexity (∼φ) = complexity φ := by + induction φ using rec' <;> simp [*] + +section Decidable + +variable [L.DecidableEq] [DecidableEq ξ] + +/-- The has Dec Eq construction in `FFL.FirstOrder.Semiformula`. -/ +def hasDecEq {n : ℕ} : (φ ψ : Semiformula L ξ n) → Decidable (φ = ψ) + | ⊤, ψ => by + cases ψ using cases' <;> + { simp only [reduceCtorEq]; infer_instance + } + | ⊥, ψ => by + cases ψ using cases' <;> + { simp only [reduceCtorEq]; infer_instance + } + | rel r v, ψ => + by + cases ψ using cases' <;> + try { simp only [reduceCtorEq]; infer_instance + } + case hrel k₁ k₂ r₂ v₂ => + by_cases e : k₁ = k₂ + · rcases e with rfl + exact + match decEq r r₂ with + | isTrue h => by simpa [h] using Matrix.decVec _ _ fun i ↦ decEq (v i) (v₂ i) + | isFalse h => isFalse (by simp [h]) + · exact isFalse (by simp [e]) + | nrel r v, ψ => + by + cases ψ using cases' <;> + try { simp only [reduceCtorEq]; infer_instance + } + case hnrel k₁ k₂ r₂ v₂ => + by_cases e : k₁ = k₂ + · rcases e with rfl + exact + match decEq r r₂ with + | isTrue h => by simpa [h] using Matrix.decVec _ _ fun i ↦ decEq (v i) (v₂ i) + | isFalse h => isFalse (by simp [h]) + · exact isFalse (by simp [e]) + | φ ⋏ ψ, r => + by + cases r using cases' <;> + try { simp only [reduceCtorEq]; infer_instance + } + case hand φ' ψ' => + exact + match hasDecEq φ φ' with + | isTrue hp => + match hasDecEq ψ ψ' with + | isTrue hq => isTrue (hp ▸ hq ▸ rfl) + | isFalse hq => isFalse (by simp [hp, hq]) + | isFalse hp => isFalse (by simp [hp]) + | φ ⋎ ψ, r => + by + cases r using cases' <;> + try { simp only [reduceCtorEq]; infer_instance + } + case hor φ' ψ' => + exact + match hasDecEq φ φ' with + | isTrue hp => + match hasDecEq ψ ψ' with + | isTrue hq => isTrue (hp ▸ hq ▸ rfl) + | isFalse hq => isFalse (by simp [hp, hq]) + | isFalse hp => isFalse (by simp [hp]) + | ∀¹ φ, ψ => + by + cases ψ using cases' <;> + try { simp only [reduceCtorEq]; infer_instance + } + case hall φ' => simpa using hasDecEq φ φ' + | ∃¹ φ, ψ => + by + cases ψ using cases' <;> + try { simp only [reduceCtorEq]; infer_instance + } + case hexs φ' => simpa using hasDecEq φ φ' + +instance : DecidableEq (Semiformula L ξ n) := + hasDecEq + +end Decidable + +/-! +Quantifier rank -/ + +section qr + +/-- The qr construction in `FFL.FirstOrder.Semiformula`. -/ +def qr {n} : Semiformula L ξ n → ℕ + | ⊤ => 0 + | ⊥ => 0 + | rel _ _ => 0 + | nrel _ _ => 0 + | φ ⋏ ψ => max φ.qr ψ.qr + | φ ⋎ ψ => max φ.qr ψ.qr + | ∀¹ φ => φ.qr + 1 + | ∃¹ φ => φ.qr + 1 + +@[simp] +lemma qr_top : (⊤ : Semiformula L ξ n).qr = 0 := + rfl + +@[simp] +lemma qr_bot : (⊥ : Semiformula L ξ n).qr = 0 := + rfl + +@[simp] +lemma qr_rel {k} (r : L.Rel k) (v : Fin k → Semiterm L ξ n) : (rel r v).qr = 0 := + rfl + +@[simp] +lemma qr_nrel {k} (r : L.Rel k) (v : Fin k → Semiterm L ξ n) : (nrel r v).qr = 0 := + rfl + +@[simp] +lemma qr_and (φ ψ : Semiformula L ξ n) : (φ ⋏ ψ).qr = max φ.qr ψ.qr := + rfl + +@[simp] +lemma qr_or (φ ψ : Semiformula L ξ n) : (φ ⋎ ψ).qr = max φ.qr ψ.qr := + rfl + +@[simp] +lemma qr_all (φ : Semiformula L ξ (n + 1)) : (∀¹ φ).qr = φ.qr + 1 := + rfl + +@[simp] +lemma qr_exs (φ : Semiformula L ξ (n + 1)) : (∃¹ φ).qr = φ.qr + 1 := + rfl + +@[simp] +lemma qr_neg (φ : Semiformula L ξ n) : (∼φ).qr = φ.qr := by induction φ using rec' <;> simp [*] + +@[simp] +lemma qr_imply (φ ψ : Semiformula L ξ n) : (φ ⇒ₗ ψ).qr = max φ.qr ψ.qr := by simp [imp_eq] + +@[simp] +lemma qr_iff (φ ψ : Semiformula L ξ n) : (φ ⇔ₗ ψ).qr = max φ.qr ψ.qr := by + simp [iff_eq, total_of] + +end qr + +/-! +Open (Semi-)Formula -/ + +section Open + +/-- The Open construction in `FFL.FirstOrder.Semiformula`. -/ +def Open (φ : Semiformula L ξ n) : Prop := + φ.qr = 0 + +lemma open_top : (⊤ : Semiformula L ξ n).Open := + rfl + +lemma open_bot : (⊥ : Semiformula L ξ n).Open := + rfl + +lemma open_rel {k} (r : L.Rel k) (v : Fin k → Semiterm L ξ n) : (rel r v).Open := + rfl + +lemma open_nrel {k} (r : L.Rel k) (v : Fin k → Semiterm L ξ n) : (nrel r v).Open := + rfl + +@[simp] +lemma open_and {φ ψ : Semiformula L ξ n} : (φ ⋏ ψ).Open ↔ φ.Open ∧ ψ.Open := by simp [Open] + +@[simp] +lemma open_or {φ ψ : Semiformula L ξ n} : (φ ⋎ ψ).Open ↔ φ.Open ∧ ψ.Open := by simp [Open] + +@[simp] +lemma not_open_all {φ : Semiformula L ξ (n + 1)} : ¬(∀¹ φ).Open := by simp [Open] + +@[simp] +lemma not_open_exs {φ : Semiformula L ξ (n + 1)} : ¬(∃¹ φ).Open := by simp [Open] + +@[simp] +lemma open_neg {φ : Semiformula L ξ n} : (∼φ).Open ↔ φ.Open := by simp [Open] + +@[simp] +lemma open_imply {φ ψ : Semiformula L ξ n} : (φ ⇒ₗ ψ).Open ↔ φ.Open ∧ ψ.Open := by simp [Open] + +@[simp] +lemma open_iff {φ ψ : Semiformula L ξ n} : (φ ⇔ₗ ψ).Open ↔ φ.Open ∧ ψ.Open := by simp [Open] + +end Open + +/-! +Free Variables -/ + +section FreeVariables + +variable [DecidableEq ξ] + +/-- The free Variables construction in `FFL.FirstOrder.Semiformula`. -/ +def freeVariables {n} : Semiformula L ξ n → Finset ξ + | rel _ v => .biUnion .univ fun i ↦ (v i).freeVariables + | nrel _ v => .biUnion .univ fun i ↦ (v i).freeVariables + | ⊤ => ∅ + | ⊥ => ∅ + | φ ⋏ ψ => freeVariables φ ∪ freeVariables ψ + | φ ⋎ ψ => freeVariables φ ∪ freeVariables ψ + | ∀¹ φ => freeVariables φ + | ∃¹ φ => freeVariables φ + +lemma freeVariables_rel {k} (r : L.Rel k) (v : Fin k → Semiterm L ξ n) : + (rel r v).freeVariables = .biUnion .univ fun i ↦ (v i).freeVariables := + rfl + +lemma freeVariables_nrel {k} (r : L.Rel k) (v : Fin k → Semiterm L ξ n) : + (nrel r v).freeVariables = .biUnion .univ fun i ↦ (v i).freeVariables := + rfl + +@[simp] +lemma freeVariables_verum : (⊤ : Semiformula L ξ n).freeVariables = ∅ := + rfl + +@[simp] +lemma freeVariables_falsum : (⊥ : Semiformula L ξ n).freeVariables = ∅ := + rfl + +@[simp] +lemma freeVariables_and (φ ψ : Semiformula L ξ n) : + (φ ⋏ ψ).freeVariables = φ.freeVariables ∪ ψ.freeVariables := + rfl + +@[simp] +lemma freeVariables_or (φ ψ : Semiformula L ξ n) : + (φ ⋎ ψ).freeVariables = φ.freeVariables ∪ ψ.freeVariables := + rfl + +@[simp] +lemma freeVariables_all (φ : Semiformula L ξ (n + 1)) : + (∀¹ φ).freeVariables = φ.freeVariables := + rfl + +@[simp] +lemma freeVariables_exs (φ : Semiformula L ξ (n + 1)) : + (∃¹ φ).freeVariables = φ.freeVariables := + rfl + +@[simp] +lemma freeVariables_not (φ : Semiformula L ξ n) : (∼φ).freeVariables = φ.freeVariables := by + induction φ using rec' <;> simp [*, freeVariables_rel, freeVariables_nrel] + +@[simp] +lemma freeVariables_imp (φ ψ : Semiformula L ξ n) : + (φ ⇒ₗ ψ).freeVariables = φ.freeVariables ∪ ψ.freeVariables := by simp [imp_eq] + +@[simp] +lemma freeVariables_allClosure (φ : Semiformula L ξ n) : + (∀¹* φ).freeVariables = φ.freeVariables := by induction n <;> simp [allClosure, *] + +@[simp] +lemma freeVariables_sentence {ο : Type*} [IsEmpty ο] (φ : Semiformula L ο n) : + φ.freeVariables = ∅ := by ext x; exact IsEmpty.elim inferInstance x + +/-- The FVar? construction in `FFL.FirstOrder.Semiformula`. -/ +abbrev HasFreeVariable (φ : Semiformula L ξ n) (x : ξ) : Prop := + x ∈ φ.freeVariables + +@[simp] +lemma hasFreeVariable_rel {x k} {R : L.Rel k} {v : Fin k → Semiterm L ξ n} : + (rel R v).HasFreeVariable x ↔ ∃ i, (v i).HasFreeVariable x := by + simp [HasFreeVariable, freeVariables_rel] + +@[simp] +lemma hasFreeVariable_nrel {x k} {R : L.Rel k} {v : Fin k → Semiterm L ξ n} : + (nrel R v).HasFreeVariable x ↔ ∃ i, (v i).HasFreeVariable x := by + simp [HasFreeVariable, freeVariables_nrel] + +@[simp] +lemma hasFreeVariable_top (x) : ¬(⊤ : Semiformula L ξ n).HasFreeVariable x := by + simp [HasFreeVariable] + +@[simp] +lemma hasFreeVariable_falsum (x) : ¬(⊥ : Semiformula L ξ n).HasFreeVariable x := by + simp [HasFreeVariable] + +@[simp] +lemma hasFreeVariable_and (x) (φ ψ : Semiformula L ξ n) : + (φ ⋏ ψ).HasFreeVariable x ↔ φ.HasFreeVariable x ∨ ψ.HasFreeVariable x := by + simp [HasFreeVariable] + +@[simp] +lemma hasFreeVariable_or (x) (φ ψ : Semiformula L ξ n) : + (φ ⋎ ψ).HasFreeVariable x ↔ φ.HasFreeVariable x ∨ ψ.HasFreeVariable x := by + simp [HasFreeVariable] + +@[simp] +lemma hasFreeVariable_all (x) (φ : Semiformula L ξ (n + 1)) : + (∀¹ φ).HasFreeVariable x ↔ φ.HasFreeVariable x := by simp [HasFreeVariable] + +@[simp] +lemma hasFreeVariable_exs (x) (φ : Semiformula L ξ (n + 1)) : + (∃¹ φ).HasFreeVariable x ↔ φ.HasFreeVariable x := by simp [HasFreeVariable] + +@[simp] +lemma hasFreeVariable_allClosure (x) (φ : Semiformula L ξ n) : + (∀¹* φ).HasFreeVariable x ↔ φ.HasFreeVariable x := by simp [HasFreeVariable] + +/-- The fv Sup construction in `FFL.FirstOrder.Semiformula`. -/ +def fvSup (φ : Semiproposition L n) : ℕ := + (φ.freeVariables.max).recBotCoe 0 .succ + +lemma lt_fvSup_of_hasFreeVariable {φ : Semiproposition L n} : + φ.HasFreeVariable m → m < φ.fvSup := + by + unfold fvSup HasFreeVariable + intro hm + have : ∃ s : ℕ, φ.freeVariables.max = s := Finset.max_of_mem hm + rcases this with ⟨s, hs⟩ + have : m ≤ s := + by + have : (m : WithBot ℕ) ≤ ↑s := by simpa [hs, -Nat.cast_le] using Finset.le_max hm + exact WithBot.coe_le_coe.mp this + simpa [hs, WithBot.recBotCoe] using Nat.lt_add_one_of_le this + +lemma not_hasFreeVariable_of_lt_fvSup (φ : Semiproposition L n) (h : φ.fvSup ≤ m) : + ¬φ.HasFreeVariable m := fun hm ↦ + (lt_self_iff_false _).mp (lt_of_le_of_lt h <| lt_fvSup_of_hasFreeVariable hm) + +@[simp] +lemma not_hasFreeVariable_fvSup (φ : Semiproposition L n) : ¬φ.HasFreeVariable φ.fvSup := + not_hasFreeVariable_of_lt_fvSup φ (by simp) + +end FreeVariables + +section + +variable {α : Type*} [LinearOrder α] + +lemma List.maximumOption_some_of_not_nil {l : List α} (h : l ≠ []) : l.max?.isSome := + by + cases l + case nil => simp at h + case cons l => simp [List.max?_cons] + +lemma List.maximumOption_eq_some [Std.LawfulOrderSup α] {l : List α} {a} (h : l.max? = some a) : + ∀ x ∈ l, x ≤ a := + List.max?_le_iff h (x := a) |>.mp (by rfl) + +end + +lemma ne_of_ne_complexity {φ ψ : Semiformula L ξ n} (h : φ.complexity ≠ ψ.complexity) : φ ≠ ψ := + by rintro rfl; contradiction + +@[simp] +lemma ne_or_left (φ ψ : Semiformula L ξ n) : φ ≠ φ ⋎ ψ := + ne_of_ne_complexity (by simp) + +@[simp] +lemma ne_or_right (φ ψ : Semiformula L ξ n) : ψ ≠ φ ⋎ ψ := + ne_of_ne_complexity (by simp) + +variable {L : Language} {L₁ : Language} {L₂ : Language} {L₃ : Language} {ξ : Type*} + {Φ : L₁ →ᵥ L₂} + +/-- The l Map Aux construction in `FFL.FirstOrder.Semiformula`. -/ +def lMapAux (Φ : L₁ →ᵥ L₂) {n} : Semiformula L₁ ξ n → Semiformula L₂ ξ n + | ⊤ => ⊤ + | ⊥ => ⊥ + | rel r v => rel (Φ.rel r) (Semiterm.lMap Φ ∘ v) + | nrel r v => nrel (Φ.rel r) (Semiterm.lMap Φ ∘ v) + | φ ⋏ ψ => lMapAux Φ φ ⋏ lMapAux Φ ψ + | φ ⋎ ψ => lMapAux Φ φ ⋎ lMapAux Φ ψ + | ∀¹ φ => ∀¹ lMapAux Φ φ + | ∃¹ φ => ∃¹ lMapAux Φ φ + +lemma lMapAux_neg {n} (φ : Semiformula L₁ ξ n) : (∼φ).lMapAux Φ = ∼φ.lMapAux Φ := by + induction φ using Semiformula.rec' <;> simp [*, lMapAux] + +/-- The map on semiformulas induced by a homomorphism between languages. +-/ +def lMap (Φ : L₁ →ᵥ L₂) {n} : Semiformula L₁ ξ n →ˡᶜ Semiformula L₂ ξ n + where + toTr := lMapAux Φ + map_top' := by simp [lMapAux] + map_bot' := by simp [lMapAux] + map_and' := by simp [lMapAux] + map_or' := by simp [lMapAux] + map_neg' := by simp [lMapAux_neg] + map_imply' := by simp [Semiformula.imp_eq, lMapAux_neg, ← Semiformula.neg_eq, lMapAux] + +@[simp] +lemma lMap_rel {k} (r : L₁.Rel k) (v : Fin k → Semiterm L₁ ξ n) : + lMap Φ (rel r v) = rel (Φ.rel r) (Semiterm.lMap Φ ∘ v) := + rfl + +@[simp] +lemma lMap_nrel {k} (r : L₁.Rel k) (v : Fin k → Semiterm L₁ ξ n) : + lMap Φ (nrel r v) = nrel (Φ.rel r) (Semiterm.lMap Φ ∘ v) := + rfl + +@[simp] +lemma lMap_all (φ : Semiformula L₁ ξ (n + 1)) : lMap Φ (∀¹ φ) = ∀¹ lMap Φ φ := + rfl + +@[simp] +lemma lMap_exs (φ : Semiformula L₁ ξ (n + 1)) : lMap Φ (∃¹ φ) = ∃¹ lMap Φ φ := + rfl + +@[simp] +lemma lMap_ball (φ ψ : Semiformula L₁ ξ (n + 1)) : lMap Φ (∀¹[φ] ψ) = ∀¹[lMap Φ φ] lMap Φ ψ := + by simp [ball] + +@[simp] +lemma lMap_bexs (φ ψ : Semiformula L₁ ξ (n + 1)) : lMap Φ (∃¹[φ] ψ) = ∃¹[lMap Φ φ] lMap Φ ψ := + by simp [bexs] + +@[simp] +lemma lMap_allClosure (φ : Semiformula L₁ ξ n) : lMap Φ (∀¹* φ) = ∀¹* lMap Φ φ := by + induction n <;> simp [*, allClosure_succ] + +@[simp] +lemma lMap_exsClosure (φ : Semiformula L₁ ξ n) : lMap Φ (∃¹* φ) = ∃¹* lMap Φ φ := by + induction n <;> simp [*, exsClosure_succ] + +@[simp] +lemma lMap_allItr {k} (φ : Semiformula L₁ ξ (n + k)) : lMap Φ (∀¹^[k] φ) = ∀¹^[k] lMap Φ φ := by + induction k <;> simp [*, allItr_succ]; + +@[simp] +lemma lMap_exsItr {k} (φ : Semiformula L₁ ξ (n + k)) : lMap Φ (∃¹^[k] φ) = ∃¹^[k] lMap Φ φ := by + induction k <;> simp [*, exsItr_succ]; + +@[simp] +lemma freeVariables_lMap [DecidableEq ξ] (Φ : L₁ →ᵥ L₂) (φ : Semiformula L₁ ξ n) : + (Semiformula.lMap Φ φ).freeVariables = φ.freeVariables := by + induction φ using Semiformula.rec' <;> + try simp [lMap_rel, lMap_nrel, freeVariables_rel, freeVariables_nrel, *] + +section enumerateFVar + +/-- The fvar List construction in `FFL.FirstOrder.Semiformula`. -/ +def fvarList {n : ℕ} : Semiformula L ξ n → List ξ + | ⊤ => [] + | ⊥ => [] + | rel _ v => List.flatten <| Matrix.toList fun i ↦ (v i).fvarList + | nrel _ v => List.flatten <| Matrix.toList fun i ↦ (v i).fvarList + | p ⋏ q => p.fvarList ++ q.fvarList + | p ⋎ q => p.fvarList ++ q.fvarList + | ∀¹ p => p.fvarList + | ∃¹ p => p.fvarList + +/-- The idx Of FVar construction in `FFL.FirstOrder.Semiformula`. -/ +def idxOfFVar [DecidableEq ξ] (φ : Semiformula L ξ n) : ξ → ℕ := + φ.fvarList.idxOf + +/-- The enumerate FVar construction in `FFL.FirstOrder.Semiformula`. -/ +def enumerateFVar [Inhabited ξ] (φ : Semiformula L ξ n) : ℕ → ξ := fun i ↦ + if hi : i < φ.fvarList.length then φ.fvarList.get ⟨i, hi⟩ else default + +lemma enumerateFVar_idxOfFVar [DecidableEq ξ] [Inhabited ξ] {φ : Semiformula L ξ n} {x : ξ} + (hx : x ∈ φ.fvarList) : enumerateFVar φ (idxOfFVar φ x) = x := by + simpa [enumerateFVar, idxOfFVar] using fun h ↦ + False.elim <| not_le.mpr (List.idxOf_lt_length_iff.mpr hx) h + +lemma mem_fvarList_iff_hasFreeVariable [DecidableEq ξ] {φ : Semiformula L ξ n} : + x ∈ φ.fvarList ↔ φ.HasFreeVariable x := by + induction φ using rec' <;> simp [fvarList, Semiterm.mem_fvarList_iff_hasFreeVariable, *] + +end enumerateFVar + +end Semiformula + +/-- The Theory construction in `FFL.FirstOrder`. -/ +abbrev Theory (L : Language) := + Set (Sentence L) + +namespace Theory + +/-- The l Map construction in `FFL.FirstOrder.Theory`. -/ +def lMap (Φ : L₁ →ᵥ L₂) (T : Theory L₁) : Theory L₂ := + Semiformula.lMap Φ '' T + +end Theory + +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Classical/Operator.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Classical/Operator.lean new file mode 100644 index 000000000..840904650 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Classical/Operator.lean @@ -0,0 +1,743 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Syntax.Classical.Rew + +/-! Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace FFL + +namespace FirstOrder + +variable {L : Language} + +namespace Semiterm + +/-- Data and laws for Operator in `FFL.FirstOrder.Semiterm`. -/ +structure Operator (L : Language) (n : ℕ) where + /-- The term construction in `FFL.FirstOrder.Semiterm.Operator`. -/ + term : ClosedSemiterm L n + +/-- The Const construction in `FFL.FirstOrder.Semiterm`. -/ +abbrev Const (L : Language.{u}) := + Operator L 0 + +/-- The fn construction in `FFL.FirstOrder.Semiterm`. -/ +def fn {k} (f : L.Func k) : Operator L k := + ⟨Semiterm.func f (#·)⟩ + +namespace Operator + +/-- The equiv construction in `FFL.FirstOrder.Semiterm.Operator`. -/ +def equiv : Operator L n ≃ ClosedSemiterm L n + where + toFun := Operator.term + invFun := Operator.mk + left_inv := by intro _; simp + right_inv := by intro _; simp + +/-- The operator construction in `FFL.FirstOrder.Semiterm.Operator`. -/ +def operator {arity : ℕ} (o : Operator L arity) (v : Fin arity → Semiterm L ξ n) : + Semiterm L ξ n := + Rew.subst v (Rew.emb o.term) + +/-- The const construction in `FFL.FirstOrder.Semiterm.Operator`. -/ +@[coe] +abbrev const (c : Const L) : Semiterm L ξ n := + c.operator ![] + +instance : Coe (Const L) (Semiterm L ξ n) := + ⟨Operator.const⟩ + +/-- The comp construction in `FFL.FirstOrder.Semiterm.Operator`. -/ +def comp (o : Operator L k) (w : Fin k → Operator L l) : Operator L l := + ⟨o.operator (fun x => (w x).term)⟩ + +@[simp] +lemma operator_comp (o : Operator L k) (w : Fin k → Operator L l) (v : Fin l → Semiterm L ξ n) : + (o.comp w).operator v = o.operator (fun x ↦ (w x).operator v) := + by + simp only [operator, comp, Rew.emb_eq_id, Rew.id_app, ← Rew.comp_app]; congr 1 + ext + · simp [Rew.comp_app] + · contradiction + +/-- The bvar construction in `FFL.FirstOrder.Semiterm.Operator`. -/ +def bvar (x : Fin n) : Operator L n := + ⟨#x⟩ + +lemma operator_bvar (x : Fin k) (v : Fin k → Semiterm L ξ n) : (bvar x).operator v = v x := by + simp [operator, bvar] + +lemma bv_operator {k} (o : Operator L k) (v : Fin k → Semiterm L ξ (n + 1)) : + (o.operator v).bv = .biUnion o.term.bv fun i ↦ (v i).bv := + by + simp only [operator] + generalize o.term = s + induction s + case bvar => simp + case fvar => contradiction + case func => simp [Rew.func, bv_func, Finset.biUnion_biUnion, *] + +lemma positive_operator_iff {k} {o : Operator L k} {v : Fin k → Semiterm L ξ (n + 1)} : + (o.operator v).Positive ↔ ∀ i ∈ o.term.bv, (v i).Positive := by + simpa [Positive, bv_operator] using + ⟨fun h i hi x hx ↦ h x i hi hx, fun h x i hi hx ↦ h i hi x hx⟩ + +@[simp] lemma positive_const (c : Const L) : (c : Semiterm L ξ (n + 1)).Positive := by + simp [const, positive_operator_iff] + +-- f.operator ![ ... f.operator ![f.operator ![z, t 0], t 1], ... ,t (n-1)] +/-- The foldr construction in `FFL.FirstOrder.Semiterm.Operator`. -/ +def foldr (f : Operator L 2) (z : Operator L k) : List (Operator L k) → Operator L k + | [] => z + | o :: os => f.comp ![foldr f z os, o] + +@[simp] +lemma foldr_nil (f : Operator L 2) (z : Operator L k) : f.foldr z [] = z := + rfl + +@[simp] +lemma operator_foldr_cons (f : Operator L 2) (z : Operator L k) (o : Operator L k) + (os : List (Operator L k)) (v : Fin k → Semiterm L ξ n) : + (f.foldr z (o :: os)).operator v = f.operator ![(f.foldr z os).operator v, o.operator v] := + by simp [foldr, operator_comp, Matrix.fun_eq_vec_two] + +/-- The iterr construction in `FFL.FirstOrder.Semiterm.Operator`. -/ +def iterr (f : Operator L 2) (z : Const L) : (n : ℕ) → Operator L n + | 0 => z + | _ + 1 => f.foldr (bvar 0) (List.ofFn fun x => bvar x.succ) + +@[simp] +lemma iterr_zero (f : Operator L 2) (z : Const L) : f.iterr z 0 = z := + rfl + +section numeral + +/-- Data and laws for Zero in `FFL.FirstOrder.Semiterm.Operator`. -/ +protected class Zero (L : Language) where + /-- The zero construction in `FFL.FirstOrder.Semiterm.Operator.Zero`. -/ + zero : Semiterm.Const L + +/-- Data and laws for One in `FFL.FirstOrder.Semiterm.Operator`. -/ +protected class One (L : Language) where + /-- The one construction in `FFL.FirstOrder.Semiterm.Operator.One`. -/ + one : Semiterm.Const L + +/-- Data and laws for Add in `FFL.FirstOrder.Semiterm.Operator`. -/ +protected class Add (L : Language) where + /-- The add construction in `FFL.FirstOrder.Semiterm.Operator.Add`. -/ + add : Semiterm.Operator L 2 + +/-- Data and laws for Mul in `FFL.FirstOrder.Semiterm.Operator`. -/ +protected class Mul (L : Language) where + /-- The mul construction in `FFL.FirstOrder.Semiterm.Operator.Mul`. -/ + mul : Semiterm.Operator L 2 + +/-- Data and laws for Exp in `FFL.FirstOrder.Semiterm.Operator`. -/ +protected class Exp (L : Language) where + /-- The exp construction in `FFL.FirstOrder.Semiterm.Operator.Exp`. -/ + exp : Semiterm.Operator L 1 + +/-- Data and laws for Sub in `FFL.FirstOrder.Semiterm.Operator`. -/ +protected class Sub (L : Language) where + /-- The sub construction in `FFL.FirstOrder.Semiterm.Operator.Sub`. -/ + sub : Semiterm.Operator L 2 + +/-- Data and laws for Div in `FFL.FirstOrder.Semiterm.Operator`. -/ +protected class Div (L : Language) where + /-- The div construction in `FFL.FirstOrder.Semiterm.Operator.Div`. -/ + div : Semiterm.Operator L 2 + +/-- Data and laws for Star in `FFL.FirstOrder.Semiterm.Operator`. -/ +protected class Star (L : Language) where + /-- The star construction in `FFL.FirstOrder.Semiterm.Operator.Star`. -/ + star : Semiterm.Const L + +/-- Data and laws for Gödel Number in `FFL.FirstOrder.Semiterm.Operator`. -/ +class GödelNumber (L : Language) (α : Type*) where + /-- The gödel Number construction in `FFL.FirstOrder.Semiterm.Operator.GödelNumber`. -/ + gödelNumber : α → Semiterm.Const L + +/-- The «term Op(0)» construction in `FFL.FirstOrder.Semiterm.Operator`. -/ +notation "op(0)" => Zero.zero + +/-- The «term Op(0)[ ]» construction in `FFL.FirstOrder.Semiterm.Operator`. -/ +notation "op(0)[" L "]" => Zero.zero (L := L) + +/-- The «term Op(1)» construction in `FFL.FirstOrder.Semiterm.Operator`. -/ +notation "op(1)" => One.one + +/-- The «term Op(1)[ ]» construction in `FFL.FirstOrder.Semiterm.Operator`. -/ +notation "op(1)[" L "]" => One.one (L := L) + +/-- The «term Op(+)» construction in `FFL.FirstOrder.Semiterm.Operator`. -/ +notation "op(+)" => Add.add + +/-- The «term Op(+)[ ]» construction in `FFL.FirstOrder.Semiterm.Operator`. -/ +notation "op(+)[" L "]" => Add.add (L := L) + +/-- The «term Op(*)» construction in `FFL.FirstOrder.Semiterm.Operator`. -/ +notation "op(*)" => Mul.mul + +/-- The «term Op(*)[ ]» construction in `FFL.FirstOrder.Semiterm.Operator`. -/ +notation "op(*)[" L "]" => Mul.mul (L := L) + +instance [L.Zero] : Operator.Zero L := + ⟨⟨Semiterm.func Language.Zero.zero ![]⟩⟩ + +instance [L.One] : Operator.One L := + ⟨⟨Semiterm.func Language.One.one ![]⟩⟩ + +instance [L.Add] : Operator.Add L := + ⟨⟨Semiterm.func Language.Add.add Semiterm.bvar⟩⟩ + +instance [L.Mul] : Operator.Mul L := + ⟨⟨Semiterm.func Language.Mul.mul Semiterm.bvar⟩⟩ + +instance [L.Exp] : Operator.Exp L := + ⟨⟨Semiterm.func Language.Exp.exp Semiterm.bvar⟩⟩ + +instance [L.Star] : Operator.Star L := + ⟨⟨Semiterm.func Language.Star.star ![]⟩⟩ + +lemma Zero.term_eq [L.Zero] : (@Zero.zero L _).term = Semiterm.func Language.Zero.zero ![] := + rfl + +lemma One.term_eq [L.One] : (@One.one L _).term = Semiterm.func Language.One.one ![] := + rfl + +lemma Add.term_eq [L.Add] : + (@Add.add L _).term = Semiterm.func Language.Add.add Semiterm.bvar := + rfl + +lemma Mul.term_eq [L.Mul] : + (@Mul.mul L _).term = Semiterm.func Language.Mul.mul Semiterm.bvar := + rfl + +lemma Exp.term_eq [L.Exp] : + (@Exp.exp L _).term = Semiterm.func Language.Exp.exp Semiterm.bvar := + rfl + +lemma Star.term_eq [L.Star] : (@Star.star L _).term = Semiterm.func Language.Star.star ![] := + rfl + +open Language Semiterm + +/-- The numeral construction in `FFL.FirstOrder.Semiterm.Operator`. -/ +def numeral (L : Language) [Operator.Zero L] [Operator.One L] [Operator.Add L] : ℕ → Const L + | 0 => Zero.zero + | n + 1 => Add.add.foldr One.one (List.replicate n One.one) + +variable [hz : Operator.Zero L] [ho : Operator.One L] [ha : Operator.Add L] + +lemma numeral_zero : numeral L 0 = Zero.zero := by rfl + +lemma numeral_one : numeral L 1 = One.one := by rfl + +lemma numeral_succ (hz : z ≠ 0) : + numeral L (z + 1) = Operator.Add.add.comp ![numeral L z, One.one] := + by + simp only [numeral] + rcases z with _ | z + · simp at hz + · rfl + +lemma numeral_add_two : + numeral L (z + 2) = Operator.Add.add.comp ![numeral L (z + 1), One.one] := + numeral_succ (by simp) + +/-- The encode construction in `FFL.FirstOrder.Semiterm.Operator`. -/ +protected abbrev encode (L : Language) [Operator.Zero L] [Operator.One L] [Operator.Add L] + {α : Type*} [Encodable α] (a : α) : Semiterm.Const L := + Semiterm.Operator.numeral L (Encodable.encode a) + +end numeral + +@[simp] +lemma Add.positive_iff [L.Add] (t u : Semiterm L ξ (n + 1)) : + (add.operator ![t, u]).Positive ↔ t.Positive ∧ u.Positive := by + simp [positive_operator_iff, Add.term_eq, bv_func] + +@[simp] +lemma Mul.positive_iff [L.Mul] (t u : Semiterm L ξ (n + 1)) : + (mul.operator ![t, u]).Positive ↔ t.Positive ∧ u.Positive := by + simp [positive_operator_iff, Mul.term_eq, bv_func] + +@[simp] +lemma Exp.positive_iff [L.Exp] (t : Semiterm L ξ (n + 1)) : + (exp.operator ![t]).Positive ↔ t.Positive := by + simp [positive_operator_iff, Exp.term_eq, bv_func] + +section npow + +/-- The npow construction in `FFL.FirstOrder.Semiterm.Operator`. -/ +def npow (L : Language) [Operator.One L] [Operator.Mul L] (n : ℕ) : Operator L 1 := + Operator.Mul.mul.foldr (One.one.comp ![]) (List.replicate n (bvar 0)) + +variable [Operator.One L] [Operator.Mul L] + +lemma npow_zero : npow L 0 = One.one.comp ![] := + rfl + +lemma npow_succ : npow L (n + 1) = Operator.Mul.mul.comp ![npow L n, bvar 0] := + rfl + +end npow + +@[simp] +lemma npow_positive_iff [Operator.One L] [L.Mul] (t : Semiterm L ξ (n + 1)) (k : ℕ) : + ((Operator.npow L k).operator ![t]).Positive ↔ k = 0 ∨ t.Positive := + by + cases k + case zero => simp [positive_operator_iff, operator_comp, npow_zero] + case succ k + n => + simp [positive_operator_iff, operator_comp, npow_succ, Mul.term_eq, bv_func, + Fin.forall_fin_iff_zero_and_forall_succ, bvar] + tauto + +namespace GödelNumber + +variable {α} [GödelNumber L α] + +/-- The gödel Number' construction in `FFL.FirstOrder.Semiterm.Operator.GödelNumber`. -/ +abbrev gödelNumber' (a : α) : Semiterm L ξ n := + const (gödelNumber a) + +instance : GödelQuote α (Semiterm L ξ n) := + ⟨gödelNumber'⟩ + +/-- The of Encodable construction in `FFL.FirstOrder.Semiterm.Operator.GödelNumber`. -/ +abbrev ofEncodable [Operator.Zero L] [Operator.One L] [Operator.Add L] {α : Type*} + [Encodable α] : GödelNumber L α := + ⟨Operator.encode L⟩ + +end GödelNumber + +end Operator + +section complexity + +variable {L : Language} + +@[simp] +lemma complexity_zero [L.Zero] : + ((Operator.Zero.zero : Const L) : Semiterm L ξ n).complexity = 1 := by + simp [Operator.const, Operator.operator, Operator.Zero.term_eq, complexity_func] + +@[simp] +lemma complexity_one [L.One] : ((Operator.One.one : Const L) : Semiterm L ξ n).complexity = 1 := + by simp [Operator.const, Operator.operator, Operator.One.term_eq, complexity_func] + +@[simp] +lemma complexity_add [L.Add] (t u : Semiterm L ξ n) : + (Operator.Add.add.operator ![t, u]).complexity = max t.complexity u.complexity + 1 := + by + simp [Operator.operator, Operator.Add.term_eq, complexity_func, Rew.func] + simp [show (Finset.univ : Finset (Fin 2)) = {0, 1} from by ext i; fin_cases i <;> simp] + +@[simp] +lemma complexity_mul [L.Mul] (t u : Semiterm L ξ n) : + (Operator.Mul.mul.operator ![t, u]).complexity = max t.complexity u.complexity + 1 := + by + simp [Operator.operator, Operator.Mul.term_eq, complexity_func, Rew.func] + simp [show (Finset.univ : Finset (Fin 2)) = {0, 1} from by ext i; fin_cases i <;> simp] + +end complexity + +end Semiterm + +namespace Semiformula + +/-- Data and laws for Operator in `FFL.FirstOrder.Semiformula`. -/ +structure Operator (L : Language.{u}) (n : ℕ) where + /-- The sentence construction in `FFL.FirstOrder.Semiformula.Operator`. -/ + sentence : Semisentence L n + +/-- The Const construction in `FFL.FirstOrder.Semiformula`. -/ +abbrev Const (L : Language.{u}) := + Operator L 0 + +namespace Operator + +/-- The operator construction in `FFL.FirstOrder.Semiformula.Operator`. -/ +def operator {arity : ℕ} (o : Operator L arity) (v : Fin arity → Semiterm L ξ n) : + Semiformula L ξ n := + Rewriting.emb o.sentence ↜ v + +/-- The const construction in `FFL.FirstOrder.Semiformula.Operator`. -/ +@[coe] +def const (c : Const L) : Semiformula L ξ n := + c.operator ![] + +instance : Coe (Const L) (Semiformula L ξ n) := + ⟨Operator.const⟩ + +/-- The comp construction in `FFL.FirstOrder.Semiformula.Operator`. -/ +def comp (o : Operator L k) (w : Fin k → Semiterm.Operator L l) : Operator L l := + ⟨o.operator (fun x => (w x).term)⟩ + +lemma operator_comp (o : Operator L k) (w : Fin k → Semiterm.Operator L l) + (v : Fin l → Semiterm L ξ n) : + (o.comp w).operator v = o.operator (fun x => (w x).operator v) := + by + unfold operator Rewriting.emb Rewriting.subst comp + simp only [operator, ← TransitiveRewriting.comp_app, Rew.emb_eq_id, Rew.comp_id]; congr 2 + ext + · simp [Rew.comp_app]; congr + · contradiction + +/-- The and construction in `FFL.FirstOrder.Semiformula.Operator`. -/ +def and {k} (o₁ o₂ : Operator L k) : Operator L k := + ⟨o₁.sentence ⋏ o₂.sentence⟩ + +/-- The or construction in `FFL.FirstOrder.Semiformula.Operator`. -/ +def or {k} (o₁ o₂ : Operator L k) : Operator L k := + ⟨o₁.sentence ⋎ o₂.sentence⟩ + +@[simp] +lemma operator_and (o₁ o₂ : Operator L k) (v : Fin k → Semiterm L ξ n) : + (o₁.and o₂).operator v = o₁.operator v ⋏ o₂.operator v := by simp [operator, and] + +@[simp] +lemma operator_or (o₁ o₂ : Operator L k) (v : Fin k → Semiterm L ξ n) : + (o₁.or o₂).operator v = o₁.operator v ⋎ o₂.operator v := by simp [operator, or] + +/-- Data and laws for Eq in `FFL.FirstOrder.Semiformula.Operator`. -/ +protected class Eq (L : Language) where + /-- The eq construction in `FFL.FirstOrder.Semiformula.Operator.Eq`. -/ + eq : Semiformula.Operator L 2 + +/-- Data and laws for LT in `FFL.FirstOrder.Semiformula.Operator`. -/ +protected class LT (L : Language) where + /-- The lt construction in `FFL.FirstOrder.Semiformula.Operator.LT`. -/ + lt : Semiformula.Operator L 2 + +/-- Data and laws for LE in `FFL.FirstOrder.Semiformula.Operator`. -/ +protected class LE (L : Language) where + /-- The le construction in `FFL.FirstOrder.Semiformula.Operator.LE`. -/ + le : Semiformula.Operator L 2 + +/-- Data and laws for Mem in `FFL.FirstOrder.Semiformula.Operator`. -/ +protected class Mem (L : Language) where + /-- The mem construction in `FFL.FirstOrder.Semiformula.Operator.Mem`. -/ + mem : Semiformula.Operator L 2 + +/-- The «term Op(=)» construction in `FFL.FirstOrder.Semiformula.Operator`. -/ +notation "op(=)" => Operator.Eq.eq + +/-- The «term Op(=)[ ]» construction in `FFL.FirstOrder.Semiformula.Operator`. -/ +notation "op(=)[" L "]" => Operator.Eq.eq (L := L) + +/-- The «term Op(<)» construction in `FFL.FirstOrder.Semiformula.Operator`. -/ +notation "op(<)" => Operator.LT.lt + +/-- The «term Op(<)[ ]» construction in `FFL.FirstOrder.Semiformula.Operator`. -/ +notation "op(<)[" L "]" => Operator.LT.lt (L := L) + +/-- The «term Op(≤)» construction in `FFL.FirstOrder.Semiformula.Operator`. -/ +notation "op(≤)" => Operator.LE.le + +/-- The «term Op(≤)[ ]» construction in `FFL.FirstOrder.Semiformula.Operator`. -/ +notation "op(≤)[" L "]" => Operator.LE.le (L := L) + +/-- The «term Op(∈)» construction in `FFL.FirstOrder.Semiformula.Operator`. -/ +notation "op(∈)" => Operator.Mem.mem + +/-- The «term Op(∈)[ ]» construction in `FFL.FirstOrder.Semiformula.Operator`. -/ +notation "op(∈)[" L "]" => Operator.Mem.mem (L := L) + +instance [Language.Eq L] : Operator.Eq L := + ⟨⟨Semiformula.rel Language.Eq.eq Semiterm.bvar⟩⟩ + +instance [Language.LT L] : Operator.LT L := + ⟨⟨Semiformula.rel Language.LT.lt Semiterm.bvar⟩⟩ + +instance [L.Mem] : Operator.Mem L := + ⟨⟨Semiformula.rel Language.Mem.mem Semiterm.bvar⟩⟩ + +instance [Operator.Eq L] [Operator.LT L] : Operator.LE L := + ⟨Eq.eq.or LT.lt⟩ + +lemma Eq.sentence_eq [L.Eq] : + (@Eq.eq L _).sentence = Semiformula.rel Language.Eq.eq Semiterm.bvar := + rfl + +lemma LT.sentence_eq [L.LT] : + (@LT.lt L _).sentence = Semiformula.rel Language.LT.lt Semiterm.bvar := + rfl + +lemma Mem.sentence_eq [L.Mem] : + (@Mem.mem L _).sentence = Semiformula.rel Language.Mem.mem Semiterm.bvar := + rfl + +lemma LE.sentence_eq [L.Eq] [L.LT] : (@LE.le L _).sentence = Eq.eq.sentence ⋎ LT.lt.sentence := + rfl + +lemma LE.def_of_Eq_of_LT [Operator.Eq L] [Operator.LT L] : + (@Operator.LE.le L _) = Eq.eq.or LT.lt := + rfl + +@[simp] +lemma Eq.equal_inj [L.Eq] {t₁ t₂ u₁ u₂ : Semiterm L ξ₂ n₂} : + Eq.eq.operator ![t₁, u₁] = Eq.eq.operator ![t₂, u₂] ↔ t₁ = t₂ ∧ u₁ = u₂ := by + simp [operator, Eq.sentence_eq, Matrix.fun_eq_vec_two] + +@[simp] +lemma LT.lt_inj [L.LT] {t₁ t₂ u₁ u₂ : Semiterm L ξ₂ n₂} : + LT.lt.operator ![t₁, u₁] = LT.lt.operator ![t₂, u₂] ↔ t₁ = t₂ ∧ u₁ = u₂ := by + simp [operator, LT.sentence_eq, Matrix.fun_eq_vec_two] + +@[simp] +lemma Mem.mem_inj [L.Mem] {t₁ t₂ u₁ u₂ : Semiterm L ξ₂ n₂} : + Mem.mem.operator ![t₁, u₁] = Mem.mem.operator ![t₂, u₂] ↔ t₁ = t₂ ∧ u₁ = u₂ := by + simp [operator, Mem.sentence_eq, Matrix.fun_eq_vec_two] + +@[simp] +lemma LE.le_inj [L.Eq] [L.LT] {t₁ t₂ u₁ u₂ : Semiterm L ξ₂ n₂} : + LE.le.operator ![t₁, u₁] = LE.le.operator ![t₂, u₂] ↔ t₁ = t₂ ∧ u₁ = u₂ := by + simp [operator, LE.sentence_eq, Eq.sentence_eq, LT.sentence_eq, Matrix.fun_eq_vec_two]; + +lemma lt_def [L.LT] (t u : Semiterm L ξ n) : + LT.lt.operator ![t, u] = Semiformula.rel Language.LT.lt ![t, u] := by + simp [operator, LT.sentence_eq, Matrix.fun_eq_vec_two] + +lemma eq_def [L.Eq] (t u : Semiterm L ξ n) : + Eq.eq.operator ![t, u] = Semiformula.rel Language.Eq.eq ![t, u] := by + simp [operator, Eq.sentence_eq, Matrix.fun_eq_vec_two] + +lemma mem_def [L.Mem] (t u : Semiterm L ξ n) : + Mem.mem.operator ![t, u] = Semiformula.rel Language.Mem.mem ![t, u] := by + simp [operator, Mem.sentence_eq, Matrix.fun_eq_vec_two] + +lemma le_def [L.Eq] [L.LT] (t u : Semiterm L ξ n) : + LE.le.operator ![t, u] = + Semiformula.rel Language.Eq.eq ![t, u] ⋎ Semiformula.rel Language.LT.lt ![t, u] := + by simp [operator, Eq.sentence_eq, LT.sentence_eq, LE.sentence_eq, Matrix.fun_eq_vec_two] + +variable {L : Language} + +@[simp] +lemma Eq.open [L.Eq] (t u : Semiterm L ξ n) : (Eq.eq.operator ![t, u]).Open := by + simp [Operator.operator, Operator.Eq.sentence_eq, open_rel] + +@[simp] +lemma LT.open [L.LT] (t u : Semiterm L ξ n) : (LT.lt.operator ![t, u]).Open := by + simp [Operator.operator, Operator.LT.sentence_eq, open_rel] + +@[simp] +lemma Mem.open [L.Mem] (t u : Semiterm L ξ n) : (Mem.mem.operator ![t, u]).Open := by + simp [Operator.operator, Operator.Mem.sentence_eq, open_rel] + +@[simp] +lemma LE.open [L.Eq] [L.LT] (t u : Semiterm L ξ n) : (LE.le.operator ![t, u]).Open := by + simp [Operator.operator, Operator.LE.sentence_eq, Operator.Eq.sentence_eq, + Operator.LT.sentence_eq, open_rel] + +end Operator + +/-- The ball LT construction in `FFL.FirstOrder.Semiformula`. -/ +def ballLT [Operator.LT L] (t : Semiterm L ξ n) (φ : Semiformula L ξ (n + 1)) : + Semiformula L ξ n := + ∀¹[Operator.LT.lt.operator ![#0, Rew.bShift t]] φ + +/-- The bexs LT construction in `FFL.FirstOrder.Semiformula`. -/ +def bexsLT [Operator.LT L] (t : Semiterm L ξ n) (φ : Semiformula L ξ (n + 1)) : + Semiformula L ξ n := + ∃¹[Operator.LT.lt.operator ![#0, Rew.bShift t]] φ + +/-- The ball LE construction in `FFL.FirstOrder.Semiformula`. -/ +def ballLE [Operator.LE L] (t : Semiterm L ξ n) (φ : Semiformula L ξ (n + 1)) : + Semiformula L ξ n := + ∀¹[Operator.LE.le.operator ![#0, Rew.bShift t]] φ + +/-- The bexs LE construction in `FFL.FirstOrder.Semiformula`. -/ +def bexsLE [Operator.LE L] (t : Semiterm L ξ n) (φ : Semiformula L ξ (n + 1)) : + Semiformula L ξ n := + ∃¹[Operator.LE.le.operator ![#0, Rew.bShift t]] φ + +/-- The ball Mem construction in `FFL.FirstOrder.Semiformula`. -/ +def ballMem [Operator.Mem L] (t : Semiterm L ξ n) (φ : Semiformula L ξ (n + 1)) : + Semiformula L ξ n := + ∀¹[Operator.Mem.mem.operator ![#0, Rew.bShift t]] φ + +/-- The bexs Mem construction in `FFL.FirstOrder.Semiformula`. -/ +def bexsMem [Operator.Mem L] (t : Semiterm L ξ n) (φ : Semiformula L ξ (n + 1)) : + Semiformula L ξ n := + ∃¹[Operator.Mem.mem.operator ![#0, Rew.bShift t]] φ + +end Semiformula + +namespace Rew + +variable {L L' : Language.{u}} {L₁ : Language.{u₁}} {L₂ : Language.{u₂}} {L₃ : Language.{u₃}} + +variable (ω : Rew L ξ₁ n₁ ξ₂ n₂) + +protected lemma operator (o : Semiterm.Operator L k) (v : Fin k → Semiterm L ξ₁ n₁) : + ω (o.operator v) = o.operator (fun i ↦ ω (v i)) := + by + simp only [Semiterm.Operator.operator, ← comp_app]; congr 1 + ext + · simp [comp_app] + · contradiction + +protected lemma operator' (o : Semiterm.Operator L k) (v : Fin k → Semiterm L ξ₁ n₁) : + ω (o.operator v) = o.operator (ω ∘ v) := + ω.operator o v + +@[simp] +lemma finitary0 (o : Semiterm.Operator L 0) (v : Fin 0 → Semiterm L ξ₁ n₁) : + ω (o.operator v) = o.operator ![] := by simp [ω.operator', Matrix.empty_eq] + +@[simp] +lemma finitary1 (o : Semiterm.Operator L 1) (t : Semiterm L ξ₁ n₁) : + ω (o.operator ![t]) = o.operator ![ω t] := by simp [ω.operator'] + +@[simp] +lemma finitary2 (o : Semiterm.Operator L 2) (t₁ t₂ : Semiterm L ξ₁ n₁) : + ω (o.operator ![t₁, t₂]) = o.operator ![ω t₁, ω t₂] := by simp [ω.operator'] + +@[simp] +lemma finitary3 (o : Semiterm.Operator L 3) (t₁ t₂ t₃ : Semiterm L ξ₁ n₁) : + ω (o.operator ![t₁, t₂, t₃]) = o.operator ![ω t₁, ω t₂, ω t₃] := by simp [ω.operator'] + +protected lemma const (c : Semiterm.Const L) : ω c = c := by simp [Semiterm.Operator.const] + +lemma hom_operator (o : Semiformula.Operator L k) (v : Fin k → Semiterm L ξ₁ n₁) : + ω ▹ o.operator v = o.operator fun i ↦ ω (v i) := + by + unfold Semiformula.Operator.operator Rewriting.subst Rewriting.emb + simp only [← TransitiveRewriting.comp_app]; congr 2 + ext + · simp [Rew.comp_app] + · contradiction + +lemma hom_operator' (o : Semiformula.Operator L k) (v : Fin k → Semiterm L ξ₁ n₁) : + ω ▹ o.operator v = o.operator (ω ∘ v) := + ω.hom_operator o v + +@[simp] +lemma hom_finitary0 (o : Semiformula.Operator L 0) (v : Fin 0 → Semiterm L ξ₁ n₁) : + ω ▹ (o.operator v) = o.operator ![] := by simp [ω.hom_operator', Matrix.empty_eq] + +@[simp] +lemma hom_finitary1 (o : Semiformula.Operator L 1) (t : Semiterm L ξ₁ n₁) : + ω ▹ (o.operator ![t]) = o.operator ![ω t] := by simp [ω.hom_operator'] + +@[simp] +lemma hom_finitary2 (o : Semiformula.Operator L 2) (t₁ t₂ : Semiterm L ξ₁ n₁) : + ω ▹ (o.operator ![t₁, t₂]) = o.operator ![ω t₁, ω t₂] := by simp [ω.hom_operator'] + +@[simp] +lemma hom_finitary3 (o : Semiformula.Operator L 3) (t₁ t₂ t₃ : Semiterm L ξ₁ n₁) : + ω ▹ (o.operator ![t₁, t₂, t₃]) = o.operator ![ω t₁, ω t₂, ω t₃] := by simp [ω.hom_operator'] + +@[simp] +lemma hom_const : + ω ▹ (Semiformula.Operator.const c : Semiformula L ξ₁ n₁) = Semiformula.Operator.const c := + by simp [Semiformula.Operator.const, ω.hom_operator'] + +open Semiformula + +lemma eq_equal_iff [L.Eq] {φ : Semiformula L ξ₁ n₁} {t u : Semiterm L ξ₂ n₂} : + ω ▹ φ = Operator.Eq.eq.operator ![t, u] ↔ + ∃ t' u', ω t' = t ∧ ω u' = u ∧ φ = Operator.Eq.eq.operator ![t', u'] := + by + match φ with + | .rel (arity := k') r' v => + by_cases hk : k' = 2 + case neg => simp [Operator.operator, Operator.Eq.sentence_eq, hk] + rcases hk + by_cases hr : r' = Language.Eq.eq + case neg => simp [Operator.operator, Operator.Eq.sentence_eq, hr] + rcases hr + simp [Operator.operator, Operator.Eq.sentence_eq, funext_iff, + Fin.forall_fin_iff_zero_and_forall_succ] + | .nrel _ _ => simp [Operator.operator, Operator.Eq.sentence_eq] + | ⊤ => simp [Operator.operator, Operator.Eq.sentence_eq] + | ⊥ => simp [Operator.operator, Operator.Eq.sentence_eq] + | _ ⋏ _ => simp [Operator.operator, Operator.Eq.sentence_eq] + | _ ⋎ _ => simp [Operator.operator, Operator.Eq.sentence_eq] + | ∀¹ _ => simp [Operator.operator, Operator.Eq.sentence_eq] + | ∃¹ _ => simp [Operator.operator, Operator.Eq.sentence_eq] + +lemma eq_lt_iff [L.LT] {φ : Semiformula L ξ₁ n₁} {t u : Semiterm L ξ₂ n₂} : + ω ▹ φ = Operator.LT.lt.operator ![t, u] ↔ + ∃ t' u', ω t' = t ∧ ω u' = u ∧ φ = Operator.LT.lt.operator ![t', u'] := + by + match φ with + | .rel (arity := k') r' v => + by_cases hk : k' = 2 + case neg => simp [Operator.operator, Operator.LT.sentence_eq, hk] + rcases hk + by_cases hr : r' = Language.LT.lt + case neg => simp [Operator.operator, Operator.LT.sentence_eq, hr] + rcases hr + simp [Operator.operator, Operator.LT.sentence_eq, funext_iff, + Fin.forall_fin_iff_zero_and_forall_succ] + | .nrel _ _ => simp [Operator.operator, Operator.LT.sentence_eq] + | ⊤ => simp [Operator.operator, Operator.LT.sentence_eq] + | ⊥ => simp [Operator.operator, Operator.LT.sentence_eq] + | _ ⋏ _ => simp [Operator.operator, Operator.LT.sentence_eq] + | _ ⋎ _ => simp [Operator.operator, Operator.LT.sentence_eq] + | ∀¹ _ => simp [Operator.operator, Operator.LT.sentence_eq] + | ∃¹ _ => simp [Operator.operator, Operator.LT.sentence_eq] + +lemma eq_mem_iff [L.Mem] {φ : Semiformula L ξ₁ n₁} {t u : Semiterm L ξ₂ n₂} : + ω ▹ φ = Operator.Mem.mem.operator ![t, u] ↔ + ∃ t' u', ω t' = t ∧ ω u' = u ∧ φ = Operator.Mem.mem.operator ![t', u'] := + by + match φ with + | .rel (arity := k') r' v => + by_cases hk : k' = 2 + case neg => simp [Operator.operator, Operator.Mem.sentence_eq, hk] + rcases hk + by_cases hr : r' = Language.Mem.mem + case neg => simp [Operator.operator, Operator.Mem.sentence_eq, hr] + rcases hr + simp [Operator.operator, Operator.Mem.sentence_eq, funext_iff, + Fin.forall_fin_iff_zero_and_forall_succ] + | .nrel _ _ => simp [Operator.operator, Operator.Mem.sentence_eq] + | ⊤ => simp [Operator.operator, Operator.Mem.sentence_eq] + | ⊥ => simp [Operator.operator, Operator.Mem.sentence_eq] + | _ ⋏ _ => simp [Operator.operator, Operator.Mem.sentence_eq] + | _ ⋎ _ => simp [Operator.operator, Operator.Mem.sentence_eq] + | ∀¹ _ => simp [Operator.operator, Operator.Mem.sentence_eq] + | ∃¹ _ => simp [Operator.operator, Operator.Mem.sentence_eq] + +end Rew + +namespace Semiterm + +variable [L.Zero] [L.One] [L.Add] + +/-- The numeral construction in `FFL.FirstOrder.Semiterm`. -/ +@[coe] +abbrev numeral (k : ℕ) : Semiterm L ξ n := + Operator.numeral L k + +instance : Coe ℕ (Semiterm L ξ n) := + ⟨numeral⟩ + +end Semiterm + +end FirstOrder + +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Classical/Padding.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Classical/Padding.lean new file mode 100644 index 000000000..56f27ff34 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Classical/Padding.lean @@ -0,0 +1,101 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Tarski.Basic +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.LK.Basic + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace FFL +namespace FirstOrder + +variable {L : Language} {ξ : Type*} + +namespace Semiformula + +/-- The padding construction in `FFL.FirstOrder.Semiformula`. -/ +def padding (φ : Semiformula L ξ n) (k : ℕ) := + φ ⋏ (PointwiseComposition.List.conj (List.replicate k ⊤)) + +/-- The get Padding Aux construction in `FFL.FirstOrder.Semiformula`. -/ +def getPaddingAux : Semiformula L ξ n → Option ℕ + | ⊤ => some 0 + | ⊤ ⋏ φ => φ.getPaddingAux.map fun x ↦ x + 1 + | _ => none + +/-- The get Padding construction in `FFL.FirstOrder.Semiformula`. -/ +def getPadding : Semiformula L ξ n → Option ℕ + | _ ⋏ φ => φ.getPaddingAux + | _ => none + +/-- The get Padding Formula construction in `FFL.FirstOrder.Semiformula`. -/ +def getPaddingFormula : Semiformula L ξ n → Option (Semiformula L ξ n) + | φ ⋏ _ => some φ + | _ => none + +@[simp] +lemma getPadding_padding (φ : Semiformula L ξ n) : (φ.padding k).getPadding = some k := + by + suffices + (PointwiseComposition.List.conj (List.replicate k (⊤ : Semiformula L ξ n))).getPaddingAux = + some k + by simpa [getPadding, padding] + induction k <;> simp [List.replicate_succ, getPaddingAux, *] + +@[simp] +lemma getPaddingFormula_padding (φ : Semiformula L ξ n) : + (φ.padding k).getPaddingFormula = some φ := by simp [padding, getPaddingFormula] + +@[simp] +lemma padding_injective_iff {φ ψ : Semiformula L ξ n} : + φ.padding k = ψ.padding m ↔ φ = ψ ∧ k = m := + ⟨fun h ↦ + ⟨by simpa using congr_arg getPaddingFormula h, by simpa using congr_arg getPadding h⟩, by + rintro ⟨rfl, rfl⟩; rfl⟩ + +@[simp] +lemma rew_padding (ω : Rew L ξ n ξ' n') (φ : Semiformula L ξ n) : + ω ▹ φ.padding k = (ω ▹ φ).padding k := + by + simp [padding] + induction k <;> simp [List.replicate_succ, *] + +end Semiformula + +open Entailment + +/-- The padding Iff construction in `FFL.FirstOrder.Entailment`. -/ +def Entailment.paddingIff [L.DecidableEq] [DecidableEq ξ] [Entailment S (Formula L ξ)] {𝓢 : S} + [Entailment.Minimal 𝓢] (φ k) : 𝓢 ⊢! φ.padding k ⇔ₗ φ := + by + apply EProofIntro + · apply and₁Proof + · apply rightKProofIntro + · apply CProofId + · apply dhypProof + apply ConjProofIntro + intro φ hφ + have : k ≠ 0 ∧ φ = ⊤ := by simpa using hφ; + exact this.2 ▸ HasAxiomVerum.verumProof + +@[simp] +theorem Entailment.padding_iff [L.DecidableEq] [Entailment S (Formula L ξ)] {𝓢 : S} + [Entailment.Minimal 𝓢] (φ k) : 𝓢 ⊢ φ.padding k ⇔ₗ φ := by classical exact ⟨paddingIff φ k⟩ + +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Classical/PrimrecCoding.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Classical/PrimrecCoding.lean new file mode 100644 index 000000000..823510880 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Classical/PrimrecCoding.lean @@ -0,0 +1,1081 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Syntax.Classical.Coding +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Computability + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +/-! +# `Primcodable` for `Semiterm` and `Semiformula` (issue #506) + +`Semiterm.ofNat`/`Semiformula.ofNat` are strong recursions on the code: the `func` branch reads an +argument vector out of the code and calls itself on each entry. Their `Primrec` versions go +through `Primrec.nat_strong_rec` (terms) and `Primrec.nat_omega_rec'` (formulas), whose step +functions this file builds. Two design points: + +Everything happens at the level of codes. The table entry for a sub-code `j` is +`encode (ofNat n j)`, and `encode` on `Option` is `0` for `none` and `encode t + 1` for `some t`, +so a successful entry already contains the argument's `toNat`, one less than itself, and the +argument-vector code is rebuilt by arithmetic alone. No term is ever reconstructed, and nothing +here needs `L` or `ξ` decidable. + +`Option` is kept out of the folds. `stepVec` returns `ℕ` with `0` for failure and `r + 1` for +success with value `r`: with `Option ℕ` as the fold's accumulator, the `Primrec` combinators must +synthesise `Primcodable` for towers of products ending in `Option ℕ`, and elaboration diverges. +The `ℕ` encoding costs one `- 1` per lookup and elaborates immediately. + +`Nat.natToList` (`Vorspiel/Nat/Matrix.lean`) is used throughout for the same reason: +`Nat.natToVec` produces a `Fin k → ℕ` whose length lives in its type, which no `Primrec` +combinator can consume, so `natToList` is the same decoding without the dependency, and +`natToVec_eq_some_iff` lets the correctness proofs move between them. +-/ + +namespace Matrix + +open _root_.Matrix + +/-- The equation lemma that keeps reasoning out of `Option`'s applicative layer: at `Option`, +`getM`'s recursive step is a `bind` of a `map`. -/ +lemma getM_option_succ {n : ℕ} {β : Type*} (f : Fin (n + 1) → Option β) : + Matrix.getM f = + (f 0).bind fun a ↦ (Matrix.getM fun j ↦ f j.succ).map fun w ↦ Fin.cases a w := + by + rw [Matrix.getM] + rcases f 0 with _ | a + · rfl + · rcases Matrix.getM (fun j ↦ f j.succ) with _ | w <;> rfl + +/-- `getM` at `Option` succeeds exactly when every component does. This is what turns the `func` +branch of `ofNat` into a statement about each argument separately. -/ +lemma getM_option_eq_some_iff {n : ℕ} {β : Type*} {f : Fin n → Option β} {v : Fin n → β} : + Matrix.getM f = some v ↔ ∀ i, f i = some (v i) := by + induction n with + | zero => + refine ⟨fun _ i ↦ i.elim0, fun _ ↦ ?_⟩ + rw [Matrix.getM] + exact congrArg some (funext fun i ↦ i.elim0) + | succ n ih => + rw [getM_option_succ] + constructor + · intro h + rw [Option.bind_eq_some_iff] at h + obtain ⟨a, ha, hm⟩ := h + rw [Option.map_eq_some_iff] at hm + obtain ⟨w, hw, rfl⟩ := hm + intro i + exact i.cases (by simpa using ha) (by simpa using ih.mp hw) + · intro h + refine Option.bind_eq_some_iff.mpr ⟨v 0, by simpa using h 0, ?_⟩ + refine + Option.map_eq_some_iff.mpr + ⟨fun j ↦ v j.succ, ih.mpr fun j ↦ by simpa using h j.succ, ?_⟩ + exact funext fun i ↦ i.cases (by simp) (by simp) + +end Matrix + +namespace FFL +namespace FirstOrder + +open _root_.Nat Encodable Nat + +/-- Primitive-recursiveness of a language's symbol encodings, uniformly in the arity. + +This is strictly stronger than `[(k : ℕ) → Primcodable (L.Func k)]`, necessarily so: +`Semiterm.ofNat` reads the arity `k` *out of the code being decoded* and then calls +`decode : ℕ → Option (L.Func k)` at that `k`, so simulating it needs +`(k, e) ↦ encode (decode e : Option (L.Func k))` to be primitive recursive as a function of the +pair. A per-arity family gives primitive recursiveness only at each fixed `k`, with no uniformity +across `k`. -/ +protected class Language.Primcodable (L : Language) [L.Encodable] where + func : Primrec₂ fun k e : ℕ ↦ Encodable.encode (Encodable.decode e : Option (L.Func k)) + rel : Primrec₂ fun k e : ℕ ↦ Encodable.encode (Encodable.decode e : Option (L.Rel k)) + +section + +variable (L : Language) [L.Encodable] [L.Primcodable] + +instance (k : ℕ) : Primcodable (L.Func k) + where + toEncodable := Language.Encodable.func k + prim := + Primrec.nat_iff.mp <| (Language.Primcodable.func (L := L)).comp (Primrec.const k) Primrec.id + +instance (k : ℕ) : Primcodable (L.Rel k) + where + toEncodable := Language.Encodable.rel k + prim := + Primrec.nat_iff.mp <| (Language.Primcodable.rel (L := L)).comp (Primrec.const k) Primrec.id + +end + +/-- `ℒₒᵣ` satisfies the uniform condition: `encode ∘ decode` is +`fun k e ↦ if (k = 0 ∨ k = 2) ∧ e < 2 then e + 1 else 0`. -/ +instance : Language.Primcodable ℒₒᵣ + where + func := + by + have h : Primrec fun p : ℕ × ℕ ↦ if (p.1 = 0 ∨ p.1 = 2) ∧ p.2 < 2 then p.2 + 1 else 0 := + Primrec.ite + (PrimrecPred.and + (PrimrecPred.or (Primrec.eq.comp Primrec.fst (Primrec.const 0)) + (Primrec.eq.comp Primrec.fst (Primrec.const 2))) + (Primrec.nat_lt.comp Primrec.snd (Primrec.const 2))) + (Primrec.succ.comp Primrec.snd) (Primrec.const 0) + refine h.of_eq ?_ + rintro ⟨k, e⟩ + match k, e with + | 0, 0 => rfl + | 0, 1 => rfl + | 0, _ + 2 => simp [Encodable.decode] + | 1, _ => simp [Encodable.decode] + | 2, 0 => rfl + | 2, 1 => rfl + | 2, _ + 2 => simp [Encodable.decode] + | _ + 3, _ => simp [Encodable.decode] + rel := + by + have h : Primrec fun p : ℕ × ℕ ↦ if p.1 = 2 ∧ p.2 < 2 then p.2 + 1 else 0 := + Primrec.ite + (PrimrecPred.and (Primrec.eq.comp Primrec.fst (Primrec.const 2)) + (Primrec.nat_lt.comp Primrec.snd (Primrec.const 2))) + (Primrec.succ.comp Primrec.snd) (Primrec.const 0) + refine h.of_eq ?_ + rintro ⟨k, e⟩ + match k, e with + | 0, _ => simp [Encodable.decode] + | 1, _ => simp [Encodable.decode] + | 2, 0 => rfl + | 2, 1 => rfl + | 2, _ + 2 => simp [Encodable.decode] + | _ + 3, _ => simp [Encodable.decode] + +namespace Semiterm + +/-- +The argument-vector fold of the `func` branch. `T` is the table of values already computed by +the strong recursion, `l` the list of argument codes. + +The result is `0` for failure and `r + 1` for success with vector code `r`; see the module +docstring for why this is `ℕ` and not `Option ℕ`. A lookup that is absent or `0` — that is, an +argument whose own decoding failed — fails the whole fold. -/ +def stepVec (T : List ℕ) (l : List ℕ) : ℕ := + l.foldr + (fun j acc ↦ + if T.getD j 0 = 0 ∨ acc = 0 then 0 else Nat.pair (T.getD j 0 - 1) (acc - 1) + 2) + 1 + +@[simp] +lemma stepVec_nil (T : List ℕ) : stepVec T [] = 1 := + rfl + +lemma stepVec_cons (T : List ℕ) (j : ℕ) (l : List ℕ) : + stepVec T (j :: l) = + if T.getD j 0 = 0 ∨ stepVec T l = 0 then 0 + else Nat.pair (T.getD j 0 - 1) (stepVec T l - 1) + 2 := + rfl + +/-- With every lookup present and non-zero, the fold rebuilds the `vecToNat` code of the +arguments. -/ +lemma stepVec_ofFn {T : List ℕ} {a : ℕ} {w u : Fin a → ℕ} (h : ∀ i, T.getD (w i) 0 = u i + 1) : + stepVec T (List.ofFn w) = Matrix.vecToNat u + 1 := by + induction a with + | zero => simp [Matrix.vecToNat] + | succ a + ih => + rw [List.ofFn_succ, stepVec_cons, + ih (w := fun i ↦ w i.succ) (u := fun i ↦ u i.succ) fun i ↦ by simpa using h i.succ, h 0, + ite_eq_right (by simp)] + simp only [Nat.add_sub_cancel] + simpa using (Matrix.encode_succ (u 0) (fun i ↦ u i.succ)).symm + +/-- One absent-or-zero lookup anywhere kills the fold. -/ +lemma stepVec_eq_zero {T : List ℕ} {l : List ℕ} {j : ℕ} (hj : j ∈ l) (h : T.getD j 0 = 0) : + stepVec T l = 0 := by + induction l with + | nil => simp at hj + | cons b l ih => + rw [stepVec_cons] + rcases List.mem_cons.mp hj with rfl | hj' + · exact ite_eq_left (Or.inl h) + · exact ite_eq_left (Or.inr (ih hj')) + +open _root_.Primrec Primrec in +theorem primrec_stepVec : Primrec₂ stepVec := + by + have hp : + Primrec fun p : List ℕ × List ℕ ↦ + p.2.foldr + (fun j acc ↦ + if p.1.getD j 0 = 0 ∨ acc = 0 then 0 else Nat.pair (p.1.getD j 0 - 1) (acc - 1) + 2) + 1 := + by + refine + Primrec.list_foldr (β := ℕ) (σ := ℕ) (f := fun p : List ℕ × List ℕ ↦ p.2) (g := fun _ ↦ + (1 : ℕ)) (h := fun p x ↦ + if p.1.getD x.1 0 = 0 ∨ x.2 = 0 then 0 else Nat.pair (p.1.getD x.1 0 - 1) (x.2 - 1) + 2) + snd (const _) ?_ + have hget : Primrec fun y : (List ℕ × List ℕ) × ℕ × ℕ ↦ y.1.1.getD y.2.1 0 := + (Primrec.list_getD 0).comp (fst.comp fst) (fst.comp snd) + refine + Primrec.ite + (PrimrecPred.or (Primrec.eq.comp hget (const 0)) + (Primrec.eq.comp (snd.comp snd) (const 0))) + (const 0) ?_ + exact + Primrec.nat_add.comp + (Primrec₂.natPair.comp (nat_sub.comp hget (const 1)) + (nat_sub.comp (snd.comp snd) (const 1))) + (const 2) + exact hp.of_eq fun p ↦ rfl + +variable {L : Language} [L.Encodable] [L.Primcodable] {ξ : Type*} [Primcodable ξ] + +/-- The four branches of `Semiterm.ofNat` at the level of codes, with `d + 1` the code being +decoded. Branch `2` is the `func` case: it checks that the argument vector decodes to the recorded +arity, that the function symbol decodes, and that every argument's own decoding succeeded — the +last through `stepVec`, reading the table. -/ +def stepBody (n : ℕ) (T : List ℕ) (d : ℕ) : ℕ := + if d.unpair.1 = 0 then (if d.unpair.2 < n then Nat.pair 0 d.unpair.2 + 2 else 0) + else + if d.unpair.1 = 1 then + (if (encode (decode d.unpair.2 : Option ξ)) = 0 then 0 + else Nat.pair 1 ((encode (decode d.unpair.2 : Option ξ)) - 1) + 2) + else + if d.unpair.1 = 2 then + (if + (Nat.natToList d.unpair.2.unpair.2.unpair.2).length = d.unpair.2.unpair.1 ∧ + (encode + (decode d.unpair.2.unpair.2.unpair.1 : + Option (L.Func d.unpair.2.unpair.1))) ≠ + 0 ∧ + stepVec T (Nat.natToList d.unpair.2.unpair.2.unpair.2) ≠ 0 then + Nat.pair 2 + (Nat.pair d.unpair.2.unpair.1 + (Nat.pair + ((encode + (decode d.unpair.2.unpair.2.unpair.1 : + Option (L.Func d.unpair.2.unpair.1))) - + 1) + (stepVec T (Nat.natToList d.unpair.2.unpair.2.unpair.2) - 1))) + + 2 + else 0) + else 0 + +/-- +One step of the course-of-values recursion, at the level of codes: given the table `T` of the +values `encode (ofNat n j)` for every `j < T.length`, it returns `encode (ofNat n T.length)`. -/ +def step (n : ℕ) (T : List ℕ) : ℕ := + Nat.casesOn (motive := fun _ ↦ ℕ) T.length 0 (stepBody (L := L) (ξ := ξ) n T) + +open _root_.Primrec Primrec in +theorem primrec_step : Primrec₂ (step (L := L) (ξ := ξ)) := by + set A := (ℕ × List ℕ) × ℕ with hA + have hn : Primrec fun q : A ↦ q.1.1 := fst.comp fst + have hT : Primrec fun q : A ↦ q.1.2 := snd.comp fst + have hd : Primrec fun q : A ↦ q.2 := snd + have hi : Primrec fun q : A ↦ q.2.unpair.1 := fst.comp (Primrec.unpair.comp hd) + have hc : Primrec fun q : A ↦ q.2.unpair.2 := snd.comp (Primrec.unpair.comp hd) + have ha : Primrec fun q : A ↦ q.2.unpair.2.unpair.1 := fst.comp (Primrec.unpair.comp hc) + have hr : Primrec fun q : A ↦ q.2.unpair.2.unpair.2 := snd.comp (Primrec.unpair.comp hc) + have hef : Primrec fun q : A ↦ q.2.unpair.2.unpair.2.unpair.1 := + fst.comp (Primrec.unpair.comp hr) + have hev : Primrec fun q : A ↦ q.2.unpair.2.unpair.2.unpair.2 := + snd.comp (Primrec.unpair.comp hr) + have hxi : Primrec fun q : A ↦ (encode (decode q.2.unpair.2 : Option ξ)) := + Primrec.nat_iff.mpr (Primcodable.prim ξ) |>.comp hc + have hF : + Primrec fun q : A ↦ + (encode + (decode q.2.unpair.2.unpair.2.unpair.1 : Option (L.Func q.2.unpair.2.unpair.1))) := + (Language.Primcodable.func (L := L)).comp ha hef + have hl : Primrec fun q : A ↦ Nat.natToList q.2.unpair.2.unpair.2.unpair.2 := + Primrec.nat_natToList.comp hev + have hsv : Primrec fun q : A ↦ stepVec q.1.2 (Nat.natToList q.2.unpair.2.unpair.2.unpair.2) := + primrec_stepVec.comp hT hl + have b0 : + Primrec fun q : A ↦ (if q.2.unpair.2 < q.1.1 then Nat.pair 0 q.2.unpair.2 + 2 else 0) := + Primrec.ite (nat_lt.comp hc hn) + (Primrec.nat_add.comp (Primrec₂.natPair.comp (const 0) hc) (const 2)) + (const 0) + -- branch 1 + have b1 : + Primrec fun q : A ↦ + (if (encode (decode q.2.unpair.2 : Option ξ)) = 0 then 0 + else Nat.pair 1 ((encode (decode q.2.unpair.2 : Option ξ)) - 1) + 2) := + Primrec.ite (Primrec.eq.comp hxi (const 0)) (const 0) + (Primrec.nat_add.comp (Primrec₂.natPair.comp (const 1) (nat_sub.comp hxi (const 1))) + (const 2)) + -- branch 2 + have b2 : + Primrec fun q : A ↦ + (if + (Nat.natToList q.2.unpair.2.unpair.2.unpair.2).length = q.2.unpair.2.unpair.1 ∧ + (encode + (decode q.2.unpair.2.unpair.2.unpair.1 : + Option (L.Func q.2.unpair.2.unpair.1))) ≠ + 0 ∧ + stepVec q.1.2 (Nat.natToList q.2.unpair.2.unpair.2.unpair.2) ≠ 0 then + Nat.pair 2 + (Nat.pair q.2.unpair.2.unpair.1 + (Nat.pair + ((encode + (decode q.2.unpair.2.unpair.2.unpair.1 : + Option (L.Func q.2.unpair.2.unpair.1))) - + 1) + (stepVec q.1.2 (Nat.natToList q.2.unpair.2.unpair.2.unpair.2) - 1))) + + 2 + else 0) := + Primrec.ite + (PrimrecPred.and (Primrec.eq.comp (list_length.comp hl) ha) + (PrimrecPred.and (PrimrecPred.not (Primrec.eq.comp hF (const 0))) + (PrimrecPred.not (Primrec.eq.comp hsv (const 0))))) + (Primrec.nat_add.comp + (Primrec₂.natPair.comp (const 2) + (Primrec₂.natPair.comp ha + (Primrec₂.natPair.comp (nat_sub.comp hF (const 1)) (nat_sub.comp hsv (const 1))))) + (const 2)) + (const 0) + have body : Primrec fun q : A ↦ stepBody (L := L) (ξ := ξ) q.1.1 q.1.2 q.2 := + (Primrec.ite (Primrec.eq.comp hi (const 0)) b0 + (Primrec.ite (Primrec.eq.comp hi (const 1)) b1 + (Primrec.ite (Primrec.eq.comp hi (const 2)) b2 (const 0)))).of_eq + fun q ↦ rfl + exact + (Primrec.nat_casesOn (f := fun p : ℕ × List ℕ ↦ p.2.length) (g := fun _ ↦ (0 : ℕ)) (h := + fun p d ↦ stepBody (L := L) (ξ := ξ) p.1 p.2 d) (list_length.comp snd) (const 0) + body).of_eq + fun p ↦ rfl + +/-- The table construction in `FFL.FirstOrder.Semiterm`. -/ +abbrev table (n e : ℕ) : List ℕ := + (List.range e).map fun j ↦ encode (ofNat (L := L) (ξ := ξ) n j) + +omit [L.Primcodable] in +lemma table_length (n e : ℕ) : (table (L := L) (ξ := ξ) n e).length = e := by simp [table] + +omit [L.Primcodable] in +lemma table_getD {n e j : ℕ} (h : j < e) : + (table (L := L) (ξ := ξ) n e).getD j 0 = encode (ofNat (L := L) (ξ := ξ) n j) := + by + rw [List.getD_eq_getElem?_getD, List.getElem?_map, List.getElem?_range h] + rfl + +omit [L.Primcodable] in +/-- On the table of all previously computed values, the step function returns the next one — the +obligation `Primrec.nat_strong_rec` asks for. + +Four branches, matching `ofNat`'s; the two atomic ones are arithmetic. In the `func` branch, +`natToVec` succeeding is tested as `natToList` having the recorded length +(`natToVec_isSome_of_length`/`natToVec_eq_none_of_length`), the function symbol's decoding is read +off `encode ∘ decode` being non-zero, and each argument's decoding is read out of the table, so +the branch never reconstructs a term; the argument-vector code comes from `stepVec_ofFn`, and when +an argument fails to decode, its table entry is `0` and `stepVec_eq_zero` collapses the fold, +matching `Matrix.getM` returning `none` on the other side. -/ +theorem step_table (n e : ℕ) : + step (L := L) (ξ := ξ) n (table (L := L) (ξ := ξ) n e) = + encode (ofNat (L := L) (ξ := ξ) n e) := + by + rw [step, table_length] + cases e with + | zero => simp [ofNat] + | succ + d => + change stepBody (L := L) (ξ := ξ) n (table (L := L) (ξ := ξ) n (d + 1)) d = _ + rw [stepBody, ofNat] + by_cases h0 : (Nat.unpair d).1 = 0 + · rw [ite_eq_left h0, h0] + by_cases hz : (Nat.unpair d).2 < n + · rw [ite_eq_left hz, dite_eq_left hz] + simp [encode_eq_toNat, toNat] + · rw [ite_eq_right hz, dite_eq_right hz] + simp + by_cases h1 : (Nat.unpair d).1 = 1 + · rw [ite_eq_right h0, ite_eq_left h1, h1] + rcases hx : (decode (Nat.unpair d).2 : Option ξ) with _ | x + · simp + · rw [ite_eq_right (by simp)] + simp [encode_eq_toNat, toNat] + by_cases h2 : (Nat.unpair d).1 = 2 + · rw [ite_eq_right h0, ite_eq_right h1, ite_eq_left h2, h2] + simp only [] + rcases hv : + (Nat.natToVec (Nat.unpair (Nat.unpair (Nat.unpair d).2).2).2) + (Nat.unpair (Nat.unpair d).2).1 with + _ | v' + · rw [ite_eq_right ?_] + · simp + · rintro ⟨hlen, -, -⟩ + obtain ⟨w, hw⟩ := Nat.natToVec_isSome_of_length hlen + rw [hw] at hv + exact absurd hv (by simp) + · have hl : + (PointwiseComposition.Nat.natToList (Nat.unpair (Nat.unpair (Nat.unpair d).2).2).2) = + List.ofFn v' := + Nat.natToVec_eq_some_iff.mp hv + have hlen : + (PointwiseComposition.Nat.natToList + (Nat.unpair (Nat.unpair (Nat.unpair d).2).2).2).length = + (Nat.unpair (Nat.unpair d).2).1 := + by rw [hl]; simp + have hlt : ∀ i, v' i < d + 1 := fun i ↦ + Nat.lt_succ_iff.mpr <| + le_trans (le_of_lt <| Nat.lt_of_eq_natToVec hv i) <| + le_trans (Nat.unpair_right_le _) <| + le_trans (Nat.unpair_right_le _) <| Nat.unpair_right_le _ + rcases hf : + (decode (Nat.unpair (Nat.unpair (Nat.unpair d).2).2).1 : + Option (L.Func (Nat.unpair (Nat.unpair d).2).1)) with + _ | f + · rw [ite_eq_right ?_] + · simp + · rintro ⟨-, hne, -⟩ + exact hne (by simp) + · rcases hg : (Matrix.getM fun i ↦ ofNat (L := L) (ξ := ξ) n (v' i)) with _ | t + · obtain ⟨i₀, hi₀⟩ : ∃ i, ofNat (L := L) (ξ := ξ) n (v' i) = none := + by + by_contra hcon + push Not at hcon + choose t ht using fun i ↦ Option.ne_none_iff_exists'.mp (hcon i) + rw [Matrix.getM_option_eq_some_iff.mpr ht] at hg + exact absurd hg (by simp) + rw [ite_eq_right ?_] + · simp [hg] + · rintro ⟨-, -, hne⟩ + refine hne (stepVec_eq_zero (j := v' i₀) ?_ ?_) + · rw [hl]; exact List.mem_ofFn.mpr ⟨i₀, rfl⟩ + · rw [table_getD (hlt i₀), hi₀]; simp + · have hT : + ∀ i, (table (L := L) (ξ := ξ) n (d + 1)).getD (v' i) 0 = encode (t i) + 1 := + fun i ↦ by + rw [table_getD (hlt i), Matrix.getM_option_eq_some_iff.mp hg i] + simp + have hsv : + stepVec (table (L := L) (ξ := ξ) n (d + 1)) + (Nat.natToList (Nat.unpair (Nat.unpair (Nat.unpair d).2).2).2) = + Matrix.vecToNat (fun i ↦ encode (t i)) + 1 := + by rw [hl]; exact stepVec_ofFn hT + rw [ite_eq_left ⟨hlen, by simp, by rw [hsv]; simp⟩, hsv] + simp [hg, encode_eq_toNat, toNat] + · rw [ite_eq_right h0, ite_eq_right h1, ite_eq_right h2] + match hi : (Nat.unpair d).1 with + | 0 => exact absurd hi h0 + | 1 => exact absurd hi h1 + | 2 => exact absurd hi h2 + | k + 3 => simp + +/-- `fun n e ↦ encode (Semiterm.ofNat n e)` is primitive recursive: the term half of +issue #506. -/ +theorem encode_ofNat_primrec : Primrec₂ fun n e : ℕ ↦ encode (ofNat (L := L) (ξ := ξ) n e) := + Primrec.nat_strong_rec _ (g := fun n T ↦ some (step (L := L) (ξ := ξ) n T)) + (Primrec.option_some.comp primrec_step) fun n e ↦ congrArg some (step_table n e) + +/-- The instance sits on the `Encodable` instance already in `Basic/Coding.lean`, so nothing +downstream sees a new `encode`; the examples below check that, and that `decode` is still +`ofNat`. -/ +instance primcodable {n : ℕ} : Primcodable (Semiterm L ξ n) + where + toEncodable := Semiterm.encodable + prim := + Primrec.nat_iff.mp <| + (encode_ofNat_primrec (L := L) (ξ := ξ)).comp (Primrec.const n) Primrec.id + +end Semiterm + +namespace Semiformula + +open FFL.FirstOrder.Semiterm + +variable {L : Language} [L.Encodable] [L.Primcodable] {ξ : Type*} [Primcodable ξ] + +/-- The `rel`/`nrel` argument fold, the term-decoding sibling of `Semiterm.stepVec`. Where the +term version reads each argument out of the strong-recursion table, this decodes each argument +code as a term of `Semiterm L ξ n` — the arguments of a relation are terms, not sub-formulas, so +they are in no table. `0` is failure and `r + 1` success, as there. -/ +def stepVecT (n : ℕ) (l : List ℕ) : ℕ := + l.foldr + (fun j acc ↦ + if encode (decode j : Option (Semiterm L ξ n)) = 0 ∨ acc = 0 then 0 + else Nat.pair (encode (decode j : Option (Semiterm L ξ n)) - 1) (acc - 1) + 2) + 1 + +omit [L.Primcodable] in +@[simp] +lemma stepVecT_nil (n : ℕ) : stepVecT (L := L) (ξ := ξ) n [] = 1 := + rfl + +omit [L.Primcodable] in +lemma stepVecT_cons (n : ℕ) (j : ℕ) (l : List ℕ) : + stepVecT (L := L) (ξ := ξ) n (j :: l) = + if + encode (decode j : Option (Semiterm L ξ n)) = 0 ∨ + stepVecT (L := L) (ξ := ξ) n l = 0 then + 0 + else + Nat.pair (encode (decode j : Option (Semiterm L ξ n)) - 1) + (stepVecT (L := L) (ξ := ξ) n l - 1) + + 2 := + rfl + +omit [L.Primcodable] in +lemma stepVecT_ofFn {n a : ℕ} {w u : Fin a → ℕ} + (h : ∀ i, encode (decode (w i) : Option (Semiterm L ξ n)) = u i + 1) : + stepVecT (L := L) (ξ := ξ) n (List.ofFn w) = Matrix.vecToNat u + 1 := by + induction a with + | zero => simp [Matrix.vecToNat] + | succ a + ih => + rw [List.ofFn_succ, stepVecT_cons, + ih (w := fun i ↦ w i.succ) (u := fun i ↦ u i.succ) fun i ↦ by simpa using h i.succ, h 0, + ite_eq_right (by simp)] + simp only [Nat.add_sub_cancel] + simpa using (Matrix.encode_succ (u 0) (fun i ↦ u i.succ)).symm + +omit [L.Primcodable] in +lemma stepVecT_eq_zero {n : ℕ} {l : List ℕ} {j : ℕ} (hj : j ∈ l) + (h : encode (decode j : Option (Semiterm L ξ n)) = 0) : + stepVecT (L := L) (ξ := ξ) n l = 0 := by + induction l with + | nil => simp at hj + | cons b l ih => + rw [stepVecT_cons] + rcases List.mem_cons.mp hj with rfl | hj' + · exact ite_eq_left (Or.inl h) + · exact ite_eq_left (Or.inr (ih hj')) + +open _root_.Primrec Primrec in +theorem primrec_stepVecT : Primrec₂ (stepVecT (L := L) (ξ := ξ)) := + by + have hp : + Primrec fun p : ℕ × List ℕ ↦ + p.2.foldr + (fun j acc ↦ + if encode (decode j : Option (Semiterm L ξ p.1)) = 0 ∨ acc = 0 then 0 + else Nat.pair (encode (decode j : Option (Semiterm L ξ p.1)) - 1) (acc - 1) + 2) + 1 := + by + refine + Primrec.list_foldr (β := ℕ) (σ := ℕ) (f := fun p : ℕ × List ℕ ↦ p.2) (g := fun _ ↦ + (1 : ℕ)) (h := fun p x ↦ + if encode (decode x.1 : Option (Semiterm L ξ p.1)) = 0 ∨ x.2 = 0 then 0 + else Nat.pair (encode (decode x.1 : Option (Semiterm L ξ p.1)) - 1) (x.2 - 1) + 2) + snd (const _) ?_ + have hdec : + Primrec fun y : (ℕ × List ℕ) × ℕ × ℕ ↦ + encode (decode y.2.1 : Option (Semiterm L ξ y.1.1)) := + (Semiterm.encode_ofNat_primrec (L := L) (ξ := ξ)).comp (fst.comp fst) + (fst.comp snd) |>.of_eq + fun _ ↦ rfl + refine + Primrec.ite + (PrimrecPred.or (Primrec.eq.comp hdec (const 0)) + (Primrec.eq.comp (snd.comp snd) (const 0))) + (const 0) ?_ + exact + Primrec.nat_add.comp + (Primrec₂.natPair.comp (nat_sub.comp hdec (const 1)) + (nat_sub.comp (snd.comp snd) (const 1))) + (const 2) + exact hp.of_eq fun p ↦ rfl + +/-! +### The formula step function + +`Semiformula.ofNat` cannot use `Primrec.nat_strong_rec`: the `∀`/`∃` branches recurse at +`ofNat (n + 1)`, so the arity changes as the recursion descends, while `nat_strong_rec` holds its +parameter fixed and tabulates one arity only. The recursion is therefore run by +`Primrec.nat_omega_rec'` over pairs `(n, e)`, with `e` as the measure and `subArgs` naming the +immediate sub-formulas — two at the same arity for `⋏`/`⋎`, one at the successor arity for +`∀`/`∃`, and none elsewhere. The measure obligation `subArgs_ord` is `ofNat`'s own internal +`< e + 1` bounds read back. + +`step` is written with an `if` rather than a `Nat.casesOn`: a `casesOn` adds a level to the tower +of products the ambient argument lives in (`((ℕ × ℕ) × List ℕ) × ℕ` instead of +`(ℕ × ℕ) × List ℕ`), and elaboration of the `Primrec` combinators diverges on it, exactly as it +did on an `Option`-valued fold in the term half. -/ + +/-- The step Body construction in `FFL.FirstOrder.Semiformula`. -/ +def stepBody (n d : ℕ) (vs : List ℕ) : ℕ := + if d.unpair.1 = 0 then + (if + (Nat.natToList d.unpair.2.unpair.2.unpair.2).length = d.unpair.2.unpair.1 ∧ + (encode (decode d.unpair.2.unpair.2.unpair.1 : Option (L.Rel d.unpair.2.unpair.1))) ≠ + 0 ∧ + stepVecT (L := L) (ξ := ξ) n (Nat.natToList d.unpair.2.unpair.2.unpair.2) ≠ 0 then + Nat.pair 0 + (Nat.pair d.unpair.2.unpair.1 + (Nat.pair + ((encode + (decode d.unpair.2.unpair.2.unpair.1 : Option (L.Rel d.unpair.2.unpair.1))) - + 1) + (stepVecT (L := L) (ξ := ξ) n (Nat.natToList d.unpair.2.unpair.2.unpair.2) - + 1))) + + 2 + else 0) + else + if d.unpair.1 = 1 then + (if + (Nat.natToList d.unpair.2.unpair.2.unpair.2).length = d.unpair.2.unpair.1 ∧ + (encode + (decode d.unpair.2.unpair.2.unpair.1 : Option (L.Rel d.unpair.2.unpair.1))) ≠ + 0 ∧ + stepVecT (L := L) (ξ := ξ) n (Nat.natToList d.unpair.2.unpair.2.unpair.2) ≠ 0 then + Nat.pair 1 + (Nat.pair d.unpair.2.unpair.1 + (Nat.pair + ((encode + (decode d.unpair.2.unpair.2.unpair.1 : + Option (L.Rel d.unpair.2.unpair.1))) - + 1) + (stepVecT (L := L) (ξ := ξ) n (Nat.natToList d.unpair.2.unpair.2.unpair.2) - + 1))) + + 2 + else 0) + else + if d.unpair.1 = 2 then Nat.pair 2 0 + 2 + else + if d.unpair.1 = 3 then Nat.pair 3 0 + 2 + else + if d.unpair.1 = 4 then + (if vs.getD 0 0 = 0 ∨ vs.getD 1 0 = 0 then 0 + else Nat.pair 4 (Nat.pair (vs.getD 0 0 - 1) (vs.getD 1 0 - 1)) + 2) + else + if d.unpair.1 = 5 then + (if vs.getD 0 0 = 0 ∨ vs.getD 1 0 = 0 then 0 + else Nat.pair 5 (Nat.pair (vs.getD 0 0 - 1) (vs.getD 1 0 - 1)) + 2) + else + if d.unpair.1 = 6 then + (if vs.getD 0 0 = 0 then 0 else Nat.pair 6 (vs.getD 0 0 - 1) + 2) + else + if d.unpair.1 = 7 then + (if vs.getD 0 0 = 0 then 0 else Nat.pair 7 (vs.getD 0 0 - 1) + 2) + else 0 + +/-- The step construction in `FFL.FirstOrder.Semiformula`. -/ +def step (n e : ℕ) (vs : List ℕ) : ℕ := + if e = 0 then 0 else stepBody (L := L) (ξ := ξ) n (e - 1) vs + +/-- The sub Args construction in `FFL.FirstOrder.Semiformula`. -/ +def subArgs (b : ℕ × ℕ) : List (ℕ × ℕ) := + Nat.casesOn (motive := fun _ ↦ List (ℕ × ℕ)) b.2 [] fun d ↦ + if d.unpair.1 = 4 ∨ d.unpair.1 = 5 then + [(b.1, d.unpair.2.unpair.1), (b.1, d.unpair.2.unpair.2)] + else if d.unpair.1 = 6 ∨ d.unpair.1 = 7 then [(b.1 + 1, d.unpair.2)] else [] + +omit [L.Primcodable] in +lemma subArgs_succ (n d : ℕ) : + subArgs (n, d + 1) = + (if d.unpair.1 = 4 ∨ d.unpair.1 = 5 then + [(n, d.unpair.2.unpair.1), (n, d.unpair.2.unpair.2)] + else if d.unpair.1 = 6 ∨ d.unpair.1 = 7 then [(n + 1, d.unpair.2)] else []) := + rfl + +omit [L.Primcodable] in +private lemma vs_bin (n d : ℕ) (h : d.unpair.1 = 4 ∨ d.unpair.1 = 5) : + (subArgs (n, d + 1)).map (fun b ↦ encode (ofNat (L := L) (ξ := ξ) b.1 b.2)) = + [encode (ofNat (L := L) (ξ := ξ) n d.unpair.2.unpair.1), + encode (ofNat (L := L) (ξ := ξ) n d.unpair.2.unpair.2)] := + by rw [subArgs_succ, ite_eq_left h]; simp + +omit [L.Primcodable] in +private lemma vs_quant (n d : ℕ) (h45 : ¬(d.unpair.1 = 4 ∨ d.unpair.1 = 5)) + (h : d.unpair.1 = 6 ∨ d.unpair.1 = 7) : + (subArgs (n, d + 1)).map (fun b ↦ encode (ofNat (L := L) (ξ := ξ) b.1 b.2)) = + [encode (ofNat (L := L) (ξ := ξ) (n + 1) d.unpair.2)] := + by rw [subArgs_succ, ite_eq_right h45, ite_eq_left h]; simp + +lemma subArgs_ord (b : ℕ × ℕ) : ∀ b' ∈ subArgs b, b'.2 < b.2 := + by + rcases b with ⟨n, e⟩ + cases e with + | zero => simp [subArgs] + | succ d => + rw [subArgs_succ] + by_cases h4 : d.unpair.1 = 4 ∨ d.unpair.1 = 5 + · rw [ite_eq_left h4] + intro b' hb' + simp only [List.mem_cons, List.not_mem_nil, or_false] at hb' + have h1 : d.unpair.2.unpair.1 ≤ d := + le_trans (Nat.unpair_left_le _) (Nat.unpair_right_le _) + have h2 : d.unpair.2.unpair.2 ≤ d := + le_trans (Nat.unpair_right_le _) (Nat.unpair_right_le _) + rcases hb' with rfl | rfl <;> simp <;> omega + · rw [ite_eq_right h4] + by_cases h6 : d.unpair.1 = 6 ∨ d.unpair.1 = 7 + · rw [ite_eq_left h6] + intro b' hb' + simp only [List.mem_cons, List.not_mem_nil, or_false] at hb' + have : d.unpair.2 ≤ d := Nat.unpair_right_le _ + rcases hb' with rfl; simp; omega + · rw [ite_eq_right h6]; simp + +omit [L.Primcodable] in +theorem step_correct (n e : ℕ) : + step (L := L) (ξ := ξ) n e + ((subArgs (n, e)).map (fun b ↦ encode (ofNat (L := L) (ξ := ξ) b.1 b.2))) = + encode (ofNat (L := L) (ξ := ξ) n e) := + by + cases e with + | zero => simp [step, ofNat] + | succ + d => + rw [step, ite_eq_right (Nat.succ_ne_zero d), Nat.add_sub_cancel, stepBody, ofNat] + by_cases h4 : d.unpair.1 = 4 + · rw [vs_bin n d (Or.inl h4), ite_eq_right (by omega), ite_eq_right (by omega), + ite_eq_right (by omega), ite_eq_right (by omega), ite_eq_left h4, h4] + simp only [List.getD_cons_zero, List.getD_cons_succ] + rcases hφ : ofNat (L := L) (ξ := ξ) n d.unpair.2.unpair.1 with _ | φ + · simp + · rcases hψ : ofNat (L := L) (ξ := ξ) n d.unpair.2.unpair.2 with _ | ψ + · simp + · rw [ite_eq_right (by simp)] + simp [encode_eq_toNat, toNat] + by_cases h5 : d.unpair.1 = 5 + · rw [vs_bin n d (Or.inr h5), ite_eq_right (by omega), ite_eq_right (by omega), + ite_eq_right (by omega), ite_eq_right (by omega), ite_eq_right (by omega), + ite_eq_left h5, h5] + simp only [List.getD_cons_zero, List.getD_cons_succ] + rcases hφ : ofNat (L := L) (ξ := ξ) n d.unpair.2.unpair.1 with _ | φ + · simp + · rcases hψ : ofNat (L := L) (ξ := ξ) n d.unpair.2.unpair.2 with _ | ψ + · simp + · rw [ite_eq_right (by simp)] + simp [encode_eq_toNat, toNat] + by_cases h6 : d.unpair.1 = 6 + · rw [vs_quant n d (by simp [h6]) (Or.inl h6), ite_eq_right (by omega), + ite_eq_right (by omega), ite_eq_right (by omega), ite_eq_right (by omega), + ite_eq_right (by omega), ite_eq_right (by omega), ite_eq_left h6, h6] + simp only [List.getD_cons_zero] + rcases hφ : ofNat (L := L) (ξ := ξ) (n + 1) d.unpair.2 with _ | φ + · simp + · rw [ite_eq_right (by simp)] + simp [encode_eq_toNat, toNat] + by_cases h7 : d.unpair.1 = 7 + · rw [vs_quant n d (by simp [h7]) (Or.inr h7), ite_eq_right (by omega), + ite_eq_right (by omega), ite_eq_right (by omega), ite_eq_right (by omega), + ite_eq_right (by omega), ite_eq_right (by omega), ite_eq_right (by omega), + ite_eq_left h7, h7] + simp only [List.getD_cons_zero] + rcases hφ : ofNat (L := L) (ξ := ξ) (n + 1) d.unpair.2 with _ | φ + · simp + · rw [ite_eq_right (by simp)] + simp [encode_eq_toNat, toNat] + by_cases h2 : d.unpair.1 = 2 + · rw [ite_eq_right (by omega), ite_eq_right (by omega), ite_eq_left h2, h2] + simp [encode_eq_toNat, toNat] + by_cases h3 : d.unpair.1 = 3 + · rw [ite_eq_right (by omega), ite_eq_right (by omega), ite_eq_right (by omega), + ite_eq_left h3, h3] + simp [encode_eq_toNat, toNat] + by_cases h0 : d.unpair.1 = 0 + · rw [ite_eq_left h0, h0] + simp only [] + rcases hv : + (Nat.natToVec (Nat.unpair (Nat.unpair (Nat.unpair d).2).2).2) + (Nat.unpair (Nat.unpair d).2).1 with + _ | v' + · rw [ite_eq_right ?_] + · simp + · rintro ⟨hlen, -, -⟩ + obtain ⟨w, hw⟩ := Nat.natToVec_isSome_of_length hlen + rw [hw] at hv; exact absurd hv (by simp) + · have hl : + (PointwiseComposition.Nat.natToList (Nat.unpair (Nat.unpair (Nat.unpair d).2).2).2) = + List.ofFn v' := + Nat.natToVec_eq_some_iff.mp hv + have hlen : + (PointwiseComposition.Nat.natToList + (Nat.unpair (Nat.unpair (Nat.unpair d).2).2).2).length = + (Nat.unpair (Nat.unpair d).2).1 := + by rw [hl]; simp + rcases hR : + (decode (Nat.unpair (Nat.unpair (Nat.unpair d).2).2).1 : + Option (L.Rel (Nat.unpair (Nat.unpair d).2).1)) with + _ | R + · rw [ite_eq_right ?_] + · simp + · rintro ⟨-, hne, -⟩; exact hne (by simp) + · rcases hg : (Matrix.getM fun i ↦ (decode (v' i) : Option (Semiterm L ξ n))) with _ | t + · obtain ⟨i₀, hi₀⟩ : ∃ i, (decode (v' i) : Option (Semiterm L ξ n)) = none := + by + by_contra hcon + push Not at hcon + choose t ht using fun i ↦ Option.ne_none_iff_exists'.mp (hcon i) + rw [Matrix.getM_option_eq_some_iff.mpr ht] at hg; exact absurd hg (by simp) + rw [ite_eq_right ?_] + · simp [hg] + · rintro ⟨-, -, hne⟩ + refine hne (stepVecT_eq_zero (j := v' i₀) ?_ ?_) + · rw [hl]; exact List.mem_ofFn.mpr ⟨i₀, rfl⟩ + · rw [hi₀]; simp + · have hT : + ∀ i, encode (decode (v' i) : Option (Semiterm L ξ n)) = encode (t i) + 1 := + fun i ↦ by rw [Matrix.getM_option_eq_some_iff.mp hg i]; simp + have hsv : + stepVecT (L := L) (ξ := ξ) n + (Nat.natToList (Nat.unpair (Nat.unpair (Nat.unpair d).2).2).2) = + Matrix.vecToNat (fun i ↦ encode (t i)) + 1 := + by rw [hl]; exact stepVecT_ofFn hT + rw [ite_eq_left ⟨hlen, by simp, by rw [hsv]; simp⟩, hsv] + simp [hg, encode_eq_toNat, toNat] + by_cases h1 : d.unpair.1 = 1 + · rw [ite_eq_right h0, ite_eq_left h1, h1] + simp only [] + rcases hv : + (Nat.natToVec (Nat.unpair (Nat.unpair (Nat.unpair d).2).2).2) + (Nat.unpair (Nat.unpair d).2).1 with + _ | v' + · rw [ite_eq_right ?_] + · simp + · rintro ⟨hlen, -, -⟩ + obtain ⟨w, hw⟩ := Nat.natToVec_isSome_of_length hlen + rw [hw] at hv; exact absurd hv (by simp) + · have hl : + (PointwiseComposition.Nat.natToList (Nat.unpair (Nat.unpair (Nat.unpair d).2).2).2) = + List.ofFn v' := + Nat.natToVec_eq_some_iff.mp hv + have hlen : + (PointwiseComposition.Nat.natToList + (Nat.unpair (Nat.unpair (Nat.unpair d).2).2).2).length = + (Nat.unpair (Nat.unpair d).2).1 := + by rw [hl]; simp + rcases hR : + (decode (Nat.unpair (Nat.unpair (Nat.unpair d).2).2).1 : + Option (L.Rel (Nat.unpair (Nat.unpair d).2).1)) with + _ | R + · rw [ite_eq_right ?_] + · simp + · rintro ⟨-, hne, -⟩; exact hne (by simp) + · rcases hg : (Matrix.getM fun i ↦ (decode (v' i) : Option (Semiterm L ξ n))) with _ | t + · obtain ⟨i₀, hi₀⟩ : ∃ i, (decode (v' i) : Option (Semiterm L ξ n)) = none := + by + by_contra hcon + push Not at hcon + choose t ht using fun i ↦ Option.ne_none_iff_exists'.mp (hcon i) + rw [Matrix.getM_option_eq_some_iff.mpr ht] at hg; exact absurd hg (by simp) + rw [ite_eq_right ?_] + · simp [hg] + · rintro ⟨-, -, hne⟩ + refine hne (stepVecT_eq_zero (j := v' i₀) ?_ ?_) + · rw [hl]; exact List.mem_ofFn.mpr ⟨i₀, rfl⟩ + · rw [hi₀]; simp + · have hT : + ∀ i, encode (decode (v' i) : Option (Semiterm L ξ n)) = encode (t i) + 1 := + fun i ↦ by rw [Matrix.getM_option_eq_some_iff.mp hg i]; simp + have hsv : + stepVecT (L := L) (ξ := ξ) n + (Nat.natToList (Nat.unpair (Nat.unpair (Nat.unpair d).2).2).2) = + Matrix.vecToNat (fun i ↦ encode (t i)) + 1 := + by rw [hl]; exact stepVecT_ofFn hT + rw [ite_eq_left ⟨hlen, by simp, by rw [hsv]; simp⟩, hsv] + simp [hg, encode_eq_toNat, toNat] + · rw [ite_eq_right h0, ite_eq_right h1, ite_eq_right h2, ite_eq_right h3, ite_eq_right h4, + ite_eq_right h5, ite_eq_right h6, ite_eq_right h7] + match hi : d.unpair.1 with + | 0 => exact absurd hi h0 + | 1 => exact absurd hi h1 + | 2 => exact absurd hi h2 + | 3 => exact absurd hi h3 + | 4 => exact absurd hi h4 + | 5 => exact absurd hi h5 + | 6 => exact absurd hi h6 + | 7 => exact absurd hi h7 + | k + 8 => simp + +open _root_.Primrec Primrec in +theorem primrec_subArgs : Primrec subArgs := + by + have hbody : + Primrec fun r : (ℕ × ℕ) × ℕ ↦ + (if r.2.unpair.1 = 4 ∨ r.2.unpair.1 = 5 then + [(r.1.1, r.2.unpair.2.unpair.1), (r.1.1, r.2.unpair.2.unpair.2)] + else + if r.2.unpair.1 = 6 ∨ r.2.unpair.1 = 7 then [(r.1.1 + 1, r.2.unpair.2)] + else ([] : List (ℕ × ℕ))) := + by + have hn : Primrec fun r : (ℕ × ℕ) × ℕ ↦ r.1.1 := fst.comp fst + have hi : Primrec fun r : (ℕ × ℕ) × ℕ ↦ r.2.unpair.1 := fst.comp (Primrec.unpair.comp snd) + have hc : Primrec fun r : (ℕ × ℕ) × ℕ ↦ r.2.unpair.2 := snd.comp (Primrec.unpair.comp snd) + have hc1 : Primrec fun r : (ℕ × ℕ) × ℕ ↦ r.2.unpair.2.unpair.1 := + fst.comp (Primrec.unpair.comp hc) + have hc2 : Primrec fun r : (ℕ × ℕ) × ℕ ↦ r.2.unpair.2.unpair.2 := + snd.comp (Primrec.unpair.comp hc) + refine + Primrec.ite (PrimrecPred.or (Primrec.eq.comp hi (const 4)) (Primrec.eq.comp hi (const 5))) + (list_cons.comp (Primrec₂.pair.comp hn hc1) + (list_cons.comp (Primrec₂.pair.comp hn hc2) (Primrec.const ([] : List (ℕ × ℕ))))) + ?_ + exact + Primrec.ite (PrimrecPred.or (Primrec.eq.comp hi (const 6)) (Primrec.eq.comp hi (const 7))) + (list_cons.comp (Primrec₂.pair.comp (succ.comp hn) hc) + (Primrec.const ([] : List (ℕ × ℕ)))) + (Primrec.const ([] : List (ℕ × ℕ))) + exact + (Primrec.nat_casesOn (f := fun b : ℕ × ℕ ↦ b.2) (g := fun _ ↦ ([] : List (ℕ × ℕ))) (h := + fun b d ↦ + if d.unpair.1 = 4 ∨ d.unpair.1 = 5 then + [(b.1, d.unpair.2.unpair.1), (b.1, d.unpair.2.unpair.2)] + else if d.unpair.1 = 6 ∨ d.unpair.1 = 7 then [(b.1 + 1, d.unpair.2)] else []) + snd (Primrec.const _) hbody).of_eq + fun b ↦ rfl + +open _root_.Primrec Primrec in +theorem primrec_step : + Primrec fun q : (ℕ × ℕ) × List ℕ ↦ step (L := L) (ξ := ξ) q.1.1 q.1.2 q.2 := + by + unfold step + have hn : Primrec fun q : (ℕ × ℕ) × List ℕ ↦ q.1.1 := fst.comp fst + have he : Primrec fun q : (ℕ × ℕ) × List ℕ ↦ q.1.2 := snd.comp fst + have hvs : Primrec fun q : (ℕ × ℕ) × List ℕ ↦ q.2 := snd + have hd : Primrec fun q : (ℕ × ℕ) × List ℕ ↦ q.1.2 - 1 := nat_sub.comp he (const 1) + have hi : Primrec fun q : (ℕ × ℕ) × List ℕ ↦ (q.1.2 - 1).unpair.1 := + fst.comp (Primrec.unpair.comp hd) + have hc : Primrec fun q : (ℕ × ℕ) × List ℕ ↦ (q.1.2 - 1).unpair.2 := + snd.comp (Primrec.unpair.comp hd) + have ha : Primrec fun q : (ℕ × ℕ) × List ℕ ↦ (q.1.2 - 1).unpair.2.unpair.1 := + fst.comp (Primrec.unpair.comp hc) + have hrest : Primrec fun q : (ℕ × ℕ) × List ℕ ↦ (q.1.2 - 1).unpair.2.unpair.2 := + snd.comp (Primrec.unpair.comp hc) + have heR : Primrec fun q : (ℕ × ℕ) × List ℕ ↦ (q.1.2 - 1).unpair.2.unpair.2.unpair.1 := + fst.comp (Primrec.unpair.comp hrest) + have hev : Primrec fun q : (ℕ × ℕ) × List ℕ ↦ (q.1.2 - 1).unpair.2.unpair.2.unpair.2 := + snd.comp (Primrec.unpair.comp hrest) + have hR : + Primrec fun q : (ℕ × ℕ) × List ℕ ↦ + (encode + (decode (q.1.2 - 1).unpair.2.unpair.2.unpair.1 : + Option (L.Rel (q.1.2 - 1).unpair.2.unpair.1))) := + (Language.Primcodable.rel (L := L)).comp ha heR + have hl : + Primrec fun q : (ℕ × ℕ) × List ℕ ↦ Nat.natToList (q.1.2 - 1).unpair.2.unpair.2.unpair.2 := + Primrec.nat_natToList.comp hev + have hsv : + Primrec fun q : (ℕ × ℕ) × List ℕ ↦ + stepVecT (L := L) (ξ := ξ) q.1.1 (Nat.natToList (q.1.2 - 1).unpair.2.unpair.2.unpair.2) := + primrec_stepVecT.comp hn hl + have hv0 : Primrec fun q : (ℕ × ℕ) × List ℕ ↦ q.2.getD 0 0 := + (Primrec.list_getD 0).comp hvs (const 0) + have hv1 : Primrec fun q : (ℕ × ℕ) × List ℕ ↦ q.2.getD 1 0 := + (Primrec.list_getD 0).comp hvs (const 1) + have hrelArm : + ∀ tag : ℕ, + Primrec fun q : (ℕ × ℕ) × List ℕ ↦ + (if + (Nat.natToList (q.1.2 - 1).unpair.2.unpair.2.unpair.2).length = + (q.1.2 - 1).unpair.2.unpair.1 ∧ + (encode + (decode (q.1.2 - 1).unpair.2.unpair.2.unpair.1 : + Option (L.Rel (q.1.2 - 1).unpair.2.unpair.1))) ≠ + 0 ∧ + stepVecT (L := L) (ξ := ξ) q.1.1 + (Nat.natToList (q.1.2 - 1).unpair.2.unpair.2.unpair.2) ≠ + 0 then + Nat.pair tag + (Nat.pair (q.1.2 - 1).unpair.2.unpair.1 + (Nat.pair + ((encode + (decode (q.1.2 - 1).unpair.2.unpair.2.unpair.1 : + Option (L.Rel (q.1.2 - 1).unpair.2.unpair.1))) - + 1) + (stepVecT (L := L) (ξ := ξ) q.1.1 + (Nat.natToList (q.1.2 - 1).unpair.2.unpair.2.unpair.2) - + 1))) + + 2 + else 0) := + fun tag ↦ + Primrec.ite + (PrimrecPred.and (Primrec.eq.comp (list_length.comp hl) ha) + (PrimrecPred.and (PrimrecPred.not (Primrec.eq.comp hR (const 0))) + (PrimrecPred.not (Primrec.eq.comp hsv (const 0))))) + (Primrec.nat_add.comp + (Primrec₂.natPair.comp (const tag) + (Primrec₂.natPair.comp ha + (Primrec₂.natPair.comp (nat_sub.comp hR (const 1)) (nat_sub.comp hsv (const 1))))) + (const 2)) + (const 0) + have hbinArm : + ∀ tag : ℕ, + Primrec fun q : (ℕ × ℕ) × List ℕ ↦ + (if q.2.getD 0 0 = 0 ∨ q.2.getD 1 0 = 0 then 0 + else Nat.pair tag (Nat.pair (q.2.getD 0 0 - 1) (q.2.getD 1 0 - 1)) + 2) := + fun tag ↦ + Primrec.ite (PrimrecPred.or (Primrec.eq.comp hv0 (const 0)) (Primrec.eq.comp hv1 (const 0))) + (const 0) + (Primrec.nat_add.comp + (Primrec₂.natPair.comp (const tag) + (Primrec₂.natPair.comp (nat_sub.comp hv0 (const 1)) (nat_sub.comp hv1 (const 1)))) + (const 2)) + have hqArm : + ∀ tag : ℕ, + Primrec fun q : (ℕ × ℕ) × List ℕ ↦ + (if q.2.getD 0 0 = 0 then 0 else Nat.pair tag (q.2.getD 0 0 - 1) + 2) := + fun tag ↦ + Primrec.ite (Primrec.eq.comp hv0 (const 0)) (const 0) + (Primrec.nat_add.comp (Primrec₂.natPair.comp (const tag) (nat_sub.comp hv0 (const 1))) + (const 2)) + refine Primrec.ite (Primrec.eq.comp he (const 0)) (const 0) ?_ + unfold stepBody + exact + Primrec.ite (Primrec.eq.comp hi (const 0)) (hrelArm 0) + (Primrec.ite (Primrec.eq.comp hi (const 1)) (hrelArm 1) + (Primrec.ite (Primrec.eq.comp hi (const 2)) (const (Nat.pair 2 0 + 2)) + (Primrec.ite (Primrec.eq.comp hi (const 3)) (const (Nat.pair 3 0 + 2)) + (Primrec.ite (Primrec.eq.comp hi (const 4)) (hbinArm 4) + (Primrec.ite (Primrec.eq.comp hi (const 5)) (hbinArm 5) + (Primrec.ite (Primrec.eq.comp hi (const 6)) (hqArm 6) + (Primrec.ite (Primrec.eq.comp hi (const 7)) (hqArm 7) (const 0)))))))) + +/-- `fun n e ↦ encode (Semiformula.ofNat n e)` is primitive recursive. With +`Semiterm.encode_ofNat_primrec` this closes issue #506: `Primcodable` instances for both +`Semiterm L ξ n` and `Semiformula L ξ n`, for every language satisfying the uniform-in-arity +condition `Language.Primcodable`. -/ +theorem encode_ofNat_primrec : Primrec₂ fun n e : ℕ ↦ encode (ofNat (L := L) (ξ := ξ) n e) := + Primrec.nat_omega_rec' (fun b : ℕ × ℕ ↦ encode (ofNat (L := L) (ξ := ξ) b.1 b.2)) (m := + fun b ↦ b.2) (l := subArgs) (g := fun b vs ↦ some (step (L := L) (ξ := ξ) b.1 b.2 vs)) + Primrec.snd primrec_subArgs (Primrec.option_some.comp primrec_step) subArgs_ord + (fun b ↦ congrArg some (step_correct b.1 b.2)) + +/-- As with the term instance, this sits on `Semiformula.encodable` rather than introducing a +second `Encodable`; the examples below check that, and that `encode` and `decode` are still +`toNat` and `ofNat` definitionally. -/ +instance primcodable {n : ℕ} : Primcodable (Semiformula L ξ n) + where + toEncodable := Semiformula.encodable + prim := + Primrec.nat_iff.mp <| + (encode_ofNat_primrec (L := L) (ξ := ξ)).comp (Primrec.const n) Primrec.id + +theorem primrec₂_and {n : ℕ} : Primrec₂ (fun φ ψ : Semiformula L ξ n ↦ φ ⋏ ψ) := + Primrec₂.encode_iff.mp <| + (Primrec.comp₂ (Primrec.succ.comp (Primrec₂.natPair.comp (Primrec.const 4) Primrec.id)) + (Primrec₂.natPair.comp₂ (Primrec.encode.comp₂ Primrec₂.left) + (Primrec.encode.comp₂ Primrec₂.right))).of_eq + fun φ ψ ↦ (encode_and φ ψ).symm + +theorem primrec₂_or {n : ℕ} : Primrec₂ (fun φ ψ : Semiformula L ξ n ↦ φ ⋎ ψ) := + Primrec₂.encode_iff.mp <| + (Primrec.comp₂ (Primrec.succ.comp (Primrec₂.natPair.comp (Primrec.const 5) Primrec.id)) + (Primrec₂.natPair.comp₂ (Primrec.encode.comp₂ Primrec₂.left) + (Primrec.encode.comp₂ Primrec₂.right))).of_eq + fun φ ψ ↦ (encode_or φ ψ).symm + +end Semiformula + +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Classical/Rew.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Classical/Rew.lean new file mode 100644 index 000000000..e0c9f76ec --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Classical/Rew.lean @@ -0,0 +1,709 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Finset.Basic +public import LeanPool.PointwiseComposition.Foundation.Syntax.Predicate.Rew +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Syntax.Classical.Formula + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +/-! +# Rewriting Entailment + +term/formula morphisms such as Rewritings, substitutions, and embs are handled by the structure +`FFL.FirstOrder.Rew`. +- `FFL.FirstOrder.Rew.rewrite f` is a Rewriting of the free variables occurring in the term by +`f : ξ₁ → Semiterm L ξ₂ n`. +- `FFL.FirstOrder.Rew.subst v` is a substitution of the bounded variables occurring in the term +by `v : Fin n → Semiterm L ξ n'`. +- `FFL.FirstOrder.Rew.bShift` is a transformation of the bounded variables occurring in the term +by `#x ↦ #(Fin.succ x)`. +- `FFL.FirstOrder.Rew.shift` is a transformation of the free variables occurring in the term by +`&x ↦ &(x + 1)`. +- `FFL.FirstOrder.Rew.emb` is a emb of the term with no free variables. + +Rewritings `FFL.FirstOrder.Rew` is naturally converted to formula Rewritings by +`FFL.FirstOrder.Rew.hom`. + +-/ + +namespace FFL + +namespace FirstOrder + +namespace Semiformula + +/-- The rew Aux construction in `FFL.FirstOrder.Semiformula`. -/ +def rewAux ⦃n₁ n₂ : ℕ⦄ (ω : Rew L ξ₁ n₁ ξ₂ n₂) : Semiformula L ξ₁ n₁ → Semiformula L ξ₂ n₂ + | ⊤ => ⊤ + | ⊥ => ⊥ + | rel r v => rel r (ω ∘ v) + | nrel r v => nrel r (ω ∘ v) + | φ ⋏ ψ => rewAux ω φ ⋏ rewAux ω ψ + | φ ⋎ ψ => rewAux ω φ ⋎ rewAux ω ψ + | ∀¹ φ => ∀¹ rewAux ω.q φ + | ∃¹ φ => ∃¹ rewAux ω.q φ + +lemma rewAux_neg (ω : Rew L ξ₁ n₁ ξ₂ n₂) (φ : Semiformula L ξ₁ n₁) : + rewAux ω (∼φ) = ∼rewAux ω φ := by + induction φ using Semiformula.rec' generalizing n₂ <;> simp [*, rewAux] + +lemma ext_rewAux' {ω₁ ω₂ : Rew L ξ₁ n₁ ξ₂ n₂} (h : ω₁ = ω₂) (φ : Semiformula L ξ₁ n₁) : + rewAux ω₁ φ = rewAux ω₂ φ := by simp [h] + +/-- The rew construction in `FFL.FirstOrder.Semiformula`. -/ +def rew (ω : Rew L ξ₁ n₁ ξ₂ n₂) : Semiformula L ξ₁ n₁ →ˡᶜ Semiformula L ξ₂ n₂ + where + toTr := rewAux ω + map_top' := by rfl + map_bot' := by rfl + map_neg' := rewAux_neg ω + map_and' := fun φ ψ ↦ rfl + map_or' := fun φ ψ ↦ rfl + map_imply' := fun φ ψ ↦ by simp [imp_eq, rewAux_neg, rewAux, ← neg_eq] + +instance : Rewriting L ξ (Semiformula L ξ) ζ (Semiformula L ζ) + where + app := rew + app_all (_ _) := rfl + app_exs (_ _) := rfl + +/-- The subst construction in `FFL.FirstOrder.Semiformula`. -/ +abbrev subst (φ : Semiformula L ξ n) (v : Fin n → Semiterm L ξ m) : Semiformula L ξ m := + Rewriting.subst φ v + +/-- The emb construction in `FFL.FirstOrder.Semiformula`. -/ +@[coe] +abbrev emb [IsEmpty o] (φ : Semiformula L o n) : Semiformula L ξ n := + Rewriting.emb φ + +/-- The free construction in `FFL.FirstOrder.Semiformula`. -/ +abbrev free (φ : Semiproposition L (n + 1)) : Semiproposition L n := + Rewriting.free φ + +/-- The shift construction in `FFL.FirstOrder.Semiformula`. -/ +abbrev shift (φ : Semiproposition L n) : Semiproposition L n := + Rewriting.shift φ + +lemma rew_rel (ω : Rew L ξ₁ n₁ ξ₂ n₂) {k} (r : L.Rel k) (v : Fin k → Semiterm L ξ₁ n₁) : + ω ▹ rel r v = rel r fun i ↦ ω (v i) := + rfl + +lemma rew_nrel (ω : Rew L ξ₁ n₁ ξ₂ n₂) {k} (r : L.Rel k) (v : Fin k → Semiterm L ξ₁ n₁) : + ω ▹ nrel r v = nrel r fun i ↦ ω (v i) := + rfl + +@[simp] +lemma rew_rel_eq_comp (ω : Rew L ξ₁ n₁ ξ₂ n₂) {k} {r : L.Rel k} {v : Fin k → Semiterm L ξ₁ n₁} : + ω ▹ rel r v = rel r (ω ∘ v) := + rfl + +@[simp] +lemma rew_nrel_eq_comp (ω : Rew L ξ₁ n₁ ξ₂ n₂) {k} {r : L.Rel k} + {v : Fin k → Semiterm L ξ₁ n₁} : ω ▹ nrel r v = nrel r (ω ∘ v) := + rfl + +lemma rew_rel0 (ω : Rew L ξ₁ n₁ ξ₂ n₂) {r : L.Rel 0} {v : Fin 0 → Semiterm L ξ₁ n₁} : + ω ▹ rel r v = rel r ![] := by simp [Matrix.empty_eq] + +lemma rew_rel1 (ω : Rew L ξ₁ n₁ ξ₂ n₂) {r : L.Rel 1} {t : Semiterm L ξ₁ n₁} : + ω ▹ rel r ![t] = rel r ![ω t] := by simp + +lemma rew_rel2 (ω : Rew L ξ₁ n₁ ξ₂ n₂) {r : L.Rel 2} {t₁ t₂ : Semiterm L ξ₁ n₁} : + ω ▹ rel r ![t₁, t₂] = rel r ![ω t₁, ω t₂] := by simp + +lemma rew_rel3 (ω : Rew L ξ₁ n₁ ξ₂ n₂) {r : L.Rel 3} {t₁ t₂ t₃ : Semiterm L ξ₁ n₁} : + ω ▹ rel r ![t₁, t₂, t₃] = rel r ![ω t₁, ω t₂, ω t₃] := by simp + +lemma rew_nrel0 (ω : Rew L ξ₁ n₁ ξ₂ n₂) {r : L.Rel 0} {v : Fin 0 → Semiterm L ξ₁ n₁} : + ω ▹ nrel r v = nrel r ![] := by simp [Matrix.empty_eq] + +lemma rew_nrel1 (ω : Rew L ξ₁ n₁ ξ₂ n₂) {r : L.Rel 1} {t : Semiterm L ξ₁ n₁} : + ω ▹ nrel r ![t] = nrel r ![ω t] := by simp + +lemma rew_nrel2 (ω : Rew L ξ₁ n₁ ξ₂ n₂) {r : L.Rel 2} {t₁ t₂ : Semiterm L ξ₁ n₁} : + ω ▹ nrel r ![t₁, t₂] = nrel r ![ω t₁, ω t₂] := by simp + +lemma rew_nrel3 (ω : Rew L ξ₁ n₁ ξ₂ n₂) {r : L.Rel 3} {t₁ t₂ t₃ : Semiterm L ξ₁ n₁} : + ω ▹ nrel r ![t₁, t₂, t₃] = nrel r ![ω t₁, ω t₂, ω t₃] := by simp + +private lemma map_inj {b : Fin n₁ → Fin n₂} {f : ξ₁ → ξ₂} (hb : Function.Injective b) + (hf : Function.Injective f) : + Function.Injective fun φ : Semiformula L ξ₁ n₁ ↦ @Rew.map L ξ₁ ξ₂ n₁ n₂ b f ▹ φ + | rel r v => fun φ ↦ + match φ with + | rel s w => by + simp only [rew_rel, rel.injEq, and_imp] + rintro rfl; simp only [heq_eq_eq, true_and]; rintro rfl h; simp only [true_and] + funext i; exact Rew.map_inj hb hf (congr_fun h i) + | nrel _ _ | ⊤ | ⊥ | _ ⋏ _ | _ ⋎ _ | ∀¹ _ | ∃¹ _ => by simp + | nrel r v => fun φ ↦ + match φ with + | nrel s w => by + simp only [rew_nrel, nrel.injEq, and_imp] + rintro rfl; simp only [heq_eq_eq, true_and]; rintro rfl h; simp only [true_and] + funext i; exact Rew.map_inj hb hf (congr_fun h i) + | rel _ _ | ⊤ | ⊥ | _ ⋏ _ | _ ⋎ _ | ∀¹ _ | ∃¹ _ => by simp + | ⊤ => by intro φ; cases φ using cases' <;> simp + | ⊥ => by intro φ; cases φ using cases' <;> simp + | φ ⋏ ψ => fun χ ↦ + match χ with + | _ ⋏ _ => by + simp only [LogicalConnective.HomClass.map_and, and_inj, and_imp] + intro hp hq; exact ⟨map_inj hb hf hp, map_inj hb hf hq⟩ + | rel _ _ | nrel _ _ | ⊤ | ⊥ | _ ⋎ _ | ∀¹ _ | ∃¹ _ => by simp + | φ ⋎ ψ => fun χ ↦ + match χ with + | _ ⋎ _ => by + simp only [LogicalConnective.HomClass.map_or, or_inj, and_imp] + intro hp hq; exact ⟨map_inj hb hf hp, map_inj hb hf hq⟩ + | rel _ _ | nrel _ _ | ⊤ | ⊥ | _ ⋏ _ | ∀¹ _ | ∃¹ _ => by simp + | ∀¹ φ => fun ψ ↦ + match ψ with + | ∀¹ _ => by + simp only [Rewriting.app_all, Rew.q_map, Nat.succ_eq_add_one, all_inj] + exact fun h ↦ + map_inj (b := 0 :> Fin.succ ∘ b) + (Matrix.injective_vecCons ((Fin.succ_injective _).comp hb) + (fun _ ↦ (Fin.succ_ne_zero _).symm)) + hf h + | rel _ _ | nrel _ _ | ⊤ | ⊥ | _ ⋏ _ | _ ⋎ _ | ∃¹ _ => by simp + | ∃¹ φ => fun ψ ↦ + match ψ with + | ∃¹ _ => by + simp only [Rewriting.app_exs, Rew.q_map, Nat.succ_eq_add_one, exs_inj] + exact fun h ↦ + map_inj (b := 0 :> Fin.succ ∘ b) + (Matrix.injective_vecCons ((Fin.succ_injective _).comp hb) + (fun _ ↦ (Fin.succ_ne_zero _).symm)) + hf h + | rel _ _ | nrel _ _ | ⊤ | ⊥ | _ ⋏ _ | _ ⋎ _ | ∀¹ _ => by simp + +instance : ReflectiveRewriting L ξ (Semiformula L ξ) where + id_app (φ) := by induction φ using rec' <;> simp [*, Function.comp_def] + +instance : + TransitiveRewriting L ξ₁ (Semiformula L ξ₁) ξ₂ (Semiformula L ξ₂) ξ₃ (Semiformula L ξ₃) + where + comp_app + {n₁ n₂ n₃ ω₁₂ ω₂₃ + φ} := by + induction φ using rec' generalizing n₂ n₃ <;> + simp [Rew.comp_app, Rew.q_comp, *, Function.comp_def] + +instance : InjMapRewriting L ξ (Semiformula L ξ) ζ (Semiformula L ζ) where + smul_map_injective := map_inj + +instance : LawfulSyntacticRewriting L (Semiproposition L) where + +@[simp] +lemma complexity_rew (ω : Rew L ξ₁ n₁ ξ₂ n₂) (φ : Semiformula L ξ₁ n₁) : + (ω ▹ φ).complexity = φ.complexity := by + induction φ using Semiformula.rec' generalizing n₂ <;> simp [*] + +section + +variable (ω : Rew L ξ₁ n₁ ξ₂ n₂) + +@[simp] +lemma eq_top_iff {φ : Semiformula L ξ₁ n₁} : ω ▹ φ = (⊤ : Semiformula L ξ₂ n₂) ↔ φ = ⊤ := by + cases φ using Semiformula.rec' <;> simp + +@[simp] +lemma eq_bot_iff {φ : Semiformula L ξ₁ n₁} : ω ▹ φ = (⊥ : Semiformula L ξ₂ n₂) ↔ φ = ⊥ := by + cases φ using Semiformula.rec' <;> simp + +lemma eq_rel_iff {φ : Semiformula L ξ₁ n₁} {k} {r : L.Rel k} {v} : + ω ▹ φ = Semiformula.rel r v ↔ ∃ v', ω ∘ v' = v ∧ φ = Semiformula.rel r v' := by + match φ with + | rel (arity := k') r' v' => + simp only [rew_rel, rel.injEq] + by_cases hk : k' = k <;> simp [hk]; rcases hk with rfl; simp + by_cases hr : r' = r <;> simp [hr, funext_iff] + | nrel _ _ | ⊤ | ⊥ | _ ⋏ _ | _ ⋎ _ | ∀¹ _ | ∃¹ _ => simp + +lemma eq_nrel_iff {φ : Semiformula L ξ₁ n₁} {k} {r : L.Rel k} {v} : + ω ▹ φ = Semiformula.nrel r v ↔ ∃ v', ω ∘ v' = v ∧ φ = Semiformula.nrel r v' := by + match φ with + | nrel (arity := k') r' v' => + simp only [rew_nrel] + by_cases hk : k' = k <;> simp [hk]; rcases hk with rfl; simp + by_cases hr : r' = r <;> simp [hr, funext_iff] + | rel _ _ | ⊤ | ⊥ | _ ⋏ _ | _ ⋎ _ | ∀¹ _ | ∃¹ _ => simp + +@[simp] +lemma eq_and_iff {φ : Semiformula L ξ₁ n₁} {ψ₁ ψ₂ : Semiformula L ξ₂ n₂} : + ω ▹ φ = ψ₁ ⋏ ψ₂ ↔ ∃ φ₁ φ₂ : Semiformula L ξ₁ n₁, ω ▹ φ₁ = ψ₁ ∧ ω ▹ φ₂ = ψ₂ ∧ φ = φ₁ ⋏ φ₂ := + by cases φ using Semiformula.rec' <;> simp + +@[simp] +lemma eq_or_iff {φ : Semiformula L ξ₁ n₁} {ψ₁ ψ₂ : Semiformula L ξ₂ n₂} : + ω ▹ φ = ψ₁ ⋎ ψ₂ ↔ ∃ φ₁ φ₂ : Semiformula L ξ₁ n₁, ω ▹ φ₁ = ψ₁ ∧ ω ▹ φ₂ = ψ₂ ∧ φ = φ₁ ⋎ φ₂ := + by cases φ using Semiformula.rec' <;> simp + +lemma eq_all_iff {φ : Semiformula L ξ₁ n₁} {ψ : Semiformula L ξ₂ (n₂ + 1)} : + ω ▹ φ = ∀¹ ψ ↔ ∃ φ' : Semiformula L ξ₁ (n₁ + 1), ω.q ▹ φ' = ψ ∧ φ = ∀¹ φ' := by + cases φ using Semiformula.rec' <;> simp + +lemma eq_exs_iff {φ : Semiformula L ξ₁ n₁} {ψ : Semiformula L ξ₂ (n₂ + 1)} : + ω ▹ φ = ∃¹ ψ ↔ ∃ φ' : Semiformula L ξ₁ (n₁ + 1), ω.q ▹ φ' = ψ ∧ φ = ∃¹ φ' := by + cases φ using Semiformula.rec' <;> simp + +@[simp] +lemma eq_neg_iff {φ : Semiformula L ξ₁ n₁} {ψ₁ ψ₂ : Semiformula L ξ₂ n₂} : + ω ▹ φ = ψ₁ ⇒ₗ ψ₂ ↔ + ∃ φ₁ φ₂ : Semiformula L ξ₁ n₁, ω ▹ φ₁ = ψ₁ ∧ ω ▹ φ₂ = ψ₂ ∧ φ = φ₁ ⇒ₗ φ₂ := + by + simp only [imp_eq, eq_or_iff, exists_and_left]; constructor + · rintro ⟨φ₁, hp₁, ψ₂, rfl, rfl⟩; exact ⟨∼φ₁, by simp [hp₁]⟩ + · rintro ⟨φ₁, rfl, φ₂, rfl, rfl⟩; exact ⟨∼φ₁, by simp, φ₂, by simp⟩ + +lemma eq_ball_iff {φ : Semiformula L ξ₁ n₁} {ψ₁ ψ₂ : Semiformula L ξ₂ (n₂ + 1)} : + (ω ▹ φ = ∀¹[ψ₁] ψ₂) ↔ + ∃ φ₁ φ₂ : Semiformula L ξ₁ (n₁ + 1), ω.q ▹ φ₁ = ψ₁ ∧ ω.q ▹ φ₂ = ψ₂ ∧ φ = ∀¹[φ₁] φ₂ := + by + simp only [ball, eq_all_iff, eq_neg_iff, exists_and_left]; constructor + · rintro ⟨φ', ⟨φ₁, rfl, φ₂, rfl, rfl⟩, rfl⟩; exact ⟨φ₁, rfl, φ₂, rfl, rfl⟩ + · rintro ⟨φ₁, rfl, φ₂, rfl, rfl⟩; simp + +lemma eq_bexs_iff {φ : Semiformula L ξ₁ n₁} {ψ₁ ψ₂ : Semiformula L ξ₂ (n₂ + 1)} : + (ω ▹ φ = ∃¹[ψ₁] ψ₂) ↔ + ∃ φ₁ φ₂ : Semiformula L ξ₁ (n₁ + 1), ω.q ▹ φ₁ = ψ₁ ∧ ω.q ▹ φ₂ = ψ₂ ∧ φ = ∃¹[φ₁] φ₂ := + by + simp only [bexs, eq_exs_iff, eq_and_iff, exists_and_left]; constructor + · rintro ⟨φ', ⟨φ₁, rfl, φ₂, rfl, rfl⟩, rfl⟩; exact ⟨φ₁, rfl, φ₂, rfl, rfl⟩ + · rintro ⟨φ₁, rfl, φ₂, rfl, rfl⟩; simp + +end + +instance : Coe (Semisentence L n) (Semiproposition L n) := + ⟨Rewriting.emb (ξ := ℕ)⟩ + +@[simp] +lemma coe_inj (σ π : Semisentence L n) : (σ : Semiproposition L n) = π ↔ σ = π := + Rewriting.emb_injective.eq_iff + +lemma coe_rel [IsEmpty ο] {k : ℕ} (R : L.Rel k) (v : Fin k → Semiterm L ο n) : + (Rewriting.emb (rel R v) : Semiformula L ξ n) = (rel R fun i ↦ Rew.emb (v i)) := by rfl + +lemma coe_nrel [IsEmpty ο] {k : ℕ} (R : L.Rel k) (v : Fin k → Semiterm L ο n) : + (Rewriting.emb (nrel R v) : Semiformula L ξ n) = (nrel R fun i ↦ Rew.emb (v i)) := by rfl + +lemma coe_subst_eq_subst_coe (φ : Semisentence L k) (v : Fin k → ClosedSemiterm L n) : + (↑(φ ↜ v) : Semiproposition L n) = + (↑φ : Semiproposition L k) ↜ (fun i ↦ (↑(v i) : Semiterm L ℕ n)) := + Rewriting.emb_subst_eq_subst_emb φ v + +lemma coe_subst_eq_subst_coe₁ (φ : Semisentence L 1) (t : ClosedSemiterm L n) : + (↑(φ/[t]) : Semiproposition L n) = (↑φ : Semiproposition L 1)/[(↑t : Semiterm L ℕ n)] := + Rewriting.emb_subst_eq_subst_coe₁ φ t + +/-- The formula Rec construction in `FFL.FirstOrder.Semiformula`. -/ +@[elab_as_elim] +def formulaRec {C : Proposition L → Sort _} (verum : C ⊤) (falsum : C ⊥) + (rel : ∀ {l : ℕ} (r : L.Rel l) (v : Fin l → SyntacticTerm L), C (rel r v)) + (nrel : ∀ {l : ℕ} (r : L.Rel l) (v : Fin l → SyntacticTerm L), C (nrel r v)) + (and : ∀ (φ ψ : Proposition L), C φ → C ψ → C (φ ⋏ ψ)) + (or : ∀ (φ ψ : Proposition L), C φ → C ψ → C (φ ⋎ ψ)) + (all : ∀ (φ : Semiproposition L 1), C (Rewriting.free φ) → C (∀¹ φ)) + (ex : ∀ (φ : Semiproposition L 1), C (Rewriting.free φ) → C (∃¹ φ)) : + ∀ (φ : Proposition L), C φ + | ⊤ => verum + | ⊥ => falsum + | .rel r v => rel r v + | .nrel r v => nrel r v + | φ ⋏ ψ => + and φ ψ (formulaRec verum falsum rel nrel and or all ex φ) + (formulaRec verum falsum rel nrel and or all ex ψ) + | φ ⋎ ψ => + or φ ψ (formulaRec verum falsum rel nrel and or all ex φ) + (formulaRec verum falsum rel nrel and or all ex ψ) + | ∀¹ φ => all φ (formulaRec verum falsum rel nrel and or all ex (Rewriting.free φ)) + | ∃¹ φ => ex φ (formulaRec verum falsum rel nrel and or all ex (Rewriting.free φ)) +termination_by φ => φ.complexity + +lemma hasFreeVariable_rew [DecidableEq ξ₁] [DecidableEq ξ₂] {φ : Semiformula L ξ₁ n₁} + {ω : Rew L ξ₁ n₁ ξ₂ n₂} {x} (h : (ω ▹ φ).HasFreeVariable x) : + (∃ i : Fin n₁, (ω #i).HasFreeVariable x) ∨ + (∃ z : ξ₁, φ.HasFreeVariable z ∧ (ω &z).HasFreeVariable x) := + by + induction φ using rec' generalizing n₂ + case hverum => simp [HasFreeVariable] at h + case hfalsum => simp [HasFreeVariable] at h + case hrel n k r + v => + have : ∃ i, (ω (v i)).HasFreeVariable x := by simpa [rew_rel, hasFreeVariable_rel] using h + rcases this with ⟨i, hi⟩ + rcases Semiterm.hasFreeVariable_rew hi with (h | ⟨z, hi, hz⟩) + · left; exact h + · right; exact ⟨z, by simpa using ⟨i, hi⟩, hz⟩ + case hnrel n k r + v => + have : ∃ i, (ω (v i)).HasFreeVariable x := by simpa [rew_nrel, hasFreeVariable_rel] using h + rcases this with ⟨i, hi⟩ + rcases Semiterm.hasFreeVariable_rew hi with (h | ⟨z, hi, hz⟩) + · left; exact h + · right; exact ⟨z, by simpa using ⟨i, hi⟩, hz⟩ + case hand n φ ψ ihp + ihq => + have : (ω ▹ φ).HasFreeVariable x ∨ (ω ▹ ψ).HasFreeVariable x := by simpa using h + rcases this with (h | h) + · rcases ihp h with (h | ⟨z, hi, hz⟩) + · exact .inl h + · exact .inr ⟨z, by simp [hi], hz⟩ + · rcases ihq h with (h | ⟨z, hi, hz⟩) + · exact .inl h + · exact .inr ⟨z, by simp [hi], hz⟩ + case hor n φ ψ ihp + ihq => + have : (ω ▹ φ).HasFreeVariable x ∨ (ω ▹ ψ).HasFreeVariable x := by simpa using h + rcases this with (h | h) + · rcases ihp h with (h | ⟨z, hi, hz⟩) + · exact .inl h + · exact .inr ⟨z, by simp [hi], hz⟩ + · rcases ihq h with (h | ⟨z, hi, hz⟩) + · exact .inl h + · exact .inr ⟨z, by simp [hi], hz⟩ + case hall n φ + ihp => + have : + (Rew.bind (#0 :> fun i ↦ Rew.bShift (ω #i)) (fun z ↦ Rew.bShift (ω &z)) ▹ + φ).HasFreeVariable + x := + h + rcases ihp this with (⟨z, hz⟩ | ⟨z, hz⟩) + · cases z using Fin.cases + case zero => simp at hz + case succ i => + have : (ω #i).HasFreeVariable x := by simpa using hz + exact .inl ⟨i, this⟩ + · have : φ.HasFreeVariable z ∧ (ω &z).HasFreeVariable x := by simpa using hz + exact .inr ⟨z, this⟩ + case hexs n φ + ihp => + have : + (Rew.bind (#0 :> fun i ↦ Rew.bShift (ω #i)) (fun z ↦ Rew.bShift (ω &z)) ▹ + φ).HasFreeVariable + x := + h + rcases ihp this with (⟨z, hz⟩ | ⟨z, hz⟩) + · cases z using Fin.cases + case zero => simp at hz + case succ i => + have : (ω #i).HasFreeVariable x := by simpa using hz + left; exact ⟨i, this⟩ + · have : φ.HasFreeVariable z ∧ (ω &z).HasFreeVariable x := by simpa using hz + right; exact ⟨z, this⟩ + +@[simp] +lemma freeVariables_emb [DecidableEq ξ] {ο : Type*} [IsEmpty ο] (φ : Semiformula L ο n) : + (Rewriting.emb φ : Semiformula L ξ n).freeVariables = ∅ := + by + ext x + suffices x ∉ (Rewriting.emb φ : Semiformula L ξ n).freeVariables by simpa using this + intro hx + rcases hasFreeVariable_rew hx with (⟨i, hi⟩ | ⟨z, _⟩) + · simp at hi + · exact IsEmpty.elim inferInstance z + +lemma rew_eq_of_funEqOn [DecidableEq ξ₁] {ω₁ ω₂ : Rew L ξ₁ n₁ ξ₂ n₂} {φ : Semiformula L ξ₁ n₁} + (hb : ∀ x, ω₁ #x = ω₂ #x) + (hf : Function.funEqOn φ.HasFreeVariable (ω₁ ∘ Semiterm.fvar) (ω₂ ∘ Semiterm.fvar)) : + ω₁ ▹ φ = ω₂ ▹ φ := by + induction φ using rec' generalizing n₂ + case hverum => simp + case hfalsum => simp + case hrel => + simp only [rew_rel, rel.injEq, heq_eq_eq, true_and] + funext i + exact + Semiterm.rew_eq_of_funEqOn _ _ _ hb + (hf.of_subset fun x hx ↦ hasFreeVariable_rel.mpr ⟨i, hx⟩) + case hnrel => + simp only [rew_nrel, nrel.injEq, heq_eq_eq, true_and] + funext i + exact + Semiterm.rew_eq_of_funEqOn _ _ _ hb + (hf.of_subset fun x hx ↦ hasFreeVariable_nrel.mpr ⟨i, hx⟩) + case hand ihp ihq => + simp only [LogicalConnective.HomClass.map_and, and_inj] + exact + ⟨ihp hb (hf.of_subset fun x hx ↦ by simp [hx]), + ihq hb (hf.of_subset fun x hx ↦ by simp [hx])⟩ + case hor ihp ihq => + simp only [LogicalConnective.HomClass.map_or, or_inj] + exact + ⟨ihp hb (hf.of_subset fun x hx ↦ by simp [hx]), + ihq hb (hf.of_subset fun x hx ↦ by simp [hx])⟩ + case hall ih => + simp only [Rewriting.app_all, all_inj] + exact + ih (fun x ↦ by cases x using Fin.cases <;> simp [hb]) + (fun x hx ↦ by simpa using congr_arg _ (hf x hx)) + case hexs ih => + simp only [Rewriting.app_exs, exs_inj] + exact + ih (fun x ↦ by cases x using Fin.cases <;> simp [hb]) + (fun x hx ↦ by simpa using congr_arg _ (hf x hx)) + +lemma rew_eq_of_funEqOn₀ [DecidableEq ξ₁] {ω₁ ω₂ : Rew L ξ₁ 0 ξ₂ n₂} {φ : Semiformula L ξ₁ 0} + (hf : Function.funEqOn (φ.HasFreeVariable) (ω₁ ∘ Semiterm.fvar) (ω₂ ∘ Semiterm.fvar)) : + ω₁ ▹ φ = ω₂ ▹ φ := + rew_eq_of_funEqOn (fun x ↦ Fin.elim0 x) hf + +lemma rew_eq_self_of [DecidableEq ξ] {ω : Rew L ξ n ξ n} {φ : Semiformula L ξ n} + (hb : ∀ x, ω #x = #x) (hf : ∀ x, φ.HasFreeVariable x → ω &x = &x) : ω ▹ φ = φ := + by + suffices ω ▹ φ = Rew.id ▹ φ by rwa [ReflectiveRewriting.id_app] at this + apply rew_eq_of_funEqOn + · intro x; simpa using hb x + · intro x hx; simp [hf x hx] + +@[simp] +lemma ex_ne_subst (φ : Semiformula L ξ 1) (t) : φ/[t] ≠ ∃¹ φ := + ne_of_ne_complexity (by simp) + +section univCl + +@[simp] +lemma fvSup_sentence (σ : Semisentence L n) : (Rewriting.emb σ).fvSup = 0 := by + induction σ using rec' <;> simp [fvSup, -rew_rel_eq_comp, -rew_nrel_eq_comp] + +private lemma not_hasFreeVariable_fixitr_fvSup (φ : Proposition L) : + ¬(Rew.fixitr 0 φ.fvSup ▹ φ).HasFreeVariable x := + by + rw [Rew.eq_bind (Rew.fixitr 0 φ.fvSup)] + simp only [Function.comp_def, Rew.fixitr_bvar, Rew.fixitr_fvar, Fin.natAdd_mk, zero_add] + intro h + rcases hasFreeVariable_rew h with (⟨z, hz⟩ | ⟨z, hz, hx⟩) + · simp at hz + · have : z < φ.fvSup := lt_fvSup_of_hasFreeVariable hz + simp [this] at hx + +@[simp] +lemma subst_comp_fixitr_eq_map (φ : Proposition L) (f : ℕ → SyntacticTerm L) : + (Rew.fixitr 0 φ.fvSup ▹ φ) ↜ (fun x ↦ f x) = Rew.rewrite f ▹ φ := + by + unfold Rewriting.subst; rw [← TransitiveRewriting.comp_app] + apply rew_eq_of_funEqOn + · simp + · intro x hx + simp [Rew.comp_app, Rew.fixitr_fvar, Semiformula.lt_fvSup_of_hasFreeVariable hx] + +lemma subst_comp_fixitr (φ : Proposition L) : + (Rew.fixitr 0 φ.fvSup ▹ φ) ↜ (fun x ↦ (&x : SyntacticTerm L)) = φ := + by + unfold Rewriting.subst; rw [← TransitiveRewriting.comp_app] + apply rew_eq_self_of + · simp + · intro x hx + simp [Rew.comp_app, Rew.fixitr_fvar, Semiformula.lt_fvSup_of_hasFreeVariable hx] + +/-- The univ Cl' construction in `FFL.FirstOrder.Semiformula`. -/ +def univCl' (φ : Proposition L) : Proposition L := + ∀¹* (@Rew.fixitr L 0 φ.fvSup ▹ φ) + +@[simp] +lemma rew_univCl' (φ : Proposition L) (ω : SyntacticRew L 0 0) : ω ▹ φ.univCl' = φ.univCl' := + rew_eq_self_of (by simp) (by simp [univCl', not_hasFreeVariable_fixitr_fvSup]) + +lemma univCl'_eq_self_of (φ : Proposition L) (h : φ.freeVariables = ∅) : φ.univCl' = φ := + by + have : φ.fvSup = 0 := by simp [fvSup, h] + simp only [univCl']; rw [this]; simp + +@[simp] +lemma senetnce_univCl'_eq_self (σ : Sentence L) : (σ : Proposition L).univCl' = σ := + univCl'_eq_self_of _ (by simp) + +@[simp] +lemma fvarList_univCl' (φ : Proposition L) : φ.univCl'.freeVariables = ∅ := + by + ext x + suffices x ∉ φ.univCl'.freeVariables by simpa + simpa [univCl'] using not_hasFreeVariable_fixitr_fvSup φ + +@[simp] +lemma univCl'_univCl'_eq_univCl' (φ : Proposition L) : φ.univCl'.univCl' = φ.univCl' := + univCl'_eq_self_of φ.univCl' (by simp) + +/-- The to Empty construction in `FFL.FirstOrder.Semiformula`. -/ +def toEmpty [DecidableEq ξ] {n : ℕ} : + (φ : Semiformula L ξ n) → φ.freeVariables = ∅ → Semisentence L n + | rel R v, h => + rel R fun i ↦ + (v i).toEmpty <| by revert i; simpa [freeVariables_rel, Finset.biUnion_eq_empty] using h + | nrel R v, h => + nrel R fun i ↦ + (v i).toEmpty <| by revert i; simpa [freeVariables_nrel, Finset.biUnion_eq_empty] using h + | ⊤, _ => ⊤ + | ⊥, _ => ⊥ + | φ ⋏ ψ, h => + φ.toEmpty + (by + simp [show φ.freeVariables = ∅ ∧ ψ.freeVariables = ∅ by + simpa [Finset.union_eq_empty] using h]) ⋏ + ψ.toEmpty + (by + simp [show φ.freeVariables = ∅ ∧ ψ.freeVariables = ∅ by + simpa [Finset.union_eq_empty] using h]) + | φ ⋎ ψ, h => + φ.toEmpty + (by + simp [show φ.freeVariables = ∅ ∧ ψ.freeVariables = ∅ by + simpa [Finset.union_eq_empty] using h]) ⋎ + ψ.toEmpty + (by + simp [show φ.freeVariables = ∅ ∧ ψ.freeVariables = ∅ by + simpa [Finset.union_eq_empty] using h]) + | ∀¹ φ, h => ∀¹ φ.toEmpty (by simpa using h) + | ∃¹ φ, h => ∃¹ φ.toEmpty (by simpa using h) + +@[simp] +lemma emb_toEmpty [DecidableEq ξ] (φ : Semiformula L ξ n) (hp : φ.freeVariables = ∅) : + Rewriting.emb (φ.toEmpty hp) = φ := by + induction φ using rec' with + | hall φ ih => simp only [toEmpty, Rewriting.app_all, Rew.q_emb]; congr 1; exact ih hp + | hexs φ ih => simp only [toEmpty, Rewriting.app_exs, Rew.q_emb]; congr 1; exact ih hp + | _ => simp [toEmpty, Function.comp_def, *] + +@[simp] +lemma toEmpty_emb [DecidableEq ξ] (φ : Semisentence L n) : + (Rewriting.emb φ : Semiformula L ξ n).toEmpty (by simp) = φ := by + induction φ using rec' <;> simp [toEmpty, *] + +@[simp] +lemma toEmpty_verum [DecidableEq ξ] : (⊤ : Semiformula L ξ n).toEmpty (by simp) = ⊤ := + rfl + +@[simp] +lemma toEmpty_falsum [DecidableEq ξ] : (⊥ : Semiformula L ξ n).toEmpty (by simp) = ⊥ := + rfl + +@[simp] +lemma toEmpty_and [DecidableEq ξ] (φ ψ : Semiformula L ξ n) (h) : + (φ ⋏ ψ).toEmpty h = + φ.toEmpty (by simp [by simpa [Finset.union_eq_empty] using h]) ⋏ + ψ.toEmpty (by simp [by simpa [Finset.union_eq_empty] using h]) := + rfl + +@[simp] +lemma toEmpty_or [DecidableEq ξ] (φ ψ : Semiformula L ξ n) (h) : + (φ ⋎ ψ).toEmpty h = + φ.toEmpty (by simp [by simpa [Finset.union_eq_empty] using h]) ⋎ + ψ.toEmpty (by simp [by simpa [Finset.union_eq_empty] using h]) := + rfl + +@[simp] +lemma toEmpty_all [DecidableEq ξ] (φ : Semiformula L ξ (n + 1)) (h) : + (∀¹ φ).toEmpty h = ∀¹ (φ.toEmpty (by simpa using h)) := + rfl + +@[simp] +lemma toEmpty_ex [DecidableEq ξ] (φ : Semiformula L ξ (n + 1)) (h) : + (∃¹ φ).toEmpty h = ∃¹ (φ.toEmpty (by simpa using h)) := + rfl + +/-- An universal closure of formula -/ +def univCl (φ : Proposition L) : Sentence L := + φ.univCl'.toEmpty (by simp) + +@[simp] +lemma coe_univCl_eq_univCl' (φ : Proposition L) : (φ.univCl : Proposition L) = φ.univCl' := by + simp [univCl] + +@[simp] +lemma univCl_coe_sentence (σ : Sentence L) : univCl (↑σ : Proposition L) = σ := + by + unfold univCl + refine (Semiformula.coe_inj _ _).mp ?_ + rw [emb_toEmpty] + simp + +/-- The to Empty' construction in `FFL.FirstOrder.Semiformula`. -/ +def toEmpty' [DecidableEq ξ] {n : ℕ} (φ : Semiformula L ξ n) : Semisentence L n := + if h : φ.freeVariables = ∅ then φ.toEmpty h else ⊥ + +@[simp] +lemma toEmpty'_coe [DecidableEq ξ] {n : ℕ} {φ : Semisentence L n} : + (Rewriting.emb φ : Semiformula L ξ n).toEmpty' = φ := by simp [toEmpty'] + +end univCl + +section lMap + +variable {L : Language.{u}} {L₁ : Language.{u₁}} {L₂ : Language.{u₂}} {L₃ : Language.{u₃}} + {ξ : Type*} {Φ : L₁ →ᵥ L₂} + +lemma lMap_bind (b : Fin n₁ → Semiterm L₁ ξ₂ n₂) (e : ξ₁ → Semiterm L₁ ξ₂ n₂) + (φ : Semiformula L₁ ξ₁ n₁) : + lMap Φ (Rew.bind b e ▹ φ) = + Rew.bind (Semiterm.lMap Φ ∘ b) (Semiterm.lMap Φ ∘ e) ▹ (lMap Φ φ) := + by + induction φ using rec' generalizing ξ₂ n₂ <;> + simp [*, lMap_rel, lMap_nrel, Semiterm.lMap_bind, Rew.q_bind, Matrix.comp_vecCons', + Semiterm.lMap_bShift, Function.comp_def] + +lemma lMap_map (b : Fin n₁ → Fin n₂) (e : ξ₁ → ξ₂) (φ : Semiformula L₁ ξ₁ n₁) : + lMap Φ (Rew.map (L := L₁) b e ▹ φ) = Rew.map (L := L₂) b e ▹ lMap Φ φ := + lMap_bind _ _ _ + +lemma lMap_rewrite (f : ξ₁ → Semiterm L₁ ξ₂ n) (φ : Semiformula L₁ ξ₁ n) : + lMap Φ (Rew.rewrite f ▹ φ) = Rew.rewrite (Semiterm.lMap Φ ∘ f) ▹ lMap Φ φ := by + simp [Rew.rewrite, lMap_bind, Function.comp_def] + +lemma lMap_subst (w : Fin k → Semiterm L₁ ξ n) (φ : Semiformula L₁ ξ k) : + lMap Φ (φ ↜ w) = (lMap Φ φ) ↜ (Semiterm.lMap Φ ∘ w) := + lMap_bind _ _ _ + +lemma lMap_shift (φ : Semiproposition L₁ n) : + lMap Φ (@Rew.shift L₁ n ▹ φ) = @Rew.shift L₂ n ▹ lMap Φ φ := + lMap_bind _ _ _ + +lemma lMap_free (φ : Semiproposition L₁ (n + 1)) : + lMap Φ (@Rew.free L₁ n ▹ φ) = @Rew.free L₂ n ▹ lMap Φ φ := by + simp [Rew.free, lMap_bind, Function.comp_def, Matrix.comp_vecConsLast] + +lemma lMap_fix (φ : Semiproposition L₁ n) : + lMap Φ (@Rew.fix L₁ n ▹ φ) = @Rew.fix L₂ n ▹ lMap Φ φ := + by + simp only [Rew.fix, lMap_bind, Function.comp_def, Semiterm.lMap_bvar] + congr; + { funext x; cases x <;> simp + } + +lemma lMap_emb {ο : Type _} [IsEmpty ο] (φ : Semiformula L₁ ο n) : + (lMap Φ (Rewriting.emb φ : Semiformula L₁ ξ n)) = Rewriting.emb (lMap Φ φ) := + lMap_bind _ _ _ + +lemma lMap_rewriteMap (φ : Semiformula L₁ ξ₁ n) (f : ξ₁ → ξ₂) : + lMap Φ (Rew.rewriteMap (L := L₁) (n := n) f ▹ φ) = + (Rew.rewriteMap (L := L₂) (n := n) f) ▹ (lMap Φ φ) := + by simp [Rew.rewriteMap, lMap_rewrite, Function.comp_def] + +end lMap + +@[simp] +lemma rew_open_iff {ω : Rew L ξ₁ n₁ ξ₂ n₂} {φ : Semiformula L ξ₁ n₁} : (ω ▹ φ).Open ↔ φ.Open := + by induction φ using Semiformula.rec' <;> simp [open_top, open_bot, open_rel, open_nrel, *] + +end Semiformula + +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Intuitionistic/Formula.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Intuitionistic/Formula.lean new file mode 100644 index 000000000..20006111f --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Intuitionistic/Formula.lean @@ -0,0 +1,421 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Syntax.Classical.Formula + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +/-! +# Formulas of intuitionistic first-order logic + +This file defines the formulas of first-order logic. + +`φ : Semiformulaᵢ L ξ n` is a (semi-)formula of language `L` with bounded variables of `Fin n` +and free variables of `ξ`. +The quantification is represented by de Bruijn index. + +-/ + +namespace FFL +namespace FirstOrder + +/-- Intuitionistic first-order formulas with separate bound and free variables. -/ +inductive Semiformulaᵢ (L : Language) (ξ : Type*) : ℕ → Type _ where + | falsum : Semiformulaᵢ L ξ n + | rel : {arity : ℕ} → L.Rel arity → (Fin arity → Semiterm L ξ n) → Semiformulaᵢ L ξ n + | and : Semiformulaᵢ L ξ n → Semiformulaᵢ L ξ n → Semiformulaᵢ L ξ n + | or : Semiformulaᵢ L ξ n → Semiformulaᵢ L ξ n → Semiformulaᵢ L ξ n + | imp : Semiformulaᵢ L ξ n → Semiformulaᵢ L ξ n → Semiformulaᵢ L ξ n + | all : Semiformulaᵢ L ξ (n + 1) → Semiformulaᵢ L ξ n + | exs : Semiformulaᵢ L ξ (n + 1) → Semiformulaᵢ L ξ n + +/-- The Formulaᵢ construction in `FFL.FirstOrder`. -/ +abbrev Formulaᵢ (L : Language) (ξ : Type*) := + Semiformulaᵢ L ξ 0 + +/-- The Sentenceᵢ construction in `FFL.FirstOrder`. -/ +abbrev Sentenceᵢ (L : Language) := + Formulaᵢ L Empty + +/-- The Semisentenceᵢ construction in `FFL.FirstOrder`. -/ +abbrev Semisentenceᵢ (L : Language) (n : ℕ) := + Semiformulaᵢ L Empty n + +/-- The Semipropositionᵢ construction in `FFL.FirstOrder`. -/ +abbrev Semipropositionᵢ (L : Language) (n : ℕ) := + Semiformulaᵢ L ℕ n + +/-- The Propositionᵢ construction in `FFL.FirstOrder`. -/ +abbrev Propositionᵢ (L : Language) := + Semipropositionᵢ L 0 + +variable {L : Language} + +namespace Semiformulaᵢ + +instance : Bot (Semiformulaᵢ L ξ n) := + ⟨falsum⟩ + +instance : Arrow (Semiformulaᵢ L ξ n) := + ⟨imp⟩ + +/-- The neg construction in `FFL.FirstOrder.Semiformulaᵢ`. -/ +abbrev neg (φ : Semiformulaᵢ L ξ n) : Semiformulaᵢ L ξ n := + φ ⇒ₗ ⊥ + +/-- The verum construction in `FFL.FirstOrder.Semiformulaᵢ`. -/ +abbrev verum : Semiformulaᵢ L ξ n := + ⊥ ⇒ₗ ⊥ + +instance : LogicalConnective (Semiformulaᵢ L ξ n) + where + arrow := imp + wedge := and + vee := or + tilde := neg + +instance : LogicalNeutral (Semiformulaᵢ L ξ n) + where + top := verum + bot := falsum + +lemma neg_def (φ : Semiformulaᵢ L ξ n) : ∼φ = φ ⇒ₗ ⊥ := + rfl + +lemma verum_def : (⊤ : Semiformulaᵢ L ξ n) = ⊥ ⇒ₗ ⊥ := + rfl + +instance : Quantifier (Semiformulaᵢ L ξ) + where + all := all + exs := exs + +section ToString + +variable [∀ k, ToString (L.Func k)] [∀ k, ToString (L.Rel k)] [ToString ξ] + +/-- The to Str construction in `FFL.FirstOrder.Semiformulaᵢ`. -/ +def toStr : ∀ {n}, Semiformulaᵢ L ξ n → String + | _, ⊥ => "\\bot" + | _, rel (arity := 0) r _ => "{" ++ toString r ++ "}" + | _, rel (arity := _ + 1) r v => + "{" ++ toString r ++ "} \\left(" ++ String.vecToStr (fun i => toString (v i)) ++ "\\right)" + | _, φ ⋏ ψ => "\\left(" ++ toStr φ ++ " \\land " ++ toStr ψ ++ "\\right)" + | _, φ ⋎ ψ => "\\left(" ++ toStr φ ++ " \\lor " ++ toStr ψ ++ "\\right)" + | _, φ ⇒ₗ ψ => "\\left(" ++ toStr φ ++ " \\to " ++ toStr ψ ++ "\\right)" + | n, all φ => "(\\forall x_{" ++ toString n ++ "}) " ++ toStr φ + | n, exs φ => "(\\exists x_{" ++ toString n ++ "}) " ++ toStr φ + +instance : Repr (Semiformulaᵢ L ξ n) := + ⟨fun t _ => toStr t⟩ + +instance : ToString (Semiformulaᵢ L ξ n) := + ⟨toStr⟩ + +end ToString + +@[simp] +lemma and_inj (φ₁ ψ₁ φ₂ ψ₂ : Semiformulaᵢ L ξ n) : φ₁ ⋏ φ₂ = ψ₁ ⋏ ψ₂ ↔ φ₁ = ψ₁ ∧ φ₂ = ψ₂ := + Iff.of_eq <| and.injEq _ _ _ _ + +@[simp] +lemma or_inj (φ₁ ψ₁ φ₂ ψ₂ : Semiformulaᵢ L ξ n) : φ₁ ⋎ φ₂ = ψ₁ ⋎ ψ₂ ↔ φ₁ = ψ₁ ∧ φ₂ = ψ₂ := + Iff.of_eq <| or.injEq _ _ _ _ + +@[simp] +lemma imp_inj {φ₁ φ₂ ψ₁ ψ₂ : Semiformulaᵢ L ξ n} : φ₁ ⇒ₗ φ₂ = ψ₁ ⇒ₗ ψ₂ ↔ φ₁ = ψ₁ ∧ φ₂ = ψ₂ := + Iff.of_eq <| imp.injEq _ _ _ _ + +@[simp] +lemma all_inj (φ ψ : Semiformulaᵢ L ξ (n + 1)) : ∀¹ φ = ∀¹ ψ ↔ φ = ψ := by + simp [UnivQuantifier.all] + +@[simp] +lemma exs_inj (φ ψ : Semiformulaᵢ L ξ (n + 1)) : ∃¹ φ = ∃¹ ψ ↔ φ = ψ := by + simp [ExsQuantifier.exs] + +@[simp] +lemma allClosure_inj (φ ψ : Semiformulaᵢ L ξ n) : ∀¹* φ = ∀¹* ψ ↔ φ = ψ := by + induction n <;> simp [*, allClosure_succ] + +@[simp] +lemma exsClosure_inj (φ ψ : Semiformulaᵢ L ξ n) : ∃¹* φ = ∃¹* ψ ↔ φ = ψ := by + induction n <;> simp [*, exsClosure_succ] + +@[simp] +lemma allItr_inj {k} (φ ψ : Semiformulaᵢ L ξ (n + k)) : ∀¹^[k] φ = ∀¹^[k] ψ ↔ φ = ψ := by + induction k <;> simp [*, allItr_succ] + +@[simp] +lemma exsItr_inj {k} (φ ψ : Semiformulaᵢ L ξ (n + k)) : ∃¹^[k] φ = ∃¹^[k] ψ ↔ φ = ψ := by + induction k <;> simp [*, exsItr_succ] + +/-- The complexity construction in `FFL.FirstOrder.Semiformulaᵢ`. -/ +def complexity {n} : Semiformulaᵢ L ξ n → ℕ + | ⊥ => 0 + | rel _ _ => 0 + | φ ⋏ ψ => max φ.complexity ψ.complexity + 1 + | φ ⋎ ψ => max φ.complexity ψ.complexity + 1 + | φ ⇒ₗ ψ => max φ.complexity ψ.complexity + 1 + | ∀¹ φ => φ.complexity + 1 + | ∃¹ φ => φ.complexity + 1 + +@[simp] +lemma complexity_top : complexity (⊤ : Semiformulaᵢ L ξ n) = 1 := + rfl + +@[simp] +lemma complexity_bot : complexity (⊥ : Semiformulaᵢ L ξ n) = 0 := + rfl + +@[simp] +lemma complexity_rel {k} (r : L.Rel k) (v : Fin k → Semiterm L ξ n) : + complexity (rel r v) = 0 := + rfl + +@[simp] +lemma complexity_and (φ ψ : Semiformulaᵢ L ξ n) : + complexity (φ ⋏ ψ) = max φ.complexity ψ.complexity + 1 := + rfl + +@[simp] +lemma complexity_and' (φ ψ : Semiformulaᵢ L ξ n) : + complexity (and φ ψ) = max φ.complexity ψ.complexity + 1 := + rfl + +@[simp] +lemma complexity_or (φ ψ : Semiformulaᵢ L ξ n) : + complexity (φ ⋎ ψ) = max φ.complexity ψ.complexity + 1 := + rfl + +@[simp] +lemma complexity_or' (φ ψ : Semiformulaᵢ L ξ n) : + complexity (or φ ψ) = max φ.complexity ψ.complexity + 1 := + rfl + +@[simp] +lemma complexity_imp (φ ψ : Semiformulaᵢ L ξ n) : + complexity (φ ⇒ₗ ψ) = max φ.complexity ψ.complexity + 1 := + rfl + +@[simp] +lemma complexity_imp' (φ ψ : Semiformulaᵢ L ξ n) : + complexity (imp φ ψ) = max φ.complexity ψ.complexity + 1 := + rfl + +@[simp] +lemma complexity_all (φ : Semiformulaᵢ L ξ (n + 1)) : complexity (∀¹ φ) = φ.complexity + 1 := + rfl + +@[simp] +lemma complexity_all' (φ : Semiformulaᵢ L ξ (n + 1)) : complexity (all φ) = φ.complexity + 1 := + rfl + +@[simp] +lemma complexity_exs (φ : Semiformulaᵢ L ξ (n + 1)) : complexity (∃¹ φ) = φ.complexity + 1 := + rfl + +@[simp] +lemma complexity_exs' (φ : Semiformulaᵢ L ξ (n + 1)) : complexity (exs φ) = φ.complexity + 1 := + rfl + +@[simp] +lemma complexity_neg (φ : Semiformulaᵢ L ξ n) : complexity (∼φ) = complexity φ + 1 := by + simp [neg_def] + +/-- The cases' construction in `FFL.FirstOrder.Semiformulaᵢ`. -/ +@[elab_as_elim] +def cases' {C : ∀ n, Semiformulaᵢ L ξ n → Sort w} + (hRel : ∀ {n k : ℕ} (r : L.Rel k) (v : Fin k → Semiterm L ξ n), C n (rel r v)) + (hFalsum : ∀ {n : ℕ}, C n ⊥) (hAnd : ∀ {n : ℕ} (φ ψ : Semiformulaᵢ L ξ n), C n (φ ⋏ ψ)) + (hOr : ∀ {n : ℕ} (φ ψ : Semiformulaᵢ L ξ n), C n (φ ⋎ ψ)) + (hImp : ∀ {n : ℕ} (φ ψ : Semiformulaᵢ L ξ n), C n (φ ⇒ₗ ψ)) + (hAll : ∀ {n : ℕ} (φ : Semiformulaᵢ L ξ (n + 1)), C n (∀¹ φ)) + (hExs : ∀ {n : ℕ} (φ : Semiformulaᵢ L ξ (n + 1)), C n (∃¹ φ)) {n} : + (φ : Semiformulaᵢ L ξ n) → C n φ + | rel r v => hRel r v + | ⊥ => hFalsum + | φ ⋏ ψ => hAnd φ ψ + | φ ⋎ ψ => hOr φ ψ + | φ ⇒ₗ ψ => hImp φ ψ + | ∀¹ φ => hAll φ + | ∃¹ φ => hExs φ + +/-- The rec' construction in `FFL.FirstOrder.Semiformulaᵢ`. -/ +@[elab_as_elim] +def rec' {C : ∀ n, Semiformulaᵢ L ξ n → Sort w} + (hRel : ∀ {n k : ℕ} (r : L.Rel k) (v : Fin k → Semiterm L ξ n), C n (rel r v)) + (hFalsum : ∀ {n : ℕ}, C n ⊥) + (hAnd : ∀ {n : ℕ} (φ ψ : Semiformulaᵢ L ξ n), C n φ → C n ψ → C n (φ ⋏ ψ)) + (hOr : ∀ {n : ℕ} (φ ψ : Semiformulaᵢ L ξ n), C n φ → C n ψ → C n (φ ⋎ ψ)) + (hImp : ∀ {n : ℕ} (φ ψ : Semiformulaᵢ L ξ n), C n φ → C n ψ → C n (φ ⇒ₗ ψ)) + (hAll : ∀ {n : ℕ} (φ : Semiformulaᵢ L ξ (n + 1)), C (n + 1) φ → C n (∀¹ φ)) + (hExs : ∀ {n : ℕ} (φ : Semiformulaᵢ L ξ (n + 1)), C (n + 1) φ → C n (∃¹ φ)) {n} : + (φ : Semiformulaᵢ L ξ n) → C n φ + | rel r v => hRel r v + | ⊥ => hFalsum + | φ ⋏ ψ => + hAnd φ ψ (rec' hRel hFalsum hAnd hOr hImp hAll hExs φ) + (rec' hRel hFalsum hAnd hOr hImp hAll hExs ψ) + | φ ⋎ ψ => + hOr φ ψ (rec' hRel hFalsum hAnd hOr hImp hAll hExs φ) + (rec' hRel hFalsum hAnd hOr hImp hAll hExs ψ) + | φ ⇒ₗ ψ => + hImp φ ψ (rec' hRel hFalsum hAnd hOr hImp hAll hExs φ) + (rec' hRel hFalsum hAnd hOr hImp hAll hExs ψ) + | ∀¹ φ => hAll φ (rec' hRel hFalsum hAnd hOr hImp hAll hExs φ) + | ∃¹ φ => hExs φ (rec' hRel hFalsum hAnd hOr hImp hAll hExs φ) + +section Decidable + +variable [L.DecidableEq] [DecidableEq ξ] + +/-- The has Dec Eq construction in `FFL.FirstOrder.Semiformulaᵢ`. -/ +def hasDecEq {n} : (φ ψ : Semiformulaᵢ L ξ n) → Decidable (φ = ψ) + | ⊥, ψ => by + cases ψ using cases' <;> + { simp only [reduceCtorEq]; + try { exact isFalse not_false + }; + try { exact isTrue trivial + } + } + | rel r v, ψ => + by + cases ψ using cases' <;> + try { simpa using isFalse not_false + } + case hRel k₁ k₂ r₂ v₂ => + by_cases e : k₁ = k₂ + · rcases e with rfl + exact + match decEq r r₂ with + | isTrue h => by simpa [h] using Matrix.decVec _ _ (fun i => decEq (v i) (v₂ i)) + | isFalse h => isFalse (by simp [h]) + · exact isFalse (by simp [e]) + | φ ⋏ ψ, χ => + by + cases χ using cases' <;> + try { simpa using isFalse not_false + } + case hAnd φ' ψ' => + exact + match hasDecEq φ φ' with + | isTrue hp => + match hasDecEq ψ ψ' with + | isTrue hq => isTrue (hp ▸ hq ▸ rfl) + | isFalse hq => isFalse (by simp [hp, hq]) + | isFalse hp => isFalse (by simp [hp]) + | φ ⋎ ψ, χ => + by + cases χ using cases' <;> + try { simpa using isFalse not_false + } + case hOr φ' ψ' => + exact + match hasDecEq φ φ' with + | isTrue hp => + match hasDecEq ψ ψ' with + | isTrue hq => isTrue (hp ▸ hq ▸ rfl) + | isFalse hq => isFalse (by simp [hp, hq]) + | isFalse hp => isFalse (by simp [hp]) + | φ ⇒ₗ ψ, χ => + by + cases χ using cases' <;> + try { simpa using isFalse not_false + } + case hImp φ' ψ' => + exact + match hasDecEq φ φ' with + | isTrue hp => + match hasDecEq ψ ψ' with + | isTrue hq => isTrue (hp ▸ hq ▸ rfl) + | isFalse hq => isFalse (by simp [hp, hq]) + | isFalse hp => isFalse (by simp [hp]) + | ∀¹ φ, ψ => + by + cases ψ using cases' <;> + try { simpa using isFalse not_false + } + case hAll φ' => simpa using hasDecEq φ φ' + | ∃¹ φ, ψ => + by + cases ψ using cases' <;> + try { simpa using isFalse not_false + } + case hExs φ' => simpa using hasDecEq φ φ' + +instance : DecidableEq (Semiformulaᵢ L ξ n) := + hasDecEq + +end Decidable + +end Semiformulaᵢ + +/-! +## (Weak) Negative formula -/ + +namespace Semiformulaᵢ + +/-- Data and laws for Is Negative in `FFL.FirstOrder.Semiformulaᵢ`. -/ +inductive IsNegative : Semiformulaᵢ L ξ n → Prop + | falsum : IsNegative ⊥ + | and {φ ψ} : IsNegative φ → IsNegative ψ → IsNegative (φ ⋏ ψ) + | imply {φ ψ} : IsNegative ψ → IsNegative (φ ⇒ₗ ψ) + | all {φ} : IsNegative φ → IsNegative (∀¹ φ) + +attribute [simp] IsNegative.falsum + +namespace IsNegative + +@[simp] +lemma and_iff {φ ψ : Semiformulaᵢ L ξ n} : (φ ⋏ ψ).IsNegative ↔ φ.IsNegative ∧ ψ.IsNegative := + ⟨by rintro ⟨⟩; simp_all, by rintro ⟨hφ, hψ⟩; exact .and hφ hψ⟩ + +@[simp] +lemma imp_iff {φ ψ : Semiformulaᵢ L ξ n} : (φ ⇒ₗ ψ).IsNegative ↔ ψ.IsNegative := + ⟨by rintro ⟨⟩; simp_all, by rintro h; exact .imply h⟩ + +@[simp] +lemma all_iff {φ : Semiformulaᵢ L ξ (n + 1)} : (∀¹ φ).IsNegative ↔ φ.IsNegative := + ⟨by rintro ⟨⟩; simp_all, by rintro h; exact .all h⟩ + +@[simp] +lemma verum : (⊤ : Semiformulaᵢ L ξ n).IsNegative := by simp [verum_def] + +@[simp] +lemma not_or {φ ψ : Semiformulaᵢ L ξ n} : ¬(φ ⋎ ψ).IsNegative := by rintro ⟨⟩ + +@[simp] +lemma not_exs {φ : Semiformulaᵢ L ξ (n + 1)} : ¬(∃¹ φ).IsNegative := by rintro ⟨⟩ + +@[simp] +lemma not_rel {k} (r : L.Rel k) (v : Fin k → Semiterm L ξ n) : ¬(rel r v).IsNegative := by + rintro ⟨⟩ + +@[simp] +lemma neg (φ : Semiformulaᵢ L ξ n) : (∼φ).IsNegative := + .imply .falsum + +end IsNegative + +end Semiformulaᵢ + +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Intuitionistic/Rew.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Intuitionistic/Rew.lean new file mode 100644 index 000000000..9ce4ebc9a --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Syntax/Intuitionistic/Rew.lean @@ -0,0 +1,149 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Syntax.Intuitionistic.Formula +public import LeanPool.PointwiseComposition.Foundation.Syntax.Predicate.Rew + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace FFL +namespace FirstOrder + +namespace Semiformulaᵢ + +/-- The rew Aux construction in `FFL.FirstOrder.Semiformulaᵢ`. -/ +def rewAux (ω : Rew L ξ₁ n₁ ξ₂ n₂) : Semiformulaᵢ L ξ₁ n₁ → Semiformulaᵢ L ξ₂ n₂ + | ⊥ => ⊥ + | rel r v => rel r (ω ∘ v) + | φ ⋏ ψ => rewAux ω φ ⋏ rewAux ω ψ + | φ ⋎ ψ => rewAux ω φ ⋎ rewAux ω ψ + | φ ⇒ₗ ψ => rewAux ω φ ⇒ₗ rewAux ω ψ + | ∀¹ φ => ∀¹ rewAux ω.q φ + | ∃¹ φ => ∃¹ rewAux ω.q φ + +/-- The rew construction in `FFL.FirstOrder.Semiformulaᵢ`. -/ +def rew (ω : Rew L ξ₁ n₁ ξ₂ n₂) : Semiformulaᵢ L ξ₁ n₁ →ˡᶜ Semiformulaᵢ L ξ₂ n₂ + where + toTr := rewAux ω + map_top' := rfl + map_bot' := rfl + map_neg' := by simp [Semiformulaᵢ.neg_def, rewAux] + map_and' := fun _ _ ↦ rfl + map_or' := fun _ _ ↦ rfl + map_imply' := fun _ _ ↦ rfl + +instance : Rewriting L ξ (Semiformulaᵢ L ξ) ζ (Semiformulaᵢ L ζ) + where + app := rew + app_all (_ _) := rfl + app_exs (_ _) := rfl + +instance : Coe (Semisentenceᵢ L n) (Semipropositionᵢ L n) := + ⟨Rewriting.emb (ξ := ℕ)⟩ + +lemma rew_rel (ω : Rew L ξ₁ n₁ ξ₂ n₂) {k} (r : L.Rel k) (v : Fin k → Semiterm L ξ₁ n₁) : + ω ▹ rel r v = rel r fun i ↦ ω (v i) := + rfl + +lemma rew_rel_eq_comp (ω : Rew L ξ₁ n₁ ξ₂ n₂) {k} {r : L.Rel k} {v : Fin k → Semiterm L ξ₁ n₁} : + ω ▹ rel r v = rel r (ω ∘ v) := + rfl + +private lemma map_inj {n₁ n₂} {b : Fin n₁ → Fin n₂} {f : ξ₁ → ξ₂} (hb : Function.Injective b) + (hf : Function.Injective f) : + Function.Injective fun φ : Semiformulaᵢ L ξ₁ n₁ ↦ @Rew.map L ξ₁ ξ₂ n₁ n₂ b f ▹ φ + | ⊥, φ => by cases φ using cases' <;> simp [rew_rel] + | rel r v, φ => by + cases φ using cases' <;> simp only [rew_rel, rel.injEq, and_imp, + LogicalConnective.HomClass.map_bot, reduceCtorEq, imp_self, + LogicalConnective.HomClass.map_and, LogicalConnective.HomClass.map_or, + LogicalConnective.HomClass.map_imply, Rewriting.app_all, Rewriting.app_exs] + case hRel => + rintro rfl; simp only [heq_eq_eq, true_and]; rintro rfl h; simp only [true_and] + funext i; exact Rew.map_inj hb hf (congr_fun h i) + | φ ⋏ ψ, χ => by + cases χ using cases' <;> simp only [LogicalConnective.HomClass.map_and, rew_rel, reduceCtorEq, + imp_self, LogicalConnective.HomClass.map_bot, and_inj, and_imp, + LogicalConnective.HomClass.map_or, LogicalConnective.HomClass.map_imply, Rewriting.app_all, + Rewriting.app_exs] + intro hp hq; exact ⟨map_inj hb hf hp, map_inj hb hf hq⟩ + | φ ⋎ ψ, χ => by + cases χ using cases' <;> simp only [LogicalConnective.HomClass.map_or, rew_rel, reduceCtorEq, + imp_self, LogicalConnective.HomClass.map_bot, LogicalConnective.HomClass.map_and, or_inj, + and_imp, LogicalConnective.HomClass.map_imply, Rewriting.app_all, Rewriting.app_exs] + intro hp hq; exact ⟨map_inj hb hf hp, map_inj hb hf hq⟩ + | φ ⇒ₗ ψ, χ => by + cases χ using cases' <;> simp only [LogicalConnective.HomClass.map_imply, rew_rel, + reduceCtorEq, imp_self, LogicalConnective.HomClass.map_bot, + LogicalConnective.HomClass.map_and, LogicalConnective.HomClass.map_or, imp_inj, and_imp, + Rewriting.app_all, Rewriting.app_exs] + intro hp hq; exact ⟨map_inj hb hf hp, map_inj hb hf hq⟩ + | ∀¹ φ, ψ => by + cases ψ using cases' <;> simp only [Rewriting.app_all, Rew.q_map, Nat.succ_eq_add_one, + rew_rel, reduceCtorEq, imp_self, LogicalConnective.HomClass.map_bot, + LogicalConnective.HomClass.map_and, LogicalConnective.HomClass.map_or, + LogicalConnective.HomClass.map_imply, all_inj, Rewriting.app_exs] + intro h; + exact + map_inj (b := 0 :> Fin.succ ∘ b) + (Matrix.injective_vecCons ((Fin.succ_injective _).comp hb) + (fun _ ↦ (Fin.succ_ne_zero _).symm)) + hf h + | ∃¹ φ, ψ => by + cases ψ using cases' <;> simp only [Rewriting.app_exs, Rew.q_map, Nat.succ_eq_add_one, + rew_rel, reduceCtorEq, imp_self, LogicalConnective.HomClass.map_bot, + LogicalConnective.HomClass.map_and, LogicalConnective.HomClass.map_or, + LogicalConnective.HomClass.map_imply, Rewriting.app_all, exs_inj] + intro h; + exact + map_inj (b := 0 :> Fin.succ ∘ b) + (Matrix.injective_vecCons ((Fin.succ_injective _).comp hb) + (fun _ ↦ (Fin.succ_ne_zero _).symm)) + hf h + +instance : ReflectiveRewriting L ξ (Semiformulaᵢ L ξ) where + id_app (φ) := by induction φ using rec' <;> simp [rew_rel, *] + +instance : + TransitiveRewriting L ξ₁ (Semiformulaᵢ L ξ₁) ξ₂ (Semiformulaᵢ L ξ₂) ξ₃ (Semiformulaᵢ L ξ₃) + where + comp_app + {n₁ n₂ n₃ ω₁₂ ω₂₃ + φ} := by + induction φ using rec' generalizing n₂ n₃ <;> simp [rew_rel, Rew.comp_app, Rew.q_comp, *] + +instance : InjMapRewriting L ξ (Semiformulaᵢ L ξ) ζ (Semiformulaᵢ L ζ) where + smul_map_injective := map_inj + +instance : LawfulSyntacticRewriting L (Semipropositionᵢ L) where + +@[simp] +lemma complexity_rew (ω : Rew L ξ₁ n₁ ξ₂ n₂) (φ : Semiformulaᵢ L ξ₁ n₁) : + (ω ▹ φ).complexity = φ.complexity := by + induction φ using rec' generalizing n₂ <;> simp [*, rew_rel] + +@[simp] +lemma IsNegative.rew {ω : Rew L ξ₁ n₁ ξ₂ n₂} {φ : Semiformulaᵢ L ξ₁ n₁} : + (ω ▹ φ).IsNegative ↔ φ.IsNegative := by + induction φ using rec' generalizing n₂ <;> simp [rew_rel, *] + +end Semiformulaᵢ + +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Tarski/AesopInit.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Tarski/AesopInit.lean new file mode 100644 index 000000000..d52f2660b --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Tarski/AesopInit.lean @@ -0,0 +1,21 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public meta import Aesop +import Aesop.Frontend.Command + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +declare_aesop_rule_sets [Definability] + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Tarski/Basic.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Tarski/Basic.lean new file mode 100644 index 000000000..6b792a63f --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Tarski/Basic.lean @@ -0,0 +1,871 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Syntax.Classical.Rew +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Fin.Basic +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.IsEmpty +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Empty + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +/-! +# Model-theoretic semantics of first-order classical logic + +This file defines the structure and the evaluation of terms and formulas by Tarski's truth +definition. +-/ + +namespace FFL + +namespace FirstOrder + +variable {L : Language.{u}} + +/-- +A first-order `L`-structure associates domain `M` with interpretations of function and relation +symbols. -/ +@[ext] +class Tarski.Structure (L : Language.{u}) (M : Type w) where + /-- The func construction in `FFL.FirstOrder.Tarski.Structure`. -/ + func : ⦃k : ℕ⦄ → L.Func k → (Fin k → M) → M + /-- The rel construction in `FFL.FirstOrder.Tarski.Structure`. -/ + rel : ⦃k : ℕ⦄ → L.Rel k → (Fin k → M) → Prop + +/-- +An auxiliary structure that corresponds to a first-order `L`-structure with a nonempty domain. -/ +structure Tarski.Struc (L : Language) where + /-- The Dom construction in `FFL.FirstOrder.Tarski.Struc`. -/ + Dom : Type* + nonempty : Nonempty Dom + /-- The struc construction in `FFL.FirstOrder.Tarski.Struc`. -/ + struc : Tarski.Structure L Dom + +/-- The Small Struc construction in `FFL.FirstOrder.Tarski`. -/ +abbrev Tarski.SmallStruc (L : Language.{u}) := + Tarski.Struc.{u, u} L + +instance : CoeSort (Tarski.Struc L) (Type _) := + ⟨Tarski.Struc.Dom⟩ + +namespace Tarski +namespace Structure + +instance [n : Nonempty M] : Nonempty (Tarski.Structure L M) := + by + rcases n with ⟨x⟩ + exact ⟨{ func := fun _ _ _ ↦ x, rel := fun _ _ _ ↦ True }⟩ + +instance unit : Tarski.Structure L Unit + where + func := fun _ _ _ ↦ () + rel := fun _ _ _ ↦ True + +/-- The l Map construction in `FFL.FirstOrder.Tarski.Structure`. -/ +protected abbrev lMap (φ : L₁ →ᵥ L₂) {M : Type w} (S : Tarski.Structure L₂ M) : + Tarski.Structure L₁ M where + func _ f := S.func (φ.func f) + rel _ r := S.rel (φ.rel r) + +variable (φ : L₁ →ᵥ L₂) {M : Type w} (s₂ : Tarski.Structure L₂ M) + +@[simp] +lemma lMap_func {k} {f : L₁.Func k} {v : Fin k → M} : + (s₂.lMap φ).func f v = s₂.func (φ.func f) v := + rfl + +@[simp] +lemma lMap_rel {k} {r : L₁.Rel k} {v : Fin k → M} : (s₂.lMap φ).rel r v ↔ s₂.rel (φ.rel r) v := + of_eq rfl + +/-- The of Equiv construction in `FFL.FirstOrder.Tarski.Structure`. -/ +abbrev ofEquiv {M : Type w} [Tarski.Structure L M] {N : Type w'} (Θ : M ≃ N) : + Tarski.Structure L N + where + func := fun _ f v ↦ Θ (func f (Θ.symm ∘ v)) + rel := fun _ r v ↦ rel r (Θ.symm ∘ v) + +/-- The Decidable construction in `FFL.FirstOrder.Tarski.Structure`. -/ +protected abbrev Decidable (L : Language.{u}) (M : Type w) [s : Tarski.Structure L M] := + {k : ℕ} → (r : L.Rel k) → (v : Fin k → M) → Decidable (s.rel r v) + +noncomputable instance [Tarski.Structure L M] : Tarski.Structure.Decidable L M := fun r v => + Classical.dec (rel r v) + +/-- The to Struc construction in `FFL.FirstOrder.Tarski.Structure`. -/ +@[reducible] +def toStruc [i : Nonempty M] (s : Tarski.Structure L M) : Tarski.Struc L := + ⟨M, i, s⟩ + +end Structure +end Tarski + +namespace Tarski +namespace Struc + +instance (s : Tarski.Struc L) : Nonempty s.Dom := + s.nonempty + +instance (s : Tarski.Struc L) : Tarski.Structure L s.Dom := + s.struc + +end Struc +end Tarski + +namespace Semiterm + +variable {M : Type w} {s : Tarski.Structure L M} {b : Fin n → M} {b₁ : Fin n₁ → M} + {b₂ : Fin n₂ → M} {f : ξ → M} {f₁ : ξ₁ → M} {f₂ : ξ₂ → M} + +/-- The val construction in `FFL.FirstOrder.Semiterm`. -/ +def val [s : Tarski.Structure L M] (b : Fin n → M) (f : ξ → M) : Semiterm L ξ n → M + | #x => b x + | &x => f x + | func F v => s.func F fun i ↦ (v i).val b f + +/-- The valb construction in `FFL.FirstOrder.Semiterm`. -/ +abbrev valb [s : Tarski.Structure L M] (b : Fin n → M) (t : ClosedSemiterm L n) : M := + t.val b Empty.elim + +/-- The valf construction in `FFL.FirstOrder.Semiterm`. -/ +abbrev valf [s : Tarski.Structure L M] {n} (b : Fin n → M) : Semiterm L Empty n → M := + val b Empty.elim + +@[simp] +lemma val_bvar (x) : val b f (#x : Semiterm L ξ n) = b x := + rfl + +@[simp] +lemma val_fvar (x) : val b f (&x : Semiterm L ξ n) = f x := + rfl + +@[simp] +lemma val_func {k} (F : L.Func k) (v) : (func F v).val b f = s.func F (Semiterm.val b f ∘ v) := + rfl + +lemma val_func' {k} (F : L.Func k) (v) : + (func F v).val b f = s.func F fun i ↦ Semiterm.val b f (v i) := + rfl + +lemma val_rew (ω : Rew L ξ₁ n₁ ξ₂ n₂) (t : Semiterm L ξ₁ n₁) : + (ω t).val b₂ f₂ = t.val (val b₂ f₂ ∘ ω ∘ bvar) (val b₂ f₂ ∘ ω ∘ fvar) := by + induction t <;> simp [*, -val_func, val_func'] + +lemma val_rewrite (f : ξ₁ → Semiterm L ξ₂ n) (t : Semiterm L ξ₁ n) : + (Rew.rewrite f t).val b f₂ = t.val b (val b f₂ ∘ f) := by simp [val_rew]; congr + +lemma val_rewriteMap (f : ξ₁ → ξ₂) (t : Semiterm L ξ₁ n) : + (Rew.rewriteMap f t).val b f₂ = t.val b (f₂ ∘ f) := by simp [val_rew]; congr + +lemma val_substs (w : Fin n₁ → Semiterm L ξ n₂) (t : Semiterm L ξ n₁) : + (Rew.subst w t).val b₂ f = t.val (val b₂ f ∘ w) f := by simp [val_rew]; congr + +@[simp] +lemma val_bShift (a : M) (t : Semiterm L ξ n) : (Rew.bShift t).val (a :> b) f = t.val b f := by + simp [val_rew, Function.comp_def] + +lemma val_bShift' (b : Fin (n + 1) → M) (t : Semiterm L ξ n) : + (Rew.bShift t).val b f = t.val (b ·.succ) f := by simp [val_rew, Function.comp_def] + +@[simp] +lemma val_emb {o : Type v'} [i : IsEmpty o] (t : Semiterm L o n) : + (Rew.emb t : Semiterm L ξ n).val b f = t.val b i.elim := by + simp only [val_rew]; congr; + funext x; exact i.elim' x + +@[simp] +lemma val_castLE (h : n₁ ≤ n₂) (t : Semiterm L ξ n₁) : + (Rew.castLE h t).val b₂ f = t.val (fun x ↦ b₂ (x.castLE h)) f := by simp [val_rew]; congr + +lemma val_embSubsts (w : Fin k → Semiterm L ξ n) (t : Semiterm L Empty k) : + (Rew.embSubsts w t).val b f = t.valb (val b f ∘ w) := by + simp [val_rew, Empty.eq_elim]; + congr + +section Language + +variable (φ : L₁ →ᵥ L₂) (b : Fin n → M) (f : ξ → M) + +lemma val_lMap (φ : L₁ →ᵥ L₂) (s₂ : Tarski.Structure L₂ M) (b : Fin n → M) (f : ξ → M) + {t : Semiterm L₁ ξ n} : (t.lMap φ).val (s := s₂) b f = t.val (s := s₂.lMap φ) b f := by + induction t <;> simp [*, val_func, Semiterm.lMap_func, Function.comp_def] + +end Language + +section Syntactic + +variable (f : ℕ → M) + +lemma val_shift (t : SyntacticSemiterm L n) : (Rew.shift t).val b f = t.val b (f ∘ Nat.succ) := + by simp [val_rew]; congr + +lemma val_free (a : M) (t : SyntacticSemiterm L (n + 1)) : + (Rew.free t).val b (a :>ₙ f) = t.val (b <: a) f := + by + simp only [val_rew] + congr; exact funext <| Fin.lastCases (by simp) (by simp) + +lemma val_fix (a : M) (t : SyntacticSemiterm L n) : + (Rew.fix t).val (b <: a) f = t.val b (a :>ₙ f) := + by + simp only [val_rew]; congr + · simp [Function.comp_def] + · simpa [Function.comp_def] using funext (Nat.cases (by simp) (by simp)) + +end Syntactic + +lemma val_eq_of_funEqOn [DecidableEq ξ] (t : Semiterm L ξ n) + (h : Function.funEqOn t.HasFreeVariable f f') : t.val b f = t.val b f' := + by + induction t + case bvar => simp + case fvar x => exact h x (by simp [HasFreeVariable]) + case func k f v ih => + simp only [val_func, Function.comp_def] + congr; funext i; exact ih i (by intro x hx; exact h x (by simpa using ⟨i, hx⟩)) + +lemma val_toEmpty [DecidableEq ξ] (t : Semiterm L ξ n) (h : t.freeVariables = ∅) : + t.val b f = (t.toEmpty h).valb b := by + induction t + case bvar => simp [Semiterm.toEmpty] + case fvar => simp at h + case func k f v ih => + simp only [val_func] + have : ∀ i, (v i).freeVariables = ∅ := by + simpa [Semiterm.freeVariables_func, Finset.biUnion_eq_empty] using h + congr 1; funext i + exact ih i (this i) + +end Semiterm + +namespace Tarski +namespace Structure + +section + +variable [s : Tarski.Structure L M] (Θ : M ≃ N) + +lemma ofEquiv_func (f : L.Func k) (v : Fin k → N) : + (ofEquiv Θ).func f v = Θ (func f (Θ.symm ∘ v)) := + rfl + +lemma ofEquiv_val (b : Fin n → N) (f : ξ → N) (t : Semiterm L ξ n) : + t.val (s := ofEquiv Θ) b f = Θ (t.val (Θ.symm ∘ b) (Θ.symm ∘ f)) := by + induction t <;> simp [*, Semiterm.val_func, ofEquiv_func Θ, Function.comp_def] + +end + +end Structure +end Tarski + +namespace Semiformula + +variable {M : Type w} {s : Tarski.Structure L M} + +variable {n : ℕ} {b : Fin n → M} {b₂ : Fin n₂ → M} {f : ξ → M} {f₂ : ξ₂ → M} + +/-- The Eval Aux construction in `FFL.FirstOrder.Semiformula`. -/ +def EvalAux (s : Tarski.Structure L M) (f : ξ → M) {n} (b : Fin n → M) : + Semiformula L ξ n → Prop + | rel φ v => s.rel φ (fun i ↦ Semiterm.val b f (v i)) + | nrel φ v => ¬s.rel φ (fun i ↦ Semiterm.val b f (v i)) + | ⊤ => True + | ⊥ => False + | φ ⋏ ψ => φ.EvalAux s f b ∧ ψ.EvalAux s f b + | φ ⋎ ψ => φ.EvalAux s f b ∨ ψ.EvalAux s f b + | ∀¹ φ => ∀ x : M, (φ.EvalAux s f (x :> b)) + | ∃¹ φ => ∃ x : M, (φ.EvalAux s f (x :> b)) + +@[simp] +lemma EvalAux_neg (φ : Semiformula L ξ n) : EvalAux s f b (∼φ) = ¬EvalAux s f b φ := by + induction φ using rec' <;> simp [*, EvalAux, or_iff_not_imp_left] + +/-- Evaluation of semiformula with variation of free-variables `f` and bounded-variables `b` -/ +def Eval [s : Tarski.Structure L M] (b : Fin n → M) (f : ξ → M) : Semiformula L ξ n →ˡᶜ Prop + where + toTr := EvalAux s f b + map_top' := rfl + map_bot' := rfl + map_and' := by simp [EvalAux] + map_or' := by simp [EvalAux] + map_neg' := by simp [EvalAux_neg] + map_imply' := by simp [EvalAux_neg, ← neg_eq, EvalAux, imp_iff_not_or] + +/-- The Evalf construction in `FFL.FirstOrder.Semiformula`. -/ +abbrev Evalf [s : Tarski.Structure L M] (f : ξ → M) : Formula L ξ →ˡᶜ Prop := + Eval (s := s) ![] f + +/-- The Evalb construction in `FFL.FirstOrder.Semiformula`. -/ +abbrev Evalb [s : Tarski.Structure L M] (b : Fin n → M) : Semiformula L Empty n →ˡᶜ Prop := + Eval b Empty.elim + +/-- The «term ⊧/ » construction in `FFL.FirstOrder.Semiformula`. -/ +notation:max M:90 " ⊧/" e:max => @Evalb _ M _ _ e + +/-- The Realize construction in `FFL.FirstOrder.Semiformula`. -/ +abbrev Realize (M : Type*) [s : Tarski.Structure L M] : Sentence L →ˡᶜ Prop := + Eval (s := s) ![] Empty.elim + +/-- The Models construction in `FFL.FirstOrder.Semiformula`. -/ +abbrev Models (s : Tarski.Structure L M) : Formula L M →ˡᶜ Prop := + Eval ![] id + +lemma Eval.of_eq {b e' : Fin n → M} {f f' : ξ → M} {φ : Semiformula L ξ n} (h : Eval b f φ) + (he : b = e') (hf : f = f') : Eval e' f' φ := + he ▸ hf ▸ h + +@[simp] +lemma eval_rel {r : L.Rel k} {v} : Eval b f (rel r v) ↔ s.rel r (Semiterm.val b f ∘ v) := + of_eq rfl + +lemma eval_rel' {r : L.Rel k} {v} : Eval b f (rel r v) ↔ s.rel r fun i ↦ (v i).val b f := + of_eq rfl + +@[simp] +lemma eval_nrel {r : L.Rel k} {v} : Eval b f (nrel r v) ↔ ¬s.rel r (Semiterm.val b f ∘ v) := + of_eq rfl + +lemma eval_nrel' {r : L.Rel k} {v} : Eval b f (nrel r v) ↔ ¬s.rel r fun i ↦ (v i).val b f := + of_eq rfl + +@[simp] +lemma eval_all {φ : Semiformula L ξ (n + 1)} : Eval b f (∀¹ φ) ↔ ∀ x : M, Eval (x :> b) f φ := + of_eq rfl + +@[simp] +lemma eval_ex {φ : Semiformula L ξ (n + 1)} : Eval b f (∃¹ φ) ↔ ∃ x : M, Eval (x :> b) f φ := + of_eq rfl + +@[simp] +lemma eval_ball {φ ψ : Semiformula L ξ (n + 1)} : + Eval b f (∀¹[φ] ψ) ↔ ∀ x : M, Eval (x :> b) f φ → Eval (x :> b) f ψ := by simp [ball] + +@[simp] +lemma eval_bexs {φ ψ : Semiformula L ξ (n + 1)} : + Eval b f (∃¹[φ] ψ) ↔ ∃ x : M, Eval (x :> b) f φ ⋏ Eval (x :> b) f ψ := by simp [bexs] + +@[simp] +lemma eval_allClosure {b} {φ : Semiformula L ξ k} : Eval b f (∀¹* φ) ↔ ∀ e', Eval e' f φ := + match k with + | 0 => by simp [eq_finZeroElim] + | k + 1 => by + simpa [allClosure_succ, eval_allClosure (k := k), Matrix.vecForall_iff] using forall_comm + +@[simp] +lemma eval_exsClosure {b} {φ : Semiformula L ξ k} : Eval b f (∃¹* φ) ↔ ∃ e', Eval e' f φ := + match k with + | 0 => by simp [eq_finZeroElim] + | k + 1 => by + simpa [exsClosure_succ, eval_exsClosure (k := k), Matrix.vecExists_iff] using exists_comm + +@[simp] +lemma eval_allItr {b} {φ : Semiformula L ξ (n + k)} : + Eval b f (∀¹^[k] φ) ↔ ∀ e', Eval (Matrix.appendr e' b) f φ := + match k with + | 0 => by simp [Matrix.empty_eq] + | k + 1 => by + simpa [allItr_succ, eval_allItr (k := k), Matrix.vecForall_iff] using forall_comm + +@[simp] +lemma eval_exsItr {b} {φ : Semiformula L ξ (n + k)} : + Eval b f (∃¹^[k] φ) ↔ ∃ e', Eval (Matrix.appendr e' b) f φ := + match k with + | 0 => by simp [Matrix.empty_eq] + | k + 1 => by + simpa [exsItr_succ, eval_exsItr (k := k), Matrix.vecExists_iff] using exists_comm + +section rew + +variable {f : ξ → M} {f₂ : ξ₂ → M} + +lemma eval_rew {n₁ n₂ b₂ f₂} (ω : Rew L ξ₁ n₁ ξ₂ n₂) (φ : Semiformula L ξ₁ n₁) : + Eval b₂ f₂ (ω ▹ φ) ↔ + Eval (Semiterm.val (s := s) b₂ f₂ ∘ ω ∘ Semiterm.bvar) + (Semiterm.val (s := s) b₂ f₂ ∘ ω ∘ Semiterm.fvar) φ := + by + match φ with + | .rel r v | + .nrel r v => + simp only [rew_rel_eq_comp, eval_rel, eval_nrel]; apply iff_of_eq + congr; funext i + simp [Semiterm.val_rew] + | ⊤ | ⊥ => simp + | φ ⋏ ψ | φ ⋎ ψ => simp [eval_rew ω φ, eval_rew ω ψ] + | ∀¹ φ => + simpa [Function.comp_def, eval_rew ω.q φ] using + iff_of_eq <| forall_congr fun x ↦ by congr; funext i; cases i using Fin.cases <;> simp + | ∃¹ φ => + simpa [Function.comp_def, eval_rew ω.q φ] using + exists_congr fun x ↦ iff_of_eq <| by congr; funext i; cases i using Fin.cases <;> simp + +lemma eval_rew_q {f₂ : ξ₂ → M} (ω : Rew L ξ₁ n₁ ξ₂ n₂) (φ : Semiformula L ξ₁ (n₁ + 1)) : + Eval (x :> b₂) f₂ (ω.q ▹ φ) ↔ + Eval (x :> Semiterm.val b₂ f₂ ∘ ω ∘ Semiterm.bvar) + (Semiterm.val b₂ f₂ ∘ ω ∘ Semiterm.fvar) φ := + by + simp only [Nat.succ_eq_add_one, eval_rew, Function.comp_def, Rew.q_fvar, Semiterm.val_bShift] + apply iff_of_eq; congr 2 + · funext x + cases x using Fin.cases <;> simp + +lemma eval_map (θ : Fin n₁ → Fin n₂) (η : ξ₁ → ξ₂) (b : Fin n₂ → M) (f : ξ₂ → M) + (φ : Semiformula L ξ₁ n₁) : + Eval b f ((Rew.map (L := L) θ η) ▹ φ) ↔ Eval (b ∘ θ) (f ∘ η) φ := by + simp [eval_rew, Function.comp_def] + +lemma eval_rewrite (f : ξ₁ → Semiterm L ξ₂ n) (φ : Semiformula L ξ₁ n) : + Eval b f₂ (Rew.rewrite f ▹ φ) ↔ Eval b (fun x ↦ (f x).val b f₂) φ := by + simp [eval_rew, Function.comp_def] + +lemma eval_rewriteMap (f : ξ₁ → ξ₂) (φ : Semiformula L ξ₁ n) : + Eval b f₂ (Rew.rewriteMap (L := L) (n := n) f ▹ φ) ↔ Eval b (fun x ↦ f₂ (f x)) φ := by + simp [eval_rew, Function.comp_def] + +@[simp] +lemma eval_castLE (h : n₁ ≤ n₂) (φ : Semiformula L ξ n₁) : + Eval b₂ f (@Rew.castLE L ξ _ _ h ▹ φ) ↔ Eval (fun x ↦ b₂ (x.castLE h)) f φ := by + simp [eval_rew, Function.comp_def] + +@[simp] +lemma eval_bShift (φ : Semiformula L ξ n) : + Eval (x :> b) f (@Rew.bShift L ξ n ▹ φ) ↔ Eval b f φ := by + simp [eval_rew, Function.comp_def] + +lemma eval_bShift' (φ : Semiformula L ξ n) : + Eval e' f (@Rew.bShift L ξ n ▹ φ) ↔ Eval (e' ·.succ) f φ := by + simp [eval_rew, Function.comp_def] + +@[simp] +lemma eval_substs {k} (w : Fin k → Semiterm L ξ n) (φ : Semiformula L ξ k) : + Eval b f (φ ↜ w) ↔ φ.Eval (Semiterm.val b f ∘ w) f := by simp [eval_rew, Function.comp_def] + +lemma eval_insert1 {n} (φ : Semiformula L ξ (n + 1)) (u w : M) (e : Fin n → M) : + Eval (u :> w :> e) f (φ ↜ (#0 :> (#·.succ.succ))) ↔ Eval (u :> e) f φ := + by + simp only [eval_substs] + exact + Iff.of_eq + (congrArg (fun c => Eval c f φ) (funext fun i => by induction i using Fin.cases <;> simp)) + +lemma eval_insert2 {n} (φ : Semiformula L ξ (n + 2)) (u x w : M) (e : Fin n → M) : + Eval (u :> x :> w :> e) f (φ ↜ (#0 :> #1 :> (#·.succ.succ.succ))) ↔ + Eval (u :> x :> e) f φ := + by + simp only [eval_substs, Function.comp_def] + exact + Iff.of_eq + (congrArg (fun c => Eval c f φ) (Fin.funext_two (by simp) (by simp) fun i => by simp)) + +@[simp] +lemma eval_emb {f : ξ → M} (φ : Semiformula L Empty n) : + Eval b f (Rewriting.emb (ξ := ξ) φ : Semiformula L ξ n) ↔ Eval b Empty.elim φ := by + simp [eval_rew, Function.comp_def, Empty.eq_elim] + +@[simp] +lemma eval_empty [h : IsEmpty o] (φ : Formula L o) : + Eval b f (@Rew.empty L o _ ξ n ▹ φ) ↔ Eval (s := s) ![] h.elim φ := + by + simp [eval_rew, Function.comp_def, Matrix.empty_eq] + simp [IsEmpty.eq_elim] + +@[simp] +lemma eval_embSubsts {ξ} {f : ξ → M} {k} (w : Fin k → Semiterm L ξ n) (σ : Semisentence L k) : + Eval b f ((@Rew.embSubsts L ξ n k w) ▹ σ) ↔ M ⊧/(Semiterm.val b f ∘ w) σ := by + simp [eval_rew, Function.comp_def, Empty.eq_elim] + +section Syntactic + +variable (f : ℕ → M) + +@[simp] +lemma eval_free (φ : Semiproposition L (n + 1)) : + Eval b (a :>ₙ f) (@Rew.free L n ▹ φ) ↔ Eval (b <: a) f φ := + by + simp only [eval_rew, Function.comp_def, Rew.free_fvar, Semiterm.val_fvar, Nat.cases_succ, + Nat.succ_eq_add_one] + apply iff_of_eq; congr; funext x; cases x using Fin.lastCases <;> simp + +@[simp] +lemma eval_shift (φ : Semiproposition L n) : + Eval b (a :>ₙ f) (@Rew.shift L n ▹ φ) ↔ Eval b f φ := by simp [eval_rew, Function.comp_def] + +end Syntactic + +lemma eval_iff_of_funEqOn [DecidableEq ξ] {n b} (φ : Semiformula L ξ n) + (h : Function.funEqOn φ.HasFreeVariable f f') : Eval b f φ ↔ Eval b f' φ := by + match φ with + | .rel r v => + simp only [eval_rel]; apply iff_of_eq; congr 1 + funext i + exact Semiterm.val_eq_of_funEqOn (v i) (fun x hx ↦ h x (hasFreeVariable_rel.mpr ⟨i, hx⟩)) + | .nrel r v => + simp only [eval_nrel]; apply iff_of_eq; congr 2 + funext i + exact Semiterm.val_eq_of_funEqOn (v i) (fun x hx ↦ h x (hasFreeVariable_nrel.mpr ⟨i, hx⟩)) + | ⊤ | ⊥ => simp + | φ ⋏ ψ => + suffices Eval b f φ ∧ Eval b f ψ ↔ Eval b f' φ ∧ Eval b f' ψ by simpa + apply and_congr + · exact eval_iff_of_funEqOn φ fun x hx ↦ h x (by simp [hx]) + · exact eval_iff_of_funEqOn ψ fun x hx ↦ h x (by simp [hx]) + | φ ⋎ ψ => + suffices Eval b f φ ∨ Eval b f ψ ↔ Eval b f' φ ∨ Eval b f' ψ by simpa + apply or_congr + · exact eval_iff_of_funEqOn φ fun x hx ↦ h x (by simp [hx]) + · exact eval_iff_of_funEqOn ψ fun x hx ↦ h x (by simp [hx]) + | ∀¹ φ => + suffices (∀ x, Eval (x :> b) f φ) ↔ (∀ x, Eval (x :> b) f' φ) by simpa + apply forall_congr'; intro x + exact eval_iff_of_funEqOn φ fun x hx ↦ h _ (by simpa [HasFreeVariable]) + | ∃¹ φ => + suffices (∃ x, Eval (x :> b) f φ) ↔ (∃ x, Eval (x :> b) f' φ) by simpa + apply exists_congr; intro x + exact eval_iff_of_funEqOn φ fun x hx ↦ h _ (by simpa [HasFreeVariable]) + +lemma eval_toEmpty [DecidableEq ξ] {n} {φ : Semiformula L ξ n} (hp : φ.freeVariables = ∅) {b} : + Eval b f φ ↔ Evalb b (φ.toEmpty hp) := by + match φ with + | .rel r v => + simp only [eval_rel] + apply iff_of_eq; congr 2; funext i + simpa [Semiterm.val_toEmpty] using Semiterm.val_toEmpty _ ?_ + | .nrel r v => + apply iff_of_eq; congr; funext i + rw [Semiterm.val_toEmpty] + | ⊤ | ⊥ => simp + | φ ⋏ ψ | φ ⋎ ψ => + simp [eval_toEmpty (φ := φ) (by simp [by simpa [Finset.union_eq_empty] using hp]), + eval_toEmpty (φ := ψ) (by simp [by simpa [Finset.union_eq_empty] using hp])] + | + ∀¹ + φ => + have : ∀ x, Eval (x :> b) f φ ↔ Evalb (x :> b) (φ.toEmpty hp) := fun x ↦ + eval_toEmpty (φ := φ) (b := (x :> b)) (by simpa using hp) + simp [this] + | + ∃¹ + φ => + have : ∀ x, Eval (x :> b) f φ ↔ Evalb (x :> b) (φ.toEmpty hp) := fun x ↦ + eval_toEmpty (φ := φ) (b := (x :> b)) (by simpa using hp) + simp [this] + +@[simp] +lemma eval_univCl' {f : ℕ → M} (φ : Proposition L) : + Evalf f φ.univCl' ↔ ∀ g : ℕ → M, Evalf g φ := + by + simp only [univCl', eval_allClosure, eval_rew, Matrix.empty_eq, Function.comp_def] + constructor + · intro h g + refine (eval_iff_of_funEqOn φ ?_).mp (h (fun x ↦ g x)) + intro x hx; simp [Rew.fixitr_fvar, lt_fvSup_of_hasFreeVariable hx] + · intro h g + refine + (eval_iff_of_funEqOn φ ?_).mp + (h (fun x ↦ if hx : x < φ.fvSup then g ⟨x, by simp [hx]⟩ else f 0)) + intro x hx; simp [Rew.fixitr_fvar, lt_fvSup_of_hasFreeVariable hx] + +@[simp] +lemma eval_univCl [Nonempty M] (φ : Proposition L) : + Realize M φ.univCl ↔ ∀ f : ℕ → M, Evalf f φ := + by + have : Inhabited M := Classical.inhabited_of_nonempty inferInstance + simp [Semiformula.univCl, ← eval_toEmpty (f := default)] + +@[simp] +lemma eval_enumerateFVar_idxOfFVar_eq_id [DecidableEq M] [Inhabited M] (φ : Semiformula L M n) + (v) : φ.Eval v (fun x ↦ φ.enumerateFVar (φ.idxOfFVar x)) ↔ φ.Eval v id := + Semiformula.eval_iff_of_funEqOn _ <| by + intro x hx + simp [Semiformula.enumerateFVar_idxOfFVar + (Semiformula.mem_fvarList_iff_hasFreeVariable.mpr hx)] + +end rew + +end Semiformula + +namespace Tarski +namespace Structure + +section + +open Semiformula + +variable [s : Tarski.Structure L M] (Θ : M ≃ N) + +lemma ofEquiv_rel (r : L.Rel k) (v : Fin k → N) : + (Tarski.Structure.ofEquiv Θ).rel r v ↔ Tarski.Structure.rel r (Θ.symm ∘ v) := + iff_of_eq rfl + +lemma eval_ofEquiv_iff {b : Fin n → N} {f : ξ → N} {φ : Semiformula L ξ n} : + Eval (s := ofEquiv Θ) b f φ ↔ Eval (Θ.symm ∘ b) (Θ.symm ∘ f) φ := + match φ with + | .rel r v | .nrel r v => by + simp [Function.comp_def, ofEquiv_rel Θ, Tarski.Structure.ofEquiv_val Θ] + | ⊤ | ⊥ => by simp + | φ ⋏ ψ | φ ⋎ ψ => by simp [eval_ofEquiv_iff (φ := φ), eval_ofEquiv_iff (φ := ψ)] + | ∀¹ φ => by + constructor + · intro h x + have h' := eval_ofEquiv_iff.mp (h (Θ x)) + simp only [Matrix.comp_vecCons'', Equiv.symm_apply_apply] at h' + exact h' + · intro h x + apply eval_ofEquiv_iff.mpr + change EvalAux s (Θ.symm ∘ f) (Θ.symm ∘ (x :> b)) φ + simpa only [Matrix.comp_vecCons''] using h (Θ.symm x) + | ∃¹ φ => by + constructor + · rintro ⟨x, h⟩ + refine ⟨Θ.symm x, ?_⟩ + have h' := eval_ofEquiv_iff.mp h + change EvalAux s (Θ.symm ∘ f) (Θ.symm ∘ (x :> b)) φ at h' + simpa only [Matrix.comp_vecCons''] using h' + · rintro ⟨x, h⟩ + refine ⟨Θ x, eval_ofEquiv_iff.mpr ?_⟩ + change EvalAux s (Θ.symm ∘ f) (Θ.symm ∘ (Θ x :> b)) φ + simpa only [Matrix.comp_vecCons'', Equiv.symm_apply_apply] using h + +lemma evalf_ofEquiv_iff {f : ξ → N} {φ : Formula L ξ} : + Evalf (s := ofEquiv Θ) f φ ↔ Evalf (s := s) (Θ.symm ∘ f) φ := by + simpa using eval_ofEquiv_iff (Θ := Θ) (f := f) (φ := φ) (b := ![]) + +end + +end Structure +end Tarski + +instance : Semantics (Tarski.Struc L) (Sentence L) where + Models := fun str ↦ Semiformula.Realize str.Dom + +instance : Semantics.Tarski (Tarski.Struc L) + where + models_verum := by simp [Semantics.Models] + models_falsum := by simp [Semantics.Models] + models_and := by simp [Semantics.Models] + models_or := by simp [Semantics.Models] + models_imply := by simp [Semantics.Models] + models_not := by simp [Semantics.Models] + +section + +variable (M : Type*) [Nonempty M] [s : Tarski.Structure L M] {T U : Theory L} + +/-- Standard structure inferred from a given domain -/ +abbrev Language.str (M : Type*) [Nonempty M] (L : Language) [s : Tarski.Structure L M] : + Tarski.Struc L := + s.toStruc + +/-- The «term ↓[ ]» construction in `FFL.FirstOrder`. -/ +notation:max M "↓[" L "]" => Language.str M L + +/-- The Consequence construction in `FFL.FirstOrder`. -/ +abbrev Consequence (T : Theory L) (σ : Sentence L) : Prop := + T ⊨[Tarski.SmallStruc L] σ + +/-- Semantic entailment, also known as logical consequence. -/ +scoped infix:45 " ⊨ " => Consequence + +/-- The Satisfiable construction in `FFL.FirstOrder`. -/ +abbrev Satisfiable (T : Theory L) : Prop := + Semantics.Satisfiable (Tarski.SmallStruc L) T + +variable {M} + +lemma struc_models_iff_models {s : Tarski.Struc L} : s ⊧ σ ↔ s.Dom↓[L] ⊧ σ := by rfl + +lemma models_iff : M↓[L] ⊧ σ ↔ σ.Realize M := by rfl + +lemma notModels_iff : M↓[L] ⊭ σ ↔ ¬σ.Realize M := by rfl + +lemma models_iff_proposition {φ : Proposition L} : M↓[L] ⊧ φ.univCl ↔ ∀ f : ℕ → M, φ.Evalf f := + by simp [models_iff] + +lemma models_theory_iff : M↓[L] ⊧* T ↔ ∀ φ ∈ T, M↓[L] ⊧ φ := + Semantics.modelsSet_iff + +lemma models_of_mem {T : Theory L} [M↓[L] ⊧* T] {φ} (h : φ ∈ T) : M↓[L] ⊧ φ := + Semantics.ModelsSet.models _ h + +variable (M T) + +lemma Theory.models [M↓[L] ⊧* T] {σ} (hσ : σ ∈ T) : M↓[L] ⊧ σ := + Semantics.modelsSet_iff.mp inferInstance hσ + +variable {M T} + +lemma models_iff_models {φ} : M↓[L] ⊧ φ ↔ s.toStruc ⊧ φ := + of_eq rfl + +lemma consequence_iff {φ} : + T ⊨[Tarski.Struc.{v, u} L] φ ↔ + (∀ (M : Type v) [Nonempty M] [Tarski.Structure L M], M↓[L] ⊧* T → M↓[L] ⊧ φ) := + ⟨fun h _ _ _ hT ↦ h hT, fun h s hT ↦ h s.Dom hT⟩ + +lemma consequence_iff' {φ} : + T ⊨[Tarski.Struc.{v, u} L] φ ↔ + (∀ (M : Type v) [Nonempty M] [Tarski.Structure L M] [M↓[L] ⊧* T], M↓[L] ⊧ φ) := + ⟨fun h _ _ s _ ↦ Semantics.consequence_iff'.mp h s.toStruc, fun h s hs ↦ + @h s.Dom s.nonempty s.struc hs⟩ + +lemma valid_iff {φ} : + Semantics.Valid (Tarski.Struc.{v, u} L) φ ↔ + ∀ (M : Type v) [Nonempty M] [Tarski.Structure L M], M↓[L] ⊧ φ := + ⟨fun hσ _ _ s ↦ @hσ s.toStruc, fun h s ↦ h s.Dom⟩ + +lemma satisfiable_iff : + Semantics.Satisfiable (Tarski.Struc.{v, u} L) T ↔ + ∃ (M : Type v) (_ : Nonempty M) (_ : Tarski.Structure L M), M↓[L] ⊧* T := + by + constructor + · rintro ⟨s, hs⟩ + exact ⟨s.Dom, s.nonempty, s.struc, hs⟩ + · rintro ⟨M, i, s, hT⟩ + exact ⟨s.toStruc, hT⟩ + +lemma unsatisfiable_iff : + ¬Semantics.Satisfiable (Tarski.Struc.{v, u} L) T ↔ + ∀ (M : Type v) (_ : Nonempty M) (_ : Tarski.Structure L M), ¬M↓[L] ⊧* T := + by simpa using satisfiable_iff.not + +lemma satisfiable_intro (M : Type v) [Nonempty M] [s : Tarski.Structure L M] (h : M↓[L] ⊧* T) : + Semantics.Satisfiable (Tarski.Struc.{v, u} L) T := + ⟨s.toStruc, h⟩ + +/-- The Model Of Sat construction in `FFL.FirstOrder`. -/ +noncomputable def ModelOfSat (h : Semantics.Satisfiable (Tarski.Struc.{v, u} L) T) : Type v := + Classical.choose (satisfiable_iff.mp h) + +noncomputable instance nonemptyModelOfSat + (h : Semantics.Satisfiable (Tarski.Struc.{v, u} L) T) : Nonempty (ModelOfSat h) := by + choose i _ _ using Classical.choose_spec (satisfiable_iff.mp h); exact i + +/-- The Structure Model Of Sat Aux construction in `FFL.FirstOrder`. -/ +noncomputable def StructureModelOfSatAux (h : Semantics.Satisfiable (Tarski.Struc.{v, u} L) T) : + { _s : Tarski.Structure L (ModelOfSat h) // (ModelOfSat h)↓[L] ⊧* T } := + by + choose _ s h using Classical.choose_spec (satisfiable_iff.mp h) + exact ⟨s, h⟩ + +noncomputable instance StructureModelOfSat + (h : Semantics.Satisfiable (Tarski.Struc.{v, u} L) T) : Tarski.Structure L (ModelOfSat h) := + StructureModelOfSatAux h + +lemma ModelOfSat.models (h : Semantics.Satisfiable (Tarski.Struc.{v, u} L) T) : + (ModelOfSat h)↓[L] ⊧* T := + (StructureModelOfSatAux h).prop + +lemma consequence_iff_unsatisfiable {σ : Sentence L} : + T ⊨[Tarski.Struc.{v, u} L] σ ↔ + ¬Semantics.Satisfiable (Tarski.Struc.{v, u} L) (insert (∼σ) T) := + by + constructor + · intro h + apply unsatisfiable_iff.mpr + intro M _ s; simp only [Semantics.ModelsSet.insert_iff, models_iff, not_and'] + intro hT; simpa using models_iff.mp (h hT) + · intro h; apply consequence_iff.mpr + intro M _ s hT + have : σ.Realize M := + by + have := by + simpa only [Semantics.ModelsSet.insert_iff, not_and', models_iff] using + unsatisfiable_iff.mp h M inferInstance s + simpa using this hT + apply models_iff.mpr (by simpa using this) + +end + +namespace Semiformula + +variable {L₁ L₂ : Language} {Φ : L₁ →ᵥ L₂} + +section lMap + +variable {M : Type u} {s₂ : Tarski.Structure L₂ M} {n} {b : Fin n → M} {f : ξ → M} + +lemma eval_lMap {φ : Semiformula L₁ ξ n} : + Eval (s := s₂) b f (lMap Φ φ) ↔ Eval (s := s₂.lMap Φ) b f φ := by + induction φ using rec' <;> + simp [*, Semiterm.val_lMap, lMap_rel, lMap_nrel, eval_rel, eval_nrel, Function.comp_def] + +lemma models_lMap [Nonempty M] {σ : Sentence L₁} : + s₂.toStruc ⊧ lMap Φ σ ↔ (s₂.lMap Φ).toStruc ⊧ σ := by simp [Semantics.Models, eval_lMap] + +end lMap + +end Semiformula + +lemma lMap_models_lMap {L₁ L₂ : Language.{u}} {Φ : L₁ →ᵥ L₂} {T : Theory L₁} {σ : Sentence L₁} + (h : T ⊨[Tarski.Struc.{v, u} L₁] σ) : + T.lMap Φ ⊨[Tarski.Struc.{v, u} L₂] Semiformula.lMap Φ σ := + by + intro s hM + have : (s.struc.lMap Φ).toStruc ⊧ σ := + h ⟨fun _ hq ↦ Semiformula.models_lMap.mp <| hM.models _ (Set.mem_image_of_mem _ hq)⟩ + exact Semiformula.models_lMap.mpr this + +section theory + +variable (M) [Nonempty M] [Tarski.Structure L M] + +variable {M} + +lemma models_of_ss {T U : Theory L} (h : M↓[L] ⊧* U) (ss : T ⊆ U) : M↓[L] ⊧* T := + Semantics.ModelsSet.of_subset h ss + +lemma models_of_le {T₁ T₂ : Theory L} (h : M↓[L] ⊧* T₂) (le : T₁ ⊆ T₂) : M↓[L] ⊧* T₁ := + Semantics.ModelsSet.of_subset h le + +instance models_theory_sup (T₁ T₂ : Theory L) [M↓[L] ⊧* T₁] [M↓[L] ⊧* T₂] : M↓[L] ⊧* T₁ ∪ T₂ := + by + simp only [Semantics.ModelsSet.union_iff] + constructor + · infer_instance + · infer_instance + +lemma models_of_mem_theory {T : Theory L} [h : M↓[L] ⊧* T] (hf : φ ∈ T) : M↓[L] ⊧ φ := + h.models _ hf + +end theory + +namespace Tarski +namespace Structure + +variable (L) + +/-- The theory construction in `FFL.FirstOrder.Tarski.Structure`. -/ +abbrev theory (M : Type*) [Nonempty M] [s : Tarski.Structure L M] : Theory L := + Semantics.theory s.toStruc + +variable {L} {M : Type v} [Nonempty M] [s : Tarski.Structure L M] + +@[simp] +lemma mem_theory_iff {σ} : σ ∈ theory L M ↔ M↓[L] ⊧ σ := by rfl + +lemma subset_of_models : T ⊆ theory L M ↔ M↓[L] ⊧* T := + ⟨fun h ↦ ⟨fun _ hσ ↦ h hσ⟩, fun h _ hσ ↦ h.models_set hσ⟩ + +lemma theory_satisfiable : Semantics.Satisfiable (Tarski.Struc.{v} L) (theory L M) := + ⟨s.toStruc, by simp⟩ + +end Structure +end Tarski + +end FirstOrder + +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Tarski/Definability.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Tarski/Definability.lean new file mode 100644 index 000000000..f13006a8e --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Tarski/Definability.lean @@ -0,0 +1,670 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Tarski.Elementary +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Syntax.Classical.BinderNotation +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Tarski.AesopInit +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Finset.Card +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Graph + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +/-! +# Relations and functions defined by a first-order formula (with parameter) +-/ + +namespace FFL +namespace FirstOrder + +variable {L : Language} {M : Type*} [Tarski.Structure L M] + +/-- The Is Defined By construction in `FFL.FirstOrder`. -/ +abbrev IsDefinedBy (R : (Fin k → M) → Prop) (φ : Semisentence L k) : Prop := + ∀ v, φ.Evalb v ↔ R v + +/-- Data and laws for Defined in `FFL.FirstOrder`. -/ +class Defined (R : outParam ((Fin k → M) → Prop)) (φ : Semisentence L k) : Prop where + iff : IsDefinedBy R φ + +/-- The relation `R` is definable by a formula `φ` with parameters over the domain `M`. +Here, the free variables of `φ` are indexed by the type `M`, so that `φ` may contain finitely +many parameters, which are interpreted by using `id : M → M` for the valuation of free +variables. +-/ +abbrev IsDefinedByWithParam (R : (Fin k → M) → Prop) (φ : Semiformula L M k) : Prop := + ∀ v, φ.Eval v id ↔ R v + +@[simp] +lemma Defined.eval_iff {R : (Fin k → M) → Prop} {φ : Semisentence L k} [h : Defined R φ] (v) : + φ.Evalb v ↔ R v := + h.iff v + +lemma IsDefinedByWithParam.iff {R : (Fin k → M) → Prop} {φ : Semiformula L M k} + (h : IsDefinedByWithParam R φ) (v) : φ.Eval v id ↔ R v := + h v + +/-- The Defined Function construction in `FFL.FirstOrder`. -/ +abbrev DefinedFunction (f : (Fin k → M) → M) (φ : Semisentence L (k + 1)) : Prop := + Defined (fun v ↦ v 0 = f (v ·.succ)) φ + +/-- The Defined Pred construction in `FFL.FirstOrder`. -/ +abbrev DefinedPred (P : M → Prop) (φ : Semisentence L 1) : Prop := + Defined (fun v ↦ P (v 0)) φ + +/-- The Defined Rel construction in `FFL.FirstOrder`. -/ +abbrev DefinedRel (R : M → M → Prop) (φ : Semisentence L 2) : Prop := + Defined (fun v ↦ R (v 0) (v 1)) φ + +/-- The Defined Rel₃ construction in `FFL.FirstOrder`. -/ +abbrev DefinedRel₃ (R : M → M → M → Prop) (φ : Semisentence L 3) : Prop := + Defined (fun v ↦ R (v 0) (v 1) (v 2)) φ + +/-- The Defined Rel₄ construction in `FFL.FirstOrder`. -/ +abbrev DefinedRel₄ (R : M → M → M → M → Prop) (φ : Semisentence L 4) : Prop := + Defined (fun v ↦ R (v 0) (v 1) (v 2) (v 3)) φ + +/-- The Defined Function₀ construction in `FFL.FirstOrder`. -/ +abbrev DefinedFunction₀ (c : M) (φ : Semisentence L 1) : Prop := + DefinedFunction (fun _ => c) φ + +/-- The Defined Function₁ construction in `FFL.FirstOrder`. -/ +abbrev DefinedFunction₁ (f : M → M) (φ : Semisentence L 2) : Prop := + DefinedFunction (fun v ↦ f (v 0)) φ + +/-- The Defined Function₂ construction in `FFL.FirstOrder`. -/ +abbrev DefinedFunction₂ (f : M → M → M) (φ : Semisentence L 3) : Prop := + DefinedFunction (fun v ↦ f (v 0) (v 1)) φ + +/-- The Defined Function₃ construction in `FFL.FirstOrder`. -/ +abbrev DefinedFunction₃ (f : M → M → M → M) (φ : Semisentence L 4) : Prop := + DefinedFunction (fun v ↦ f (v 0) (v 1) (v 2)) φ + +/-- The Defined Function₄ construction in `FFL.FirstOrder`. -/ +abbrev DefinedFunction₄ (f : M → M → M → M → M) (φ : Semisentence L 5) : Prop := + DefinedFunction (fun v ↦ f (v 0) (v 1) (v 2) (v 3)) φ + +/-- The Defined Function₅ construction in `FFL.FirstOrder`. -/ +abbrev DefinedFunction₅ (f : M → M → M → M → M → M) (φ : Semisentence L 6) : Prop := + DefinedFunction (fun v ↦ f (v 0) (v 1) (v 2) (v 3) (v 4)) φ + +/-- The «term -relation Via » construction in `FFL.FirstOrder`. -/ +notation K "-relation " P " via " φ => DefinedRel (L := K) P φ + +/-- The «term -relation₃ Via » construction in `FFL.FirstOrder`. -/ +notation K "-relation₃ " P " via " φ => DefinedRel₃ (L := K) P φ + +/-- The «term -relation₄ Via » construction in `FFL.FirstOrder`. -/ +notation K "-relation₄ " P " via " φ => DefinedRel₄ (L := K) P φ + +/-- The «term -function₀ Via » construction in `FFL.FirstOrder`. -/ +notation K "-function₀ " c " via " φ => DefinedFunction₀ (L := K) c φ + +/-- The «term -function₁ Via » construction in `FFL.FirstOrder`. -/ +notation K "-function₁ " f " via " φ => DefinedFunction₁ (L := K) f φ + +/-- The «term -function₂ Via » construction in `FFL.FirstOrder`. -/ +notation K "-function₂ " f " via " φ => DefinedFunction₂ (L := K) f φ + +/-- The «term -function₃ Via » construction in `FFL.FirstOrder`. -/ +notation K "-function₃ " f " via " φ => DefinedFunction₃ (L := K) f φ + +/-- The «term -function₄ Via » construction in `FFL.FirstOrder`. -/ +notation K "-function₄ " f " via " φ => DefinedFunction₄ (L := K) f φ + +/-- The «term -function₅ Via » construction in `FFL.FirstOrder`. -/ +notation K "-function₅ " f " via " φ => DefinedFunction₅ (L := K) f φ + +/-- The «term -predicate[ ] Via » construction in `FFL.FirstOrder`. -/ +notation K "-predicate[" N "] " P " via " φ => DefinedPred (L := K) (M := N) P φ + +/-- The «term -relation[ ] Via » construction in `FFL.FirstOrder`. -/ +notation K "-relation[" N "] " P " via " φ => DefinedRel (L := K) (M := N) P φ + +/-- The «term -relation₃[ ] Via » construction in `FFL.FirstOrder`. -/ +notation K "-relation₃[" N "] " P " via " φ => DefinedRel₃ (L := K) (M := N) P φ + +/-- The «term -relation₄[ ] Via » construction in `FFL.FirstOrder`. -/ +notation K "-relation₄[" N "] " P " via " φ => DefinedRel₄ (L := K) (M := N) P φ + +/-- The «term -function₀[ ] Via » construction in `FFL.FirstOrder`. -/ +notation K "-function₀[" N "] " c " via " φ => DefinedFunction₀ (L := K) (M := N) c φ + +/-- The «term -function₁[ ] Via » construction in `FFL.FirstOrder`. -/ +notation K "-function₁[" N "] " f " via " φ => DefinedFunction₁ (L := K) (M := N) f φ + +/-- The «term -function₂[ ] Via » construction in `FFL.FirstOrder`. -/ +notation K "-function₂[" N "] " f " via " φ => DefinedFunction₂ (L := K) (M := N) f φ + +/-- The «term -function₃[ ] Via » construction in `FFL.FirstOrder`. -/ +notation K "-function₃[" N "] " f " via " φ => DefinedFunction₃ (L := K) (M := N) f φ + +/-- The «term -function₄[ ] Via » construction in `FFL.FirstOrder`. -/ +notation K "-function₄[" N "] " f " via " φ => DefinedFunction₄ (L := K) (M := N) f φ + +/-- The «term -function₅[ ] Via » construction in `FFL.FirstOrder`. -/ +notation K "-function₅[" N "] " f " via " φ => DefinedFunction₅ (L := K) (M := N) f φ + +namespace Language + +variable (L) + +/-- Data and laws for Definable in `FFL.FirstOrder.Language`. -/ +class Definable {k} (P : (Fin k → M) → Prop) : Prop where + definable : ∃ φ : Semiformula L M k, IsDefinedByWithParam P φ + +/-- The Definable Pred construction in `FFL.FirstOrder.Language`. -/ +abbrev DefinablePred (P : M → Prop) : Prop := + L.Definable (k := 1) fun v ↦ P (v 0) + +/-- The Definable Rel construction in `FFL.FirstOrder.Language`. -/ +abbrev DefinableRel (P : M → M → Prop) : Prop := + L.Definable (k := 2) (fun v ↦ P (v 0) (v 1)) + +/-- The Definable Rel₃ construction in `FFL.FirstOrder.Language`. -/ +abbrev DefinableRel₃ (P : M → M → M → Prop) : Prop := + L.Definable (k := 3) (fun v ↦ P (v 0) (v 1) (v 2)) + +/-- The Definable Rel₄ construction in `FFL.FirstOrder.Language`. -/ +abbrev DefinableRel₄ (P : M → M → M → M → Prop) : Prop := + L.Definable (k := 4) (fun v ↦ P (v 0) (v 1) (v 2) (v 3)) + +/-- The Definable Rel₅ construction in `FFL.FirstOrder.Language`. -/ +abbrev DefinableRel₅ (P : M → M → M → M → M → Prop) : Prop := + L.Definable (k := 5) (fun v ↦ P (v 0) (v 1) (v 2) (v 3) (v 4)) + +/-- The Definable Rel₆ construction in `FFL.FirstOrder.Language`. -/ +abbrev DefinableRel₆ (P : M → M → M → M → M → M → Prop) : Prop := + L.Definable (k := 6) (fun v ↦ P (v 0) (v 1) (v 2) (v 3) (v 4) (v 5)) + +/-- The Definable Function construction in `FFL.FirstOrder.Language`. -/ +abbrev DefinableFunction (f : (Fin k → M) → M) : Prop := + Definable (k := k + 1) L fun v ↦ v 0 = f (v ·.succ) + +/-- The Definable Function₀ construction in `FFL.FirstOrder.Language`. -/ +abbrev DefinableFunction₀ (c : M) : Prop := + L.DefinableFunction (k := 0) (fun _ ↦ c) + +/-- The Definable Function₁ construction in `FFL.FirstOrder.Language`. -/ +abbrev DefinableFunction₁ (f : M → M) : Prop := + L.DefinableFunction (k := 1) (fun v ↦ f (v 0)) + +/-- The Definable Function₂ construction in `FFL.FirstOrder.Language`. -/ +abbrev DefinableFunction₂ (f : M → M → M) : Prop := + L.DefinableFunction (k := 2) (fun v ↦ f (v 0) (v 1)) + +/-- The Definable Function₃ construction in `FFL.FirstOrder.Language`. -/ +abbrev DefinableFunction₃ (f : M → M → M → M) : Prop := + L.DefinableFunction (k := 3) (fun v ↦ f (v 0) (v 1) (v 2)) + +/-- The Definable Function₄ construction in `FFL.FirstOrder.Language`. -/ +abbrev DefinableFunction₄ (f : M → M → M → M → M) : Prop := + L.DefinableFunction (k := 4) (fun v ↦ f (v 0) (v 1) (v 2) (v 3)) + +/-- The Definable Function₅ construction in `FFL.FirstOrder.Language`. -/ +abbrev DefinableFunction₅ (f : M → M → M → M → M → M) : Prop := + L.DefinableFunction (k := 5) (fun v ↦ f (v 0) (v 1) (v 2) (v 3) (v 4)) + +variable {L} + +/-- The «term -predicate » construction in `FFL.FirstOrder.Language`. -/ +notation L "-predicate " P => DefinablePred L P + +/-- The «term -relation » construction in `FFL.FirstOrder.Language`. -/ +notation L "-relation " P => DefinableRel L P + +/-- The «term -relation₃ » construction in `FFL.FirstOrder.Language`. -/ +notation L "-relation₃ " P => DefinableRel₃ L P + +/-- The «term -relation₄ » construction in `FFL.FirstOrder.Language`. -/ +notation L "-relation₄ " P => DefinableRel₄ L P + +/-- The «term -relation₅ » construction in `FFL.FirstOrder.Language`. -/ +notation L "-relation₅ " P => DefinableRel₅ L P + +/-- The «term -function₁ » construction in `FFL.FirstOrder.Language`. -/ +notation L "-function₁ " f => DefinableFunction₁ L f + +/-- The «term -function₂ » construction in `FFL.FirstOrder.Language`. -/ +notation L "-function₂ " f => DefinableFunction₂ L f + +/-- The «term -function₃ » construction in `FFL.FirstOrder.Language`. -/ +notation L "-function₃ " f => DefinableFunction₃ L f + +/-- The «term -function₄ » construction in `FFL.FirstOrder.Language`. -/ +notation L "-function₄ " f => DefinableFunction₄ L f + +/-- The «term -predicate[ ] » construction in `FFL.FirstOrder.Language`. -/ +notation L "-predicate[" N "] " P => DefinablePred (M := N) L P + +/-- The «term -relation[ ] » construction in `FFL.FirstOrder.Language`. -/ +notation L "-relation[" N "] " P => DefinableRel (M := N) L P + +/-- The «term -relation₃[ ] » construction in `FFL.FirstOrder.Language`. -/ +notation L "-relation₃[" N "] " P => DefinableRel₃ (M := N) L P + +/-- The «term -relation₄[ ] » construction in `FFL.FirstOrder.Language`. -/ +notation L "-relation₄[" N "] " P => DefinableRel₄ (M := N) L P + +/-- The «term -relation₅[ ] » construction in `FFL.FirstOrder.Language`. -/ +notation L "-relation₅[" N "] " P => DefinableRel₅ (M := N) L P + +/-- The «term -function₁[ ] » construction in `FFL.FirstOrder.Language`. -/ +notation L "-function₁[" N "] " f => DefinableFunction₁ (M := N) L f + +/-- The «term -function₂[ ] » construction in `FFL.FirstOrder.Language`. -/ +notation L "-function₂[" N "] " f => DefinableFunction₂ (M := N) L f + +/-- The «term -function₃[ ] » construction in `FFL.FirstOrder.Language`. -/ +notation L "-function₃[" N "] " f => DefinableFunction₃ (M := N) L f + +/-- The «term -function₄[ ] » construction in `FFL.FirstOrder.Language`. -/ +notation L "-function₄[" N "] " f => DefinableFunction₄ (M := N) L f + +end Language + +namespace IsDefinedBy + +lemma of_vec_one {R : (Fin 1 → M) → Prop} {φ : Semisentence L 1} + (h : ∀ x, φ.Evalb ![x] ↔ R ![x]) : IsDefinedBy R φ := by + intro v; + simpa [← Matrix.fun_eq_vec_one] using h (v 0) + +lemma of_vec_two {R : (Fin 2 → M) → Prop} {φ : Semisentence L 2} + (h : ∀ x y, φ.Evalb ![x, y] ↔ R ![x, y]) : IsDefinedBy R φ := by + intro v; + simpa [← Matrix.fun_eq_vec_two] using h (v 0) (v 1) + +lemma of_vec_three {R : (Fin 3 → M) → Prop} {φ : Semisentence L 3} + (h : ∀ x y z, φ.Evalb ![x, y, z] ↔ R ![x, y, z]) : IsDefinedBy R φ := by + intro v; + simpa [← Matrix.fun_eq_vec_three] using h (v 0) (v 1) (v 2) + +end IsDefinedBy + +namespace Defined + +lemma to_definable {R : (Fin k → M) → Prop} {φ : Semisentence L k} (hR : Defined R φ) : + L.Definable R := + ⟨Rewriting.emb φ, fun v ↦ by simp [Semiformula.eval_emb]⟩ + +end Defined + +namespace DefinedFunction + +lemma to_definable {f : (Fin k → M) → M} {φ : Semisentence L (k + 1)} + (hf : DefinedFunction f φ) : L.DefinableFunction f := + Defined.to_definable hf + +end DefinedFunction + +namespace Language + +namespace Definable + +variable {P Q R : (Fin k → M) → Prop} + +lemma of_iff {P Q : (Fin k → M) → Prop} (H : L.Definable Q) (h : ∀ x, P x ↔ Q x) : + L.Definable P := by rwa [show P = Q from by funext v; simp [h]] + +@[simp] +lemma const (p : Prop) : L.Definable fun _ : Fin k → M ↦ p := + by + by_cases hp : p + · exact ⟨⊤, by intro _; simp [hp]⟩ + · exact ⟨⊥, by intro _; simp [hp]⟩ + +@[grind .] +lemma and {R S : (Fin k → M) → Prop} (hR : L.Definable R) (hS : L.Definable S) : + L.Definable fun v : Fin k → M ↦ R v ∧ S v := + by + rcases hR with ⟨φ, hR⟩ + rcases hS with ⟨ψ, hS⟩ + exact ⟨φ ⋏ ψ, by intro _; simp [hR.iff, hS.iff]⟩ + +@[grind .] +lemma or {R S : (Fin k → M) → Prop} (hR : L.Definable R) (hS : L.Definable S) : + L.Definable fun v : Fin k → M ↦ R v ∨ S v := + by + rcases hR with ⟨φ, hR⟩ + rcases hS with ⟨ψ, hS⟩ + exact ⟨φ ⋎ ψ, by intro _; simp [hR.iff, hS.iff]⟩ + +@[grind .] +lemma imp {R S : (Fin k → M) → Prop} (hR : L.Definable R) (hS : L.Definable S) : + L.Definable fun v : Fin k → M ↦ R v → S v := + by + rcases hR with ⟨φ, hR⟩ + rcases hS with ⟨ψ, hS⟩ + exact ⟨φ ⇒ₗ ψ, by intro _; simp [hR.iff, hS.iff]⟩ + +@[grind .] +lemma not {R : (Fin k → M) → Prop} (hR : L.Definable R) : + L.Definable fun v : Fin k → M ↦ ¬R v := + by + rcases hR with ⟨φ, hR⟩ + exact ⟨∼φ, by intro _; simp [hR.iff]⟩ + +@[grind .] +lemma biconditional {R S : (Fin k → M) → Prop} (hR : L.Definable R) (hS : L.Definable S) : + L.Definable fun v : Fin k → M ↦ R v ↔ S v := + by + rcases hR with ⟨φ, hR⟩ + rcases hS with ⟨ψ, hS⟩ + exact ⟨φ ⇔ₗ ψ, by intro _; simp [hR.iff, hS.iff]⟩ + +lemma all {R : (Fin k → M) → M → Prop} (hR : L.Definable fun w ↦ R (w ·.succ) (w 0)) : + L.Definable fun v : Fin k → M ↦ ∀ x, R v x := + by + rcases hR with ⟨φ, hR⟩ + exact ⟨∀¹ φ, fun v ↦ by simp [hR.iff]⟩ + +lemma exs {R : (Fin k → M) → M → Prop} (hR : L.Definable fun w ↦ R (w ·.succ) (w 0)) : + L.Definable fun v : Fin k → M ↦ ∃ x, R v x := + by + rcases hR with ⟨φ, hR⟩ + exact ⟨∃¹ φ, fun v ↦ by simp [hR.iff]⟩ + +instance eq [L.Eq] [Tarski.Structure.Eq L M] : L-relation[M] Eq := + ⟨“x y. x = y”, fun _ ↦ by simp⟩ + +instance lt [L.LT] [LT M] [Tarski.Structure.LT L M] : L-relation[M] _root_.LT.lt := + ⟨“x y. x < y”, fun _ ↦ by simp⟩ + +instance mem [L.Mem] [Membership M M] [Tarski.Structure.Mem L M] : + L-relation[M] Membership.mem := + ⟨“x y. y ∈ x”, fun _ ↦ by simp⟩ + +lemma fconj {P : ι → (Fin k → M) → Prop} (s : Finset ι) + (h : ∀ i, L.Definable fun w : Fin k → M ↦ P i w) : + L.Definable fun v : Fin k → M ↦ ∀ i ∈ s, P i v := + by + have : ∀ i, ∃ φ, IsDefinedByWithParam (P i) φ := fun i ↦ (h i).definable + rcases Classical.axiomOfChoice this with ⟨φ, H⟩ + exact ⟨⋀ i ∈ s, φ i, fun v ↦ by simp [fun i ↦ (H i).iff]⟩ + +lemma fdisj {P : ι → (Fin k → M) → Prop} (s : Finset ι) + (h : ∀ i, L.Definable fun w : Fin k → M ↦ P i w) : + L.Definable fun v : Fin k → M ↦ ∃ i ∈ s, P i v := + by + have : ∀ i, ∃ φ, IsDefinedByWithParam (P i) φ := fun i ↦ (h i).definable + rcases Classical.axiomOfChoice this with ⟨φ, H⟩ + exact ⟨⋁ i ∈ s, φ i, fun v ↦ by simp [fun i ↦ (H i).iff]⟩ + +lemma fintype_all {ι : Type*} [_root_.Finite ι] {P : ι → (Fin k → M) → Prop} + (h : ∀ i, L.Definable fun w : Fin k → M ↦ P i w) : + L.Definable fun v : Fin k → M ↦ ∀ i, P i v := by + classical + let : Fintype ι := Fintype.ofFinite ι + simpa using fconj Finset.univ h + +lemma fintype_exs {ι : Type*} [_root_.Finite ι] {P : ι → (Fin k → M) → Prop} + (h : ∀ i, L.Definable fun w : Fin k → M ↦ P i w) : + L.Definable fun v : Fin k → M ↦ ∃ i, P i v := by + classical + let : Fintype ι := Fintype.ofFinite ι + simpa using fdisj Finset.univ h + +lemma retraction (h : L.Definable P) {n} (f : Fin k → Fin n) : + L.Definable fun v ↦ P (fun i ↦ v (f i)) := + by + rcases h with ⟨φ, hφ⟩ + exact ⟨(Rew.subst fun i ↦ #(f i)) ▹ φ, fun v ↦ by simp [← hφ.iff, Function.comp_def]⟩ + +lemma exsVec {k l} {P : (Fin k → M) → (Fin l → M) → Prop} + (h : + L.Definable fun w : Fin (k + l) → M ↦ + P (fun i ↦ w (i.castAdd l)) (fun j ↦ w (j.natAdd k))) : + L.Definable fun v : Fin k → M ↦ ∃ ys : Fin l → M, P v ys := + by + induction l generalizing k + case zero => simpa [Matrix.empty_eq] using h + case succ l + ih => + suffices L.Definable fun v : Fin k → M ↦ ∃ y, ∃ ys : Fin l → M, P v (y :> ys) + by + apply of_iff this; intro x + constructor + · rintro ⟨ys, h⟩; exact ⟨ys 0, (ys ·.succ), by simpa using h⟩ + · rintro ⟨y, ys, h⟩; exact ⟨_, h⟩ + apply exs; apply ih + let g : Fin (k + (l + 1)) → Fin (k + 1 + l) := + Matrix.vecAppend rfl (fun x ↦ x.succ.castAdd l) + (Fin.castAdd l 0 :> fun j ↦ j.natAdd (k + 1)) + exact + of_iff (retraction h g) + (by + intro v; simp only [g] + apply iff_of_eq; congr + · ext i; congr 1; ext; simp [Matrix.vecAppend_eq_ite] + · ext i + refine Fin.cases ?_ (fun i => ?_) i + · simp only [Matrix.cons_val_zero]; congr 1; ext; simp [Matrix.vecAppend_eq_ite] + · simp only [Matrix.cons_val_succ]; congr 1; ext; simp [Matrix.vecAppend_eq_ite]) + +lemma allVec {k l} {P : (Fin k → M) → (Fin l → M) → Prop} + (h : + L.Definable fun w : Fin (k + l) → M ↦ + P (fun i ↦ w (i.castAdd l)) (fun j ↦ w (j.natAdd k))) : + L.Definable fun v : Fin k → M ↦ ∀ ys : Fin l → M, P v ys := + by + induction l generalizing k + case zero => simpa [Matrix.empty_eq] using h + case succ l + ih => + suffices L.Definable fun v : Fin k → M ↦ ∀ y, ∀ ys : Fin l → M, P v (y :> ys) + by + apply of_iff this; intro x + constructor + · intro h y ys; apply h + · intro h ys; simpa using h (ys 0) (ys ·.succ) + apply all; apply ih + let g : Fin (k + (l + 1)) → Fin (k + 1 + l) := + Matrix.vecAppend rfl (fun x ↦ x.succ.castAdd l) + (Fin.castAdd l 0 :> fun j ↦ j.natAdd (k + 1)) + exact + of_iff (retraction h g) + (by + intro v; simp only [g] + apply iff_of_eq; congr + · ext i; congr 1; ext; simp [Matrix.vecAppend_eq_ite] + · ext i + refine Fin.cases ?_ (fun i => ?_) i + · simp only [Matrix.cons_val_zero]; congr 1; ext; simp [Matrix.vecAppend_eq_ite] + · simp only [Matrix.cons_val_succ]; congr 1; ext; simp [Matrix.vecAppend_eq_ite]) + +lemma substitution {P : (Fin k → M) → Prop} {f : Fin k → (Fin l → M) → M} (hP : L.Definable P) + (hf : ∀ i, L.DefinableFunction (f i)) : L.Definable fun z ↦ P (f · z) := + by + have : L.Definable fun z ↦ ∃ ys : Fin k → M, (∀ i, ys i = f i z) ∧ P ys := + by + apply exsVec; apply and + · apply fintype_all; intro i + simpa using retraction (hf i) (i.natAdd l :> fun i ↦ i.castAdd k) + · exact retraction hP (Fin.natAdd l) + exact + of_iff this <| by + intro v + constructor + · intro hP + exact ⟨(f · v), by simp, hP⟩ + · rintro ⟨ys, hys, hP⟩ + have : ys = fun i ↦ f i v := funext hys + rcases this; exact hP + +end Definable + +lemma DefinablePred.comp {P : M → Prop} {k} {f : (Fin k → M) → M} [hP : L.DefinablePred P] + (hf : L.DefinableFunction f) : L.Definable (fun v ↦ P (f v)) := + Definable.substitution (f := ![f]) hP (by simpa using hf) + +lemma DefinableRel.comp {P : M → M → Prop} {k} {f g : (Fin k → M) → M} [hP : L.DefinableRel P] + (hf : L.DefinableFunction f) (hg : L.DefinableFunction g) : + L.Definable fun v ↦ P (f v) (g v) := + Definable.substitution (f := ![f, g]) hP + (by simp [Fin.forall_fin_iff_zero_and_forall_succ, hf, hg]) + +lemma DefinableRel₃.comp {k} {P : M → M → M → Prop} {f₁ f₂ f₃ : (Fin k → M) → M} + [hP : L.DefinableRel₃ P] (hf₁ : L.DefinableFunction f₁) (hf₂ : L.DefinableFunction f₂) + (hf₃ : L.DefinableFunction f₃) : L.Definable (fun v ↦ P (f₁ v) (f₂ v) (f₃ v)) := + Definable.substitution (f := ![f₁, f₂, f₃]) hP + (by simp [Fin.forall_fin_iff_zero_and_forall_succ, hf₁, hf₂, hf₃]) + +lemma DefinableRel₄.comp {k} {P : M → M → M → M → Prop} {f₁ f₂ f₃ f₄ : (Fin k → M) → M} + [hP : L.DefinableRel₄ P] (hf₁ : L.DefinableFunction f₁) (hf₂ : L.DefinableFunction f₂) + (hf₃ : L.DefinableFunction f₃) (hf₄ : L.DefinableFunction f₄) : + L.Definable (fun v ↦ P (f₁ v) (f₂ v) (f₃ v) (f₄ v)) := + Definable.substitution (f := ![f₁, f₂, f₃, f₄]) hP + (by simp [Fin.forall_fin_iff_zero_and_forall_succ, hf₁, hf₂, hf₃, hf₄]) + +lemma DefinableRel₅.comp {k} {P : M → M → M → M → M → Prop} {f₁ f₂ f₃ f₄ f₅ : (Fin k → M) → M} + [hP : L.DefinableRel₅ P] (hf₁ : L.DefinableFunction f₁) (hf₂ : L.DefinableFunction f₂) + (hf₃ : L.DefinableFunction f₃) (hf₄ : L.DefinableFunction f₄) + (hf₅ : L.DefinableFunction f₅) : + L.Definable (fun v ↦ P (f₁ v) (f₂ v) (f₃ v) (f₄ v) (f₅ v)) := + Definable.substitution (f := ![f₁, f₂, f₃, f₄, f₅]) hP + (by simp [Fin.forall_fin_iff_zero_and_forall_succ, hf₁, hf₂, hf₃, hf₄, hf₅]) + +lemma DefinablePred.of_iff {P Q : M → Prop} (H : L.DefinablePred Q) (h : ∀ x, P x ↔ Q x) : + L.DefinablePred P := by rwa [show P = Q from by funext v; simp [h]] + +instance DefinableFunction₁.graph {f : M → M} [h : L.DefinableFunction₁ f] : + L.DefinableRel (Function.Graph f) := + h + +instance DefinableFunction₂.graph {f : M → M → M} [h : L.DefinableFunction₂ f] : + L.DefinableRel₃ (Function.Graph₂ f) := + h + +instance DefinableFunction₃.graph {f : M → M → M → M} [h : L.DefinableFunction₃ f] : + L.DefinableRel₄ (Function.Graph₃ f) := + h + +/-! +### Definable functions +-/ + +variable [L.Eq] [Tarski.Structure.Eq L M] + +namespace DefinableFunction + +instance projection (i : Fin k) : L.DefinableFunction fun w : Fin k → M ↦ w i := + ⟨“x. x = #i.succ”, fun _ ↦ by simp⟩ + +instance const (c : M) : L.DefinableFunction fun _ : Fin k → M ↦ c := + ⟨“x. x = &c”, fun _ ↦ by simp⟩ + +lemma substitution {f : Fin k → (Fin l → M) → M} (hF : L.DefinableFunction F) + (hf : ∀ i, L.DefinableFunction (f i)) : L.DefinableFunction fun z ↦ F (fun i ↦ f i z) := by + simpa using + Definable.substitution (f := (· 0) :> fun i w ↦ f i (w ·.succ)) hF <| + by + intro i + refine Fin.cases ?_ (fun i => ?_) i + · simpa using projection _ + · simpa using Definable.retraction (hf i) (0 :> (·.succ.succ)) + +instance hAdd [L.Add] [Add M] [Tarski.Structure.Add L M] : L-function₂[M] HAdd.hAdd := + ⟨“x y z. x = y + z”, fun _ ↦ by simp⟩ + +instance hMul [L.Mul] [Mul M] [Tarski.Structure.Mul L M] : L-function₂[M] HMul.hMul := + ⟨“x y z. x = y * z”, fun _ ↦ by simp⟩ + +end DefinableFunction + +lemma DefinableFunction₁.comp {k} {F : M → M} {f : (Fin k → M) → M} + [hF : L.DefinableFunction₁ F] (hf : L.DefinableFunction f) : + L.DefinableFunction (fun v ↦ F (f v)) := + DefinableFunction.substitution (f := ![f]) hF (by simp [hf]) + +lemma DefinableFunction₂.comp {k} {F : M → M → M} {f₁ f₂ : (Fin k → M) → M} + [hF : L.DefinableFunction₂ F] (hf₁ : L.DefinableFunction f₁) + (hf₂ : L.DefinableFunction f₂) : L.DefinableFunction (fun v ↦ F (f₁ v) (f₂ v)) := + DefinableFunction.substitution (f := ![f₁, f₂]) hF + (by simp [Fin.forall_fin_iff_zero_and_forall_succ, *]) + +lemma DefinableFunction₃.comp {k} {F : M → M → M → M} {f₁ f₂ f₃ : (Fin k → M) → M} + [hF : L.DefinableFunction₃ F] (hf₁ : L.DefinableFunction f₁) (hf₂ : L.DefinableFunction f₂) + (hf₃ : L.DefinableFunction f₃) : L.DefinableFunction (fun v ↦ F (f₁ v) (f₂ v) (f₃ v)) := + DefinableFunction.substitution (f := ![f₁, f₂, f₃]) hF + (by simp [Fin.forall_fin_iff_zero_and_forall_succ, *]) + +lemma DefinableFunction₄.comp {k} {F : M → M → M → M → M} {f₁ f₂ f₃ f₄ : (Fin k → M) → M} + [hF : L.DefinableFunction₄ F] (hf₁ : L.DefinableFunction f₁) (hf₂ : L.DefinableFunction f₂) + (hf₃ : L.DefinableFunction f₃) (hf₄ : L.DefinableFunction f₄) : + L.DefinableFunction (fun v ↦ F (f₁ v) (f₂ v) (f₃ v) (f₄ v)) := + DefinableFunction.substitution (f := ![f₁, f₂, f₃, f₄]) hF + (by simp [Fin.forall_fin_iff_zero_and_forall_succ, *]) + +lemma DefinableFunction₅.comp {k} {F : M → M → M → M → M → M} {f₁ f₂ f₃ f₄ f₅ : (Fin k → M) → M} + [hF : L.DefinableFunction₅ F] (hf₁ : L.DefinableFunction f₁) (hf₂ : L.DefinableFunction f₂) + (hf₃ : L.DefinableFunction f₃) (hf₄ : L.DefinableFunction f₄) + (hf₅ : L.DefinableFunction f₅) : + L.DefinableFunction (fun v ↦ F (f₁ v) (f₂ v) (f₃ v) (f₄ v) (f₅ v)) := + DefinableFunction.substitution (f := ![f₁, f₂, f₃, f₄, f₅]) hF + (by simp [Fin.forall_fin_iff_zero_and_forall_succ, *]) + +section aesop + +open Lean.Parser.Tactic (config) + +attribute [aesop (rule_sets := [Definability]) norm] Function.comp_def + +attribute [aesop 4 (rule_sets := [Definability]) safe] DefinableFunction.const + DefinableFunction.projection Definable.const + +attribute [aesop 5 (rule_sets := [Definability]) safe] DefinableFunction₁.comp + DefinableFunction₂.comp DefinableFunction₃.comp + +attribute [aesop 6 (rule_sets := [Definability]) safe] DefinablePred.comp DefinableRel.comp + DefinableRel₃.comp DefinableRel₄.comp + +attribute [aesop 10 (rule_sets := [Definability]) safe] Definable.not Definable.imp + Definable.biconditional + +attribute [aesop 11 (rule_sets := [Definability]) safe] Definable.and Definable.or Definable.all + Definable.exs + +/-- The attr Definability construction in `FFL.FirstOrder.Language`. -/ +macro "definability" : attr => + `(attr|aesop 10 (rule_sets := [$(Lean.mkIdent `Definability):ident]) safe) + + + + + + + +/-- The tactic Definability construction in `FFL.FirstOrder.Language`. -/ +macro "definability" (config)? : tactic => + `(tactic| + aesop (config := { terminal := true }) + (rule_sets := [$(Lean.mkIdent `Definability):ident])) + +/-- The tactic Definability? construction in `FFL.FirstOrder.Language`. -/ +macro "definability?" (config)? : tactic => + `(tactic| + aesop? (config := { terminal := true }) + (rule_sets := [$(Lean.mkIdent `Definability):ident])) + +end aesop + +end Language + +end FirstOrder +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Tarski/Elementary.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Tarski/Elementary.lean new file mode 100644 index 000000000..139c54ba3 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Tarski/Elementary.lean @@ -0,0 +1,383 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Tarski.Basic + +/-! Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace FFL +namespace FirstOrder + +section + +variable {L : Language} +variable {M : Type*} {M₁ : Type*} {M₂ : Type*} {M₃ : Type*} +variable [Nonempty M] [Nonempty M₁] [Nonempty M₂] [Nonempty M₃] [s : Tarski.Structure L M] + [s₁ : Tarski.Structure L M₁] [s₂ : Tarski.Structure L M₂] [s₃ : Tarski.Structure L M₃] + +namespace Tarski +namespace Structure + +variable (L M M₁ M₂ M₃) + +/-- Data and laws for Hom in `FFL.FirstOrder.Tarski.Structure`. -/ +structure Hom where + /-- The to Fun construction in `FFL.FirstOrder.Tarski.Structure.Hom`. -/ + toFun : M₁ → M₂ + func' : ∀ {k} (f : L.Func k) (v : Fin k → M₁), toFun (s₁.func f v) = s₂.func f (toFun ∘ v) + rel' : ∀ {k} (r : L.Rel k) (v : Fin k → M₁), s₁.rel r v → s₂.rel r (toFun ∘ v) + +/-- The «term →ₛ[ ] » construction in `FFL.FirstOrder.Tarski.Structure`. -/ +notation:25 M " →ₛ[" L "] " M' => Hom L M M' + +/-- Data and laws for Embedding in `FFL.FirstOrder.Tarski.Structure`. -/ +structure Embedding extends M₁ →ₛ[L] M₂ where + toFun_inj : Function.Injective toFun + rel_inv' {k} (r : L.Rel k) (v : Fin k → M₁) : s₂.rel r (toFun ∘ v) → s₁.rel r v + +/-- The «term ↪ₛ[ ] » construction in `FFL.FirstOrder.Tarski.Structure`. -/ +notation:25 M " ↪ₛ[" L "] " M' => Embedding L M M' + +/-- Data and laws for Iso in `FFL.FirstOrder.Tarski.Structure`. -/ +structure Iso extends M₁ ↪ₛ[L] M₂ where + toFun_bij : Function.Bijective toFun + +/-- The «term ≃ₛ[ ] » construction in `FFL.FirstOrder.Tarski.Structure`. -/ +notation:25 M " ≃ₛ[" L "] " M' => Iso L M M' + +/-- Data and laws for Closed Subset in `FFL.FirstOrder.Tarski.Structure`. -/ +@[ext] +structure ClosedSubset where + /-- The domain construction in `FFL.FirstOrder.Tarski.Structure.ClosedSubset`. -/ + domain : Set M + domain_closed : + ∀ {k} (f : L.Func k) {v : Fin k → M}, (∀ i, v i ∈ domain) → s.func f v ∈ domain + +/-- Data and laws for Hom Class in `FFL.FirstOrder.Tarski.Structure`. -/ +class HomClass (F : Type*) (L : outParam (Language.{u})) (M₁ : outParam (Type*)) + (M₂ : outParam (Type*)) [s₁ : Tarski.Structure L M₁] [s₂ : Tarski.Structure L M₂] + [FunLike F M₁ M₂] where + map_func : ∀ (h : F) {k} (f : L.Func k) (v : Fin k → M₁), h (func f v) = func f (h ∘ v) + map_rel : ∀ (h : F) {k} (r : L.Rel k) (v : Fin k → M₁), s₁.rel r v → s₂.rel r (h ∘ v) + +/-- Data and laws for Embedding Class in `FFL.FirstOrder.Tarski.Structure`. -/ +class EmbeddingClass (F : Type*) (L : outParam (Language.{u})) (M₁ : outParam (Type*)) + (M₂ : outParam (Type*)) [s₁ : Tarski.Structure L M₁] [s₂ : Tarski.Structure L M₂] + [FunLike F M₁ M₂] extends HomClass F L M₁ M₂ where + map_inj (f : F) : Function.Injective f + map_rel_inv (f : F) {k} (r : L.Rel k) (v : Fin k → M₁) : s₂.rel r (f ∘ v) → s₁.rel r v + +/-- Data and laws for Iso Class in `FFL.FirstOrder.Tarski.Structure`. -/ +class IsoClass (F : Type*) (L : outParam (Language.{u})) (M₁ : outParam (Type*)) + (M₂ : outParam (Type*)) [s₁ : Tarski.Structure L M₁] [s₂ : Tarski.Structure L M₂] + [FunLike F M₁ M₂] extends EmbeddingClass F L M₁ M₂ where + map_bij (f : F) : Function.Bijective f + +variable {L M M₁ M₂ M₃} + +instance : FunLike (M₁ →ₛ[L] M₂) M₁ M₂ + where + coe := fun φ => φ.toFun + coe_injective := fun φ ψ h => by + rcases φ; rcases ψ + simp only [Hom.mk.injEq] at h ⊢ + ext; exact congr_fun h _ + +instance : HomClass (M₁ →ₛ[L] M₂) L M₁ M₂ + where + map_func := Hom.func' + map_rel := Hom.rel' + +omit [Nonempty M₁] [Nonempty M₂] +@[ext] +lemma Hom.ext (φ ψ : M₁ →ₛ[L] M₂) (h : ∀ x, φ x = ψ x) : φ = ψ := + DFunLike.ext φ ψ h + +namespace HomClass + +variable {F : Type*} [FunLike F M₁ M₂] [HomClass F L M₁ M₂] (φ : F) + +@[ext] +lemma ext (φ ψ : F) (h : ∀ x, φ x = ψ x) : φ = ψ := + DFunLike.ext φ ψ h + +protected lemma func {k} (f : L.Func k) (v : Fin k → M₁) : + φ (s₁.func f v) = s₂.func f (φ ∘ v) := + map_func φ f v + +protected lemma rel {k} (r : L.Rel k) (v : Fin k → M₁) : s₁.rel r v → s₂.rel r (φ ∘ v) := + map_rel φ r v + +lemma val_term (e : Fin n → M₁) (ε : ξ → M₁) (t : Semiterm L ξ n) : + φ (t.val e ε) = t.val (φ ∘ e) (φ ∘ ε) := by + induction t <;> simp [*, HomClass.func, Function.comp_def] + +end HomClass + +instance : FunLike (M₁ ↪ₛ[L] M₂) M₁ M₂ where + coe := fun φ => φ.toFun + coe_injective := fun φ ψ h => by + rcases φ; rcases ψ; simp only [Embedding.mk.injEq] at h ⊢; ext; exact congr_fun h _ + +instance : EmbeddingClass (M₁ ↪ₛ[L] M₂) L M₁ M₂ + where + map_func := fun φ => φ.func' + map_rel := fun φ => φ.rel' + map_inj := Embedding.toFun_inj + map_rel_inv := fun φ => φ.rel_inv' + +@[ext] +lemma Embedding.ext (φ ψ : M₁ ↪ₛ[L] M₂) (h : ∀ x, φ x = ψ x) : φ = ψ := + DFunLike.ext φ ψ h + +namespace EmbeddingClass +open HomClass +variable {F : Type*} [FunLike F M₁ M₂] [EmbeddingClass F L M₁ M₂] (φ : F) + +/-- The to Embedding construction in `FFL.FirstOrder.Tarski.Structure.EmbeddingClass`. -/ +def toEmbedding : M₁ ↪ M₂ where + toFun := φ + inj' := map_inj φ + +protected lemma func {k} (f : L.Func k) (v : Fin k → M₁) : + φ (s₁.func f v) = s₂.func f (φ ∘ v) := + map_func φ f v + +protected lemma rel {k} (r : L.Rel k) (v : Fin k → M₁) : s₂.rel r (φ ∘ v) ↔ s₁.rel r v := + ⟨map_rel_inv φ r v, HomClass.rel φ r v⟩ + +end EmbeddingClass + +instance : FunLike (M₁ ≃ₛ[L] M₂) M₁ M₂ where + coe := fun φ => φ.toFun + coe_injective := fun φ ψ h => by + rcases φ; rcases ψ; simp only [Iso.mk.injEq] at h ⊢; ext; exact congr_fun h _ + +instance : IsoClass (M₁ ≃ₛ[L] M₂) L M₁ M₂ + where + map_func := fun φ => φ.func' + map_rel := fun φ => φ.rel' + map_inj := fun φ => φ.toFun_inj + map_rel_inv := fun φ => φ.rel_inv' + map_bij := fun φ => φ.toFun_bij + +@[ext] +lemma Iso.ext (φ ψ : M₁ ≃ₛ[L] M₂) (h : ∀ x, φ x = ψ x) : φ = ψ := + DFunLike.ext φ ψ h + +namespace IsoClass + +end IsoClass + +namespace ClosedSubset + +variable (u : ClosedSubset L M) + +instance : SetLike (ClosedSubset L M) M := + ⟨ClosedSubset.domain, fun _ _ ↦ ClosedSubset.ext⟩ + +omit [Nonempty M] +lemma closed {k} (f : L.Func k) {v : Fin k → M} (hv : ∀ i, v i ∈ u) : s.func f v ∈ u := + u.domain_closed f hv + +instance toStructure (u : ClosedSubset L M) : Tarski.Structure L u + where + func := fun k f v => ⟨s.func f (fun i ↦ ↑(v i)), u.closed f (by simp)⟩ + rel := fun k r v => s.rel r (fun i ↦ v i) + +protected lemma func {k} (f : L.Func k) (v : Fin k → u) : + u.toStructure.func f v = s.func f (fun i ↦ v i) := + rfl + +protected lemma rel {k} (r : L.Rel k) (v : Fin k → u) : + u.toStructure.rel r v ↔ s.rel r (fun i ↦ v i) := + of_eq rfl + +/-- The inclusion construction in `FFL.FirstOrder.Tarski.Structure.ClosedSubset`. -/ +def inclusion : u ↪ₛ[L] M where + toFun := Subtype.val + func' := by simp [ClosedSubset.func, Function.comp_def] + rel' := by simp [ClosedSubset.rel, Function.comp_def] + rel_inv' := by simp [ClosedSubset.rel, Function.comp_def] + toFun_inj := Subtype.val_injective + +end ClosedSubset + +end Structure +end Tarski + +namespace Semiformula +open Tarski.Structure + +variable {F : Type*} [FunLike F M₁ M₂] [EmbeddingClass F L M₁ M₂] (Θ : F) +variable {e₁ : Fin n → M₁} {ε₁ : ξ → M₁} + +omit [Nonempty M₁] [Nonempty M₂] +lemma eval_hom_iff_of_open {n} {e₁ : Fin n → M₁} {ε₁ : ξ → M₁} {φ : Semiformula L ξ n} + (h : φ.Open) : φ.Eval e₁ ε₁ ↔ φ.Eval (Θ ∘ e₁) (Θ ∘ ε₁) := + match φ with + | rel r v | nrel r v => by simp [Function.comp_def, ← EmbeddingClass.rel Θ, HomClass.val_term] + | ⊤ | ⊥ => by simp + | φ ⋏ ψ | φ ⋎ ψ => by simp at h ⊢; simp [eval_hom_iff_of_open h.1, eval_hom_iff_of_open h.2] + +lemma eval_hom_allClosure {n} {ε₁ : ξ → M₁} {φ : Semiformula L ξ n} (hp : φ.Open) : + (∀¹* φ).Evalf (Θ ∘ ε₁) → (∀¹* φ).Evalf ε₁ := + by + simp only [eval_allClosure] + intro h e₁; exact (eval_hom_iff_of_open Θ hp).mpr (h (Θ ∘ e₁)) + +end Semiformula + +end + +section + +variable {L : Language} {M : Type*} {M₁ : Type*} {M₂ : Type*} {M₃ : Type*} +variable [Nonempty M] [Nonempty M₁] [Nonempty M₂] [Nonempty M₃] [s : Tarski.Structure L M] + [s₁ : Tarski.Structure L M₁] [s₂ : Tarski.Structure L M₂] [s₃ : Tarski.Structure L M₃] + +namespace Tarski +namespace Structure + +variable (L M₁ M₂) + +/-- Data and laws for Elementary Equiv in `FFL.FirstOrder.Tarski.Structure`. -/ +class ElementaryEquiv : Prop where + models {φ : Sentence L} : M₁↓[L] ⊧ φ ↔ M₂↓[L] ⊧ φ + +/-- The «term ≡ₑ[ ] » construction in `FFL.FirstOrder.Tarski.Structure`. -/ +notation:50 M₁ " ≡ₑ[" L "] " M₂ => ElementaryEquiv L M₁ M₂ + +variable {L M₁ M₂} + +namespace ElementaryEquiv + +@[refl] +instance refl (M) [Nonempty M] [Tarski.Structure L M] : M ≡ₑ[L] M := + ⟨by rfl⟩ + +@[symm] +lemma symm : (M₁ ≡ₑ[L] M₂) → (M₂ ≡ₑ[L] M₁) := fun h ↦ ⟨h.models.symm⟩ + +@[trans] +lemma trans : (M₁ ≡ₑ[L] M₂) → (M₂ ≡ₑ[L] M₃) → (M₁ ≡ₑ[L] M₃) := fun h₁ h₂ ↦ + ⟨Iff.trans h₁.models h₂.models⟩ + +lemma modelsTheory [h : M₁ ≡ₑ[L] M₂] {T : Theory L} : M₁↓[L] ⊧* T ↔ M₂↓[L] ⊧* T := by + simp [models_theory_iff, h.models] + +variable (M₁ M₂) + +lemma modelsTheory' [M₁ ≡ₑ[L] M₂] (T : Theory L) [h : M₂↓[L] ⊧* T] : M₁↓[L] ⊧* T := + modelsTheory.mpr h + +variable {M₁ M₂} + +lemma ofEquiv [Nonempty N] (Θ : M ≃ N) : + letI : Tarski.Structure L N := Tarski.Structure.ofEquiv Θ + M ≡ₑ[L] N := + letI : Tarski.Structure L N := Tarski.Structure.ofEquiv Θ + ⟨by simp [models_iff, Empty.eq_elim, Tarski.Structure.evalf_ofEquiv_iff (Θ := Θ)]⟩ + +omit [Nonempty M₁] [Nonempty M₂] in +lemma val_eq_of_equiv {f₁ f₂ b₁ b₂} (I : M₁ ≃ M₂) (hf : ∀ x, I (f₁ x) = f₂ x) + (hb : ∀ x, I (b₁ x) = b₂ x) + (hfunc : + ∀ {k} (f : L.Func k) {v₁ : Fin k → M₁} {v₂ : Fin k → M₂}, + (∀ i, I (v₁ i) = v₂ i) → I (s₁.func f v₁) = s₂.func f v₂) + (t : Semiterm L ξ n) : I (t.val b₁ f₁) = t.val b₂ f₂ := + match t with + | #x => by simp [hb] + | &x => by simp [hf] + | .func f v => + by + have ih : ∀ i, I ((v i).val b₁ f₁) = (v i).val b₂ f₂ := fun i ↦ + val_eq_of_equiv I hf hb hfunc (v i) + simp [hfunc, ih, Function.comp_def] + +omit [Nonempty M₁] [Nonempty M₂] in +lemma eval_iff_of_equiv {f₁ f₂ b₁ b₂} (I : M₁ ≃ M₂) (hf : ∀ x, I (f₁ x) = f₂ x) + (hb : ∀ x, I (b₁ x) = b₂ x) + (hrel : + ∀ {k} (R : L.Rel k) {v₁ : Fin k → M₁} {v₂ : Fin k → M₂}, + (∀ i, I (v₁ i) = v₂ i) → (s₁.rel R v₁ ↔ s₂.rel R v₂)) + (hfunc : + ∀ {k} (f : L.Func k) {v₁ : Fin k → M₁} {v₂ : Fin k → M₂}, + (∀ i, I (v₁ i) = v₂ i) → I (s₁.func f v₁) = s₂.func f v₂) + (φ : Semiformula L ξ n) : φ.Eval b₁ f₁ ↔ φ.Eval b₂ f₂ := + match φ with + | .rel R v => by + simpa [Function.comp_def] using hrel R fun i ↦ val_eq_of_equiv I hf hb hfunc (v i) + | .nrel R v => by + simpa [Function.comp_def] using + not_congr <| hrel R fun i ↦ val_eq_of_equiv I hf hb hfunc (v i) + | ⊤ => by simp + | ⊥ => by simp + | φ ⋏ ψ => by + simp [eval_iff_of_equiv I hf hb hrel hfunc φ, eval_iff_of_equiv I hf hb hrel hfunc ψ] + | φ ⋎ ψ => by + simp [eval_iff_of_equiv I hf hb hrel hfunc φ, eval_iff_of_equiv I hf hb hrel hfunc ψ] + | ∀¹ φ => + by + suffices (∀ x₁ : M₁, φ.Eval (x₁ :> b₁) f₁) ↔ (∀ x₂ : M₂, φ.Eval (x₂ :> b₂) f₂) by simpa + constructor + · intro h x₂ + have : φ.Eval (I.symm x₂ :> b₁) f₁ ↔ φ.Eval (x₂ :> b₂) f₂ := + eval_iff_of_equiv I (b₁ := I.symm x₂ :> b₁) (b₂ := x₂ :> b₂) hf + (by intro i; cases i using Fin.cases <;> simp [hb]) hrel hfunc φ + exact this.mp (h (I.symm x₂)) + · intro h x₁ + have : φ.Eval (x₁ :> b₁) f₁ ↔ φ.Eval (I x₁ :> b₂) f₂ := + eval_iff_of_equiv I (b₁ := x₁ :> b₁) (b₂ := I x₁ :> b₂) hf + (by intro i; cases i using Fin.cases <;> simp [hb]) hrel hfunc φ + exact this.mpr (h _) + | ∃¹ φ => + by + suffices (∃ x₁, φ.Eval (x₁ :> b₁) f₁) ↔ (∃ x₂, φ.Eval (x₂ :> b₂) f₂) by simpa + constructor + · rintro ⟨x₁, h⟩ + have : φ.Eval (x₁ :> b₁) f₁ ↔ φ.Eval (I x₁ :> b₂) f₂ := + eval_iff_of_equiv I (b₁ := x₁ :> b₁) (b₂ := I x₁ :> b₂) hf + (by intro i; cases i using Fin.cases <;> simp [hb]) hrel hfunc φ + exact ⟨I x₁, this.mp h⟩ + · rintro ⟨x₂, h⟩ + have : φ.Eval (I.symm x₂ :> b₁) f₁ ↔ φ.Eval (x₂ :> b₂) f₂ := + eval_iff_of_equiv I (b₁ := I.symm x₂ :> b₁) (b₂ := x₂ :> b₂) hf + (by intro i; cases i using Fin.cases <;> simp [hb]) hrel hfunc φ + exact ⟨I.symm x₂, this.mpr h⟩ + +lemma of_equiv (I : M₁ ≃ M₂) + (hrel : + ∀ {k} (R : L.Rel k) {v₁ : Fin k → M₁} {v₂ : Fin k → M₂}, + (∀ i, I (v₁ i) = v₂ i) → (s₁.rel R v₁ ↔ s₂.rel R v₂)) + (hfunc : + ∀ {k} (f : L.Func k) {v₁ : Fin k → M₁} {v₂ : Fin k → M₂}, + (∀ i, I (v₁ i) = v₂ i) → I (s₁.func f v₁) = s₂.func f v₂) : + M₁ ≡ₑ[L] M₂ := + ⟨fun {φ} ↦ + eval_iff_of_equiv (b₁ := ![]) (b₂ := ![]) (f₁ := Empty.elim) (f₂ := Empty.elim) I (by simp) + (by simp) hrel hfunc φ⟩ + +end ElementaryEquiv + +end Structure +end Tarski + +end + +end FirstOrder +end FFL +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Tarski/Eq.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Tarski/Eq.lean new file mode 100644 index 000000000..39ed212ec --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Tarski/Eq.lean @@ -0,0 +1,294 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Syntax.Classical.Eq +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Tarski.Operator +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Tarski.Elementary +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Quotient + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace FFL + +namespace FirstOrder + +variable {L : Language} {ξ : Type*} [Semiformula.Operator.Eq L] + +namespace Tarski +namespace Structure + +namespace Eq + +variable (L) (M : Type*) [Nonempty M] [Tarski.Structure L M] + +@[simp] +instance models_eq [Tarski.Structure.Eq L M] : M↓[L] ⊧* 𝐄𝐐 L := + ⟨by + intro φ h + rcases h with (_ | _ | _ | _ | _) <;> simp [models_iff, Theory.Eq.funcExt, Theory.Eq.relExt] + · simp [Function.comp_def]; grind + · simp [Function.comp_def]; grind⟩ + +instance models_eqAxiom' [Tarski.Structure.Eq L M] : M↓[L] ⊧* 𝐄𝐐 L := + models_eq _ _ + +variable {M} + +/-- The eqv construction in `FFL.FirstOrder.Tarski.Structure.Eq`. -/ +def eqv (a b : M) : Prop := + (@Semiformula.Operator.Eq.eq L _).val ![a, b] + +variable {L} + +variable [H : M↓[L] ⊧* 𝐄𝐐 L] + +open Semiterm Theory Semiformula + +lemma eqv_refl (a : M) : eqv L a a := + by + have : M↓[L] ⊧ (“∀ x, x = x”) := H.models _ (Theory.eqAxiom.refl (L := L)) + have : ∀ x : M, op(=)[L].val ![x, x] := by simpa [models_iff] using this + exact this a + +lemma eqv_symm {a b : M} : eqv L a b → eqv L b a := + by + have : M↓[L] ⊧ (“∀ x y, x = y → y = x”) := H.models _ (Theory.eqAxiom.symm (L := L)) + have : ∀ x y : M, op(=)[L].val ![x, y] → op(=)[L].val ![y, x] := by + simpa [models_iff] using this + exact this a b + +lemma eqv_trans {a b c : M} : eqv L a b → eqv L b c → eqv L a c := + by + have : M↓[L] ⊧ (“∀ x y z, x = y → y = z → x = z”) := + H.models _ (Theory.eqAxiom.trans (L := L)) + have : ∀ x y z : M, op(=)[L].val ![x, y] → op(=)[L].val ![y, z] → op(=)[L].val ![x, z] := by + simpa [models_iff] using this + exact this a b c + +lemma eqv_funcExt {k} (f : L.Func k) {v w : Fin k → M} (h : ∀ i, eqv L (v i) (w i)) : + eqv L (func f v) (func f w) := + by + have : M↓[L] ⊧ Eq.funcExt f := H.models _ (eqAxiom.funcExt f) + have : + ∀ m : Fin (k + k) → M, + (∀ (i : Fin k), op(=)[L].val ![m (Fin.addCast k i), m (i.addNat k)]) → + op(=)[L].val ![func f fun i ↦ m (Fin.addCast k i), func f fun i ↦ m (i.addNat k)] := + by simpa [models_iff, Semiterm.val_func] using! this + have := + this (Matrix.vecAppend rfl v w) (fun i ↦ by simpa [Matrix.vecAppend_eq_ite, eqv] using h i) + simpa [Semiterm.val_func, Matrix.vecAppend_eq_ite, eqv] using this + +lemma eqv_relExt_aux {k} (r : L.Rel k) {v w : Fin k → M} (h : ∀ i, eqv L (v i) (w i)) : + rel r v → rel r w := + by + have : M↓[L] ⊧ Eq.relExt r := H.models _ (eqAxiom.relExt r) + have : + ∀ m : Fin (k + k) → M, + (∀ (i : Fin k), op(=)[L].val ![m (Fin.addCast k i), m (i.addNat k)]) → + (rel r fun i ↦ m (Fin.addCast k i)) → rel r fun i ↦ m (i.addNat k) := + by simpa [models_iff, Semiterm.val_func, eval_rel] using! this + have := + this (Matrix.vecAppend rfl v w) (fun i ↦ by simpa [Matrix.vecAppend_eq_ite, eqv] using h i) + simpa [Semiterm.val_func, Matrix.vecAppend_eq_ite, eqv] using this + +lemma eqv_relExt {k} (r : L.Rel k) {v w : Fin k → M} (h : ∀ i, eqv L (v i) (w i)) : + rel r v ↔ rel r w := by + constructor + · exact eqv_relExt_aux r h + · exact eqv_relExt_aux r (fun i => eqv_symm (h i)) + +lemma eqv_equivalence : Equivalence (eqv L (M := M)) + where + refl := eqv_refl + symm := eqv_symm + trans := eqv_trans + +variable (L M) + +/-- The eqv Setoid construction in `FFL.FirstOrder.Tarski.Structure.Eq`. -/ +def eqvSetoid : Setoid M := + Setoid.mk (eqv L) eqv_equivalence + +/-- The Quot Eq construction in `FFL.FirstOrder.Tarski.Structure.Eq`. -/ +abbrev QuotEq := + Quotient (eqvSetoid L M) + +variable {L M} + +instance QuotEq.inhabited : Nonempty (QuotEq L M) := + Nonempty.map (⟦·⟧) inferInstance + +lemma of_eq_of {a b : M} : (⟦a⟧ : QuotEq L M) = ⟦b⟧ ↔ eqv L a b := + Quotient.eq (r := eqvSetoid L M) + +namespace QuotEq + +/-- The func construction in `FFL.FirstOrder.Tarski.Structure.Eq.QuotEq`. -/ +def func ⦃k⦄ (f : L.Func k) (v : Fin k → QuotEq L M) : QuotEq L M := + Quotient.liftVec (s := eqvSetoid L M) (⟦Tarski.Structure.func f ·⟧) + (fun _ _ hvw ↦ of_eq_of.mpr (eqv_funcExt f hvw)) v + +/-- The Rel construction in `FFL.FirstOrder.Tarski.Structure.Eq.QuotEq`. -/ +def Rel ⦃k⦄ (r : L.Rel k) (v : Fin k → QuotEq L M) : Prop := + Quotient.liftVec (s := eqvSetoid L M) (Tarski.Structure.rel r) + (fun _ _ hvw ↦ eq_iff_iff.mpr <| eqv_relExt r hvw) v + +instance struc : Tarski.Structure L (QuotEq L M) + where + func := QuotEq.func + rel := QuotEq.Rel + +lemma funk_mk {k} (f : L.Func k) (v : Fin k → M) : + Tarski.Structure.func (M := QuotEq L M) f (⟦v ·⟧) = ⟦Tarski.Structure.func f v⟧ := + Quotient.liftVec_mk (s := eqvSetoid L M) _ _ _ + +lemma rel_mk {k} (r : L.Rel k) (v : Fin k → M) : + Tarski.Structure.rel (M := QuotEq L M) r (⟦v ·⟧) ↔ Tarski.Structure.rel r v := + of_eq <| Quotient.liftVec_mk (s := eqvSetoid L M) _ _ _ + +lemma funk_mk_of_eq {k} (f : L.Func k) {w : Fin k → QuotEq L M} {v : Fin k → M} + (h : ∀ i, w i = ⟦v i⟧) : + Tarski.Structure.func (M := QuotEq L M) f w = ⟦Tarski.Structure.func f v⟧ := + funext h ▸ funk_mk f v + +lemma rel_mk_of_eq {k} (r : L.Rel k) {w : Fin k → QuotEq L M} {v : Fin k → M} + (h : ∀ i, w i = ⟦v i⟧) : + Tarski.Structure.rel (M := QuotEq L M) r w ↔ Tarski.Structure.rel r v := + funext h ▸ rel_mk r v + +lemma val_mk {bv fv} (t : Semiterm L ξ n) : + t.val (M := QuotEq L M) (⟦bv ·⟧) (⟦fv ·⟧) = ⟦t.val bv fv⟧ := by + induction t with + | bvar x => rfl + | fvar x => rfl + | func f v ih => exact funk_mk_of_eq f ih + +lemma eval_mk {bv fv} {φ : Semiformula L ξ n} : + φ.Eval (M := QuotEq L M) (⟦bv ·⟧) (⟦fv ·⟧) ↔ φ.Eval bv fv := + by + induction φ using Semiformula.rec' + case hall n φ ih => + constructor + · intro h a; exact (ih (bv := a :> bv)).mp (by simp only [Matrix.comp_vecCons]; exact h ⟦a⟧) + · intro h a; induction a using Quotient.ind + rename_i a + have h2 := ih.mpr (h a); simp only [Matrix.comp_vecCons] at h2; exact h2 + case hexs n φ ih => + constructor + · intro ⟨a, h⟩ + induction a using Quotient.ind + rename_i a + exact ⟨a, (ih (bv := a :> bv)).mp (by simp only [Matrix.comp_vecCons]; exact h)⟩ + · intro ⟨a, h⟩; refine ⟨⟦a⟧, ?_⟩ + have h2 := ih.mpr h; simp only [Matrix.comp_vecCons] at h2; exact h2 + case _ => simp [*] + case _ => simp [*] + case hrel r v => exact rel_mk_of_eq r fun i ↦ val_mk (v i) + case hnrel r v => exact not_congr (rel_mk_of_eq r fun i ↦ val_mk (v i)) + case _ => simp [*] + case _ => simp [*] + +lemma evalf_mk {fv} {φ : Formula L ξ} : φ.Evalf (M := QuotEq L M) (⟦fv ·⟧) ↔ φ.Evalf fv := + by + have h := eval_mk (bv := ![]) (fv := fv) (φ := φ) + simp only [Matrix.empty_eq] at h; exact h + +lemma models_iff {σ : Sentence L} : (QuotEq L M)↓[L] ⊧ σ ↔ M↓[L] ⊧ σ := + by + have h := eval_mk (M := M) (ξ := Empty) (φ := σ) (bv := ![]) (fv := Empty.elim) + simp only [Empty.eq_elim, Matrix.empty_eq] at h; exact h + +variable (L M) + +lemma elementaryEquiv : QuotEq L M ≡ₑ[L] M := + ⟨models_iff⟩ + +variable {L M} + +lemma rel_eq (a b : QuotEq L M) : op(=)[L].val (M := QuotEq L M) ![a, b] ↔ a = b := + by + induction a using Quotient.ind + rename_i a + induction b using Quotient.ind + rename_i b + rw [of_eq_of]; simp [eqv, Semiformula.Operator.val]; + simpa [Matrix.fun_eq_vec_two, Empty.eq_elim] using + eval_mk (H := H) (bv := ![a, b]) (fv := Empty.elim) (φ := + Semiformula.Operator.Eq.eq.sentence) + +instance structureEq : Tarski.Structure.Eq L (QuotEq L M) := + ⟨rel_eq⟩ + +end QuotEq + +end Eq + +end Structure +end Tarski + +/-- +Consequence can be tested on equality structures when all models satisfy the equality axioms. +This is a routine consequence of the quotient-model construction. -/ +lemma consequence_iff_eq_of_models_eq {T : Theory L} + (hEq : ∀ (M : Type v) [Nonempty M] [Tarski.Structure L M], M↓[L] ⊧* T → M↓[L] ⊧* 𝐄𝐐 L) + {σ : Sentence L} : + T ⊨[Tarski.Struc.{v, u} L] σ ↔ + (∀ (M : Type v) [Nonempty M] [Tarski.Structure L M] [Tarski.Structure.Eq L M], + M↓[L] ⊧* T → M↓[L] ⊧ σ) := + by + simp only [consequence_iff, Nonempty.forall]; constructor; + · intro h M x s _ hM; exact h M x hM; + · intro h M x s hM; have : Nonempty M := ⟨x⟩; have H : M↓[L] ⊧* 𝐄𝐐 L := hEq M hM; + have e : Tarski.Structure.Eq.QuotEq L M ≡ₑ[L] M := + Tarski.Structure.Eq.QuotEq.elementaryEquiv L M; + exact e.models.mp <| h (Tarski.Structure.Eq.QuotEq L M) ⟦x⟧ (e.modelsTheory.mpr hM); + +/-- +Satisfiability has an equality-structure witness when all models satisfy the equality axioms. +This is a routine consequence of the quotient-model construction. -/ +lemma satisfiable_iff_eq_of_models_eq {T : Theory L} + (hEq : ∀ (M : Type v) [Nonempty M] [Tarski.Structure L M], M↓[L] ⊧* T → M↓[L] ⊧* 𝐄𝐐 L) : + Semantics.Satisfiable (Tarski.Struc.{v, u} L) T ↔ + (∃ (M : Type v) (_ : Nonempty M) (_ : Tarski.Structure L M) (_ : Tarski.Structure.Eq L M), + M↓[L] ⊧* T) := + by + simp only [satisfiable_iff, Nonempty.exists, exists_prop]; constructor; + · intro ⟨M, x, s, hM⟩; have : Nonempty M := ⟨x⟩; have H : M↓[L] ⊧* 𝐄𝐐 L := hEq M hM; + have e : Tarski.Structure.Eq.QuotEq L M ≡ₑ[L] M := + Tarski.Structure.Eq.QuotEq.elementaryEquiv L M; + exact + ⟨Tarski.Structure.Eq.QuotEq L M, ⟦x⟧, inferInstance, inferInstance, + e.modelsTheory.mpr hM⟩; + · intro ⟨M, i, s, _, hM⟩; exact ⟨M, i, s, hM⟩; + +namespace Semiformula + +variable {M : Type*} [s : Tarski.Structure L M] [Tarski.Structure.Eq L M] + +@[simp] +lemma eval_existsUnique {e ε} {φ : Semiformula L ξ (n + 1)} : + Eval (M := M) e ε (∃¹! φ) ↔ ∃! x, Eval (M := M) (x :> e) ε φ := + by + simp [existsUnique, Semiformula.eval_substs, Matrix.comp_vecCons'', ExistsUnique] + simp [Function.comp_def] + +end Semiformula + +end FirstOrder + +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Tarski/Model.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Tarski/Model.lean new file mode 100644 index 000000000..86cfeb677 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Tarski/Model.lean @@ -0,0 +1,271 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Tarski.Operator +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Tarski.Elementary + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace FFL + +namespace FirstOrder + +namespace Tarski +namespace Structure + +/-- Data and laws for Model in `FFL.FirstOrder.Tarski.Structure`. -/ +structure Model (L : Language) (M : Type*) where + /-- The intro construction in `FFL.FirstOrder.Tarski.Structure.Model`. -/ + intro : M + +namespace Model + +variable [Tarski.Structure L M] + +/-- The equiv construction in `FFL.FirstOrder.Tarski.Structure.Model`. -/ +def equiv (L : Language) (M : Type*) : M ≃ Model L M + where + toFun := fun x => ⟨x⟩ + invFun := Model.intro + left_inv := by intro x; simp + right_inv := by rintro ⟨x⟩; simp + +instance : Tarski.Structure L (Model L M) := + Tarski.Structure.ofEquiv (equiv L M) + +instance [h : Nonempty M] : Nonempty (Model L M) := by rcases h with ⟨x⟩; exact ⟨equiv L M x⟩ + +instance elementaryEquiv (L : Language) (M : Type*) [Nonempty M] [Tarski.Structure L M] : + M ≡ₑ[L] Model L M := + ElementaryEquiv.ofEquiv _ + +section + +open Semiterm Semiformula + +instance [Operator.Zero L] : Zero (Model L M) := + ⟨(@Operator.Zero.zero L _).val ![]⟩ + +instance [Operator.Zero L] : Tarski.Structure.Zero L (Model L M) := + ⟨rfl⟩ + +instance [Operator.One L] : One (Model L M) := + ⟨(@Operator.One.one L _).val ![]⟩ + +instance [Operator.One L] : Tarski.Structure.One L (Model L M) := + ⟨rfl⟩ + +instance [Operator.Add L] : Add (Model L M) := + ⟨fun x y => (@Operator.Add.add L _).val ![x, y]⟩ + +instance [Operator.Add L] : Tarski.Structure.Add L (Model L M) := + ⟨fun _ _ => rfl⟩ + +instance [Operator.Mul L] : Mul (Model L M) := + ⟨fun x y => (@Operator.Mul.mul L _).val ![x, y]⟩ + +instance [Operator.Mul L] : Tarski.Structure.Mul L (Model L M) := + ⟨fun _ _ => rfl⟩ + +instance [Operator.Exp L] : Exp (Model L M) := + ⟨fun x => (@Operator.Exp.exp L _).val ![x]⟩ + +instance [Operator.Exp L] : Tarski.Structure.Exp L (Model L M) := + ⟨fun _ => rfl⟩ + +instance [Operator.Eq L] [Tarski.Structure.Eq L M] : Tarski.Structure.Eq L (Model L M) := + ⟨fun x y => by simp [operator_val_ofEquiv_iff]⟩ + +instance [Operator.LT L] : LT (Model L M) := + ⟨fun x y => (@Operator.LT.lt L _).val ![x, y]⟩ + +instance [Operator.LT L] : Tarski.Structure.LT L (Model L M) := + ⟨fun _ _ => iff_of_eq rfl⟩ + +instance [Operator.Mem L] : Membership (Model L M) (Model L M) := + ⟨fun x y => (@Operator.Mem.mem L _).val ![y, x]⟩ + +instance [Operator.Mem L] : Tarski.Structure.Mem L (Model L M) := + ⟨fun _ _ => iff_of_eq rfl⟩ + +end + +end Model + +section ofFunc + +variable (F : ℕ → Type*) {M : Type*} (fF : {k : ℕ} → (f : F k) → (Fin k → M) → M) + +/-- The of Func construction in `FFL.FirstOrder.Tarski.Structure`. -/ +abbrev ofFunc : Tarski.Structure (Language.ofFunc F) M + where + func := fun _ f v => fF f v + rel := fun _ r _ => r.elim + +lemma func_ofFunc {k} (f : F k) (v : Fin k → M) : (ofFunc F fF).func f v = fF f v := + rfl + +end ofFunc + +section add + +variable (L₁ : Language.{u₁}) (L₂ : Language.{u₂}) (M : Type*) [str₁ : Tarski.Structure L₁ M] + [str₂ : Tarski.Structure L₂ M] + +instance add : Tarski.Structure (L₁.add L₂) M + where + func := fun _ f v => + match f with + | Sum.inl f => func f v + | Sum.inr f => func f v + rel := fun _ r v => + match r with + | Sum.inl r => rel r v + | Sum.inr r => rel r v + +variable {L₁ L₂ M} + +@[simp] +lemma func_sigma_inl {k} (f : L₁.Func k) (v : Fin k → M) : + (add L₁ L₂ M).func (Sum.inl f) v = func f v := + rfl + +@[simp] +lemma func_sigma_inr {k} (f : L₂.Func k) (v : Fin k → M) : + (add L₁ L₂ M).func (Sum.inr f) v = func f v := + rfl + +@[simp] +lemma rel_sigma_inl {k} (r : L₁.Rel k) (v : Fin k → M) : + (add L₁ L₂ M).rel (Sum.inl r) v ↔ rel r v := + iff_of_eq rfl + +@[simp] +lemma rel_sigma_inr {k} (r : L₂.Rel k) (v : Fin k → M) : + (add L₁ L₂ M).rel (Sum.inr r) v ↔ rel r v := + iff_of_eq rfl + +lemma lMap_add₁ : (add L₁ L₂ M).lMap (Language.Hom.add₁ L₁ L₂) = str₁ := + rfl + +lemma lMap_add₂ : (add L₁ L₂ M).lMap (Language.Hom.add₂ L₁ L₂) = str₂ := + rfl + +@[simp] +lemma val_lMap_add₁ {n} (t : Semiterm L₁ μ n) (e : Fin n → M) (f : μ → M) : + Semiterm.val (s := add L₁ L₂ M) e f (t.lMap (Language.Hom.add₁ L₁ L₂)) = + t.val (s := str₁) e f := + by rw [Semiterm.val_lMap, lMap_add₁] + +@[simp] +lemma val_lMap_add₂ {n} (t : Semiterm L₂ μ n) (e : Fin n → M) (f : μ → M) : + Semiterm.val (s := add L₁ L₂ M) e f (t.lMap (Language.Hom.add₂ L₁ L₂)) = + t.val (s := str₂) e f := + by rw [Semiterm.val_lMap, lMap_add₂] + +@[simp] +lemma eval_lMap_add₁ {n} (φ : Semiformula L₁ μ n) (e : Fin n → M) (f : μ → M) : + (Semiformula.lMap (Language.Hom.add₁ L₁ L₂) φ).Eval (s := add L₁ L₂ M) e f ↔ + φ.Eval (s := str₁) e f := + by rw [Semiformula.eval_lMap, lMap_add₁] + +@[simp] +lemma eval_lMap_add₂ {n} (φ : Semiformula L₂ μ n) (e : Fin n → M) (f : μ → M) : + (Semiformula.lMap (Language.Hom.add₂ L₁ L₂) φ).Eval (s := add L₁ L₂ M) e f ↔ + φ.Eval (s := str₂) e f := + by rw [Semiformula.eval_lMap, lMap_add₂] + +end add + +section sigma + +variable (L : ι → Language) (M : Type*) [str : (i : ι) → Tarski.Structure (L i) M] + +instance sigma : Tarski.Structure (Language.sigma L) M + where + func := fun _ ⟨_, f⟩ v ↦ func f v + rel := fun _ ⟨_, r⟩ v ↦ rel r v + +@[simp] +lemma func_sigma {k} (f : (L i).Func k) (v : Fin k → M) : + (sigma L M).func ⟨i, f⟩ v = func f v := + rfl + +@[simp] +lemma rel_sigma {k} (r : (L i).Rel k) (v : Fin k → M) : (sigma L M).rel ⟨i, r⟩ v ↔ rel r v := + iff_of_eq rfl + +lemma lMap_sigma : (sigma L M).lMap (Language.Hom.sigma L i) = str i := + rfl + +@[simp] +lemma val_lMap_sigma {n} (t : Semiterm (L i) μ n) (e : Fin n → M) (f : μ → M) : + Semiterm.val (s := sigma L M) e f (t.lMap (Language.Hom.sigma L i)) = + t.val (s := str i) e f := + by rw [Semiterm.val_lMap, lMap_sigma] + +@[simp] +lemma eval_lMap_sigma {n} (φ : Semiformula (L i) μ n) (e : Fin n → M) (f : μ → M) : + (Semiformula.lMap (Language.Hom.sigma L i) φ).Eval (s := sigma L M) e f ↔ + φ.Eval (s := str i) e f := + by rw [Semiformula.eval_lMap, lMap_sigma] + +end sigma + +end Structure +end Tarski + +section ULift + +variable {L : Language.{u}} {M : Type v} [Tarski.Structure L M] + +instance : Tarski.Structure L (ULift.{v'} M) + where + func _ f v := ⟨Tarski.Structure.func f (ULift.down ∘ v)⟩ + rel _ r v := Tarski.Structure.rel r (ULift.down ∘ v) + +@[simp] +lemma Tarski.Structure.func_uLift {k} (f : L.Func k) (v : Fin k → ULift.{v'} M) : + Tarski.Structure.func f v = ⟨Tarski.Structure.func f (ULift.down ∘ v)⟩ := + rfl + +@[simp] +lemma Tarski.Structure.rel_uLift {k} (r : L.Rel k) (v : Fin k → ULift.{v'} M) : + Tarski.Structure.rel r v = Tarski.Structure.rel r (ULift.down ∘ v) := + rfl + +lemma Semiterm.val_uLift {e : Fin n → ULift.{v'} M} {f : ξ → ULift.{v'} M} + {t : Semiterm L ξ n} : + Semiterm.val e f t = ⟨Semiterm.val (ULift.down ∘ e) (ULift.down ∘ f) t⟩ := by + induction t <;> simp [*, Function.comp_def] + +lemma Semiformula.eval_uLift {e : Fin n → ULift.{v'} M} {f : ξ → ULift.{v'} M} + {φ : Semiformula L ξ n} : φ.Eval e f ↔ φ.Eval (ULift.down ∘ e) (ULift.down ∘ f) := by + induction φ using Semiformula.rec' <;> + simp [*, Semiterm.val_uLift, Matrix.comp_vecCons', Function.comp_def] + +variable (L M) + +lemma uLift_elementaryEquiv [Nonempty M] : ULift.{v'} M ≡ₑ[L] M := + ⟨by intro σ; simp [models_iff, Semiformula.eval_uLift, Matrix.empty_eq, Empty.eq_elim]⟩ + +end ULift + +end FirstOrder + +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Tarski/Operator.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Tarski/Operator.lean new file mode 100644 index 000000000..a54f2ce27 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Tarski/Operator.lean @@ -0,0 +1,261 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Tarski.Basic +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Syntax.Classical.Operator + +/-! Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace FFL + +namespace FirstOrder + +variable {L : Language} + +namespace Semiterm + +/-- The val construction in `FFL.FirstOrder.Semiterm.Operator`. -/ +def Operator.val {M : Type w} [s : Tarski.Structure L M] (v : Fin k → M) (o : Operator L k) : + M := + Semiterm.val v Empty.elim o.term + +variable {M : Type w} {s : Tarski.Structure L M} + +@[simp] +lemma val_operator {k} (b : Fin n → M) (f : ξ → M) (o : Operator L k) + (v : Fin k → Semiterm L ξ n) : val b f (o.operator v) = o.val (Semiterm.val b f ∘ v) := by + simp [Operator.operator, val_substs, Empty.eq_elim]; congr + +lemma val_operator' {k} (b : Fin k → M) (f : ξ → M) (o : Operator L k) (v) : + val b f (o.operator v) = o.val fun i ↦ (v i).val b f := + val_operator b f o v + +lemma Operator.val_comp (o₁ : Operator L k) (o₂ : Fin k → Operator L m) (v : Fin m → M) : + (o₁.comp o₂).val v = o₁.val (val v ∘ o₂) := by simp [comp, val, Function.comp_def] + +@[simp] +lemma Operator.val_bvar {n} (x : Fin n) (v : Fin n → M) : + (Operator.bvar (L := L) x).val v = v x := by simp [Operator.bvar, Operator.val] + +end Semiterm + +namespace Semiformula + +/-- The val construction in `FFL.FirstOrder.Semiformula.Operator`. -/ +def Operator.val {M : Type w} [s : Tarski.Structure L M] {k} (v : Fin k → M) + (o : Operator L k) : Prop := + o.sentence.Eval v Empty.elim + +section + +variable {M : Type w} {s : Tarski.Structure L M} + +@[simp] +lemma val_operator_and {k} {o₁ o₂ : Operator L k} {v : Fin k → M} : + (o₁.and o₂).val v ↔ o₁.val v ∧ o₂.val v := by simp [Operator.and, Operator.val] + +@[simp] +lemma val_operator_or {k} {o₁ o₂ : Operator L k} {v : Fin k → M} : + (o₁.or o₂).val v ↔ o₁.val v ∨ o₂.val v := by simp [Operator.or, Operator.val] + +@[simp] +lemma eval_operator {k} {o : Operator L k} {e : Fin n → M} {f : ξ → M} + {v : Fin k → Semiterm L ξ n} : Eval e f (o.operator v) ↔ o.val (Semiterm.val e f ∘ v) := by + simp [Operator.operator, eval_substs, Operator.val] + +end + +end Semiformula + +namespace Tarski +namespace Structure + +open Semiterm Semiformula + +variable (L) (M : Type*) [Tarski.Structure L M] + +/-- Data and laws for Zero in `FFL.FirstOrder.Tarski.Structure`. -/ +protected class Zero [Operator.Zero L] [Zero M] : Prop where + zero : (@Operator.Zero.zero L _).val ![] = (0 : M) + +/-- Data and laws for One in `FFL.FirstOrder.Tarski.Structure`. -/ +protected class One [Operator.One L] [One M] : Prop where + one : (@Operator.One.one L _).val ![] = (1 : M) + +/-- Data and laws for Add in `FFL.FirstOrder.Tarski.Structure`. -/ +protected class Add [Operator.Add L] [Add M] : Prop where + add : ∀ a b : M, (@Operator.Add.add L _).val ![a, b] = a + b + +/-- Data and laws for Mul in `FFL.FirstOrder.Tarski.Structure`. -/ +protected class Mul [Operator.Mul L] [Mul M] : Prop where + mul : ∀ a b : M, (@Operator.Mul.mul L _).val ![a, b] = a * b + +/-- Data and laws for Exp in `FFL.FirstOrder.Tarski.Structure`. -/ +protected class Exp [Operator.Exp L] [Exp M] : Prop where + exp : ∀ a : M, (@Operator.Exp.exp L _).val ![a] = Exp.exp a + +/-- Data and laws for Eq in `FFL.FirstOrder.Tarski.Structure`. -/ +protected class Eq [Operator.Eq L] : Prop where + eq : ∀ a b : M, (@Operator.Eq.eq L _).val ![a, b] ↔ a = b + +/-- Data and laws for LT in `FFL.FirstOrder.Tarski.Structure`. -/ +protected class LT [Operator.LT L] [LT M] : Prop where + lt : ∀ a b : M, (@Operator.LT.lt L _).val ![a, b] ↔ a < b + +/-- Data and laws for LE in `FFL.FirstOrder.Tarski.Structure`. -/ +protected class LE [Operator.LE L] [LE M] : Prop where + le : ∀ a b : M, (@Operator.LE.le L _).val ![a, b] ↔ a ≤ b + +/-- Data and laws for Mem in `FFL.FirstOrder.Tarski.Structure`. -/ +protected class Mem [Operator.Mem L] [Membership M M] : Prop where + mem : ∀ a b : M, (@Operator.Mem.mem L _).val ![a, b] ↔ a ∈ b + +attribute [simp] Zero.zero One.one Add.add Mul.mul Exp.exp LE.le + +instance [L.Eq] [L.LT] [Tarski.Structure.Eq L M] [PartialOrder M] [Tarski.Structure.LT L M] : + Tarski.Structure.LE L M := + ⟨by + intro a b + simpa [Operator.LE.def_of_Eq_of_LT, Tarski.Structure.Eq.eq, Tarski.Structure.LT.lt] using + (le_iff_eq_or_lt (a := a) (b := b)).symm⟩ + +variable {L M} + +@[simp] +lemma zero_eq_of_lang [L.Zero] [Zero M] [Tarski.Structure.Zero L M] (v : Fin 0 → M) : + Tarski.Structure.func (L := L) Language.Zero.zero v = (0 : M) := by + simpa [Matrix.empty_eq, Semiterm.Operator.val, Semiterm.Operator.Zero.zero, + ← Matrix.fun_eq_vec_two] using Tarski.Structure.Zero.zero (L := L) (M := M) + +@[simp] +lemma one_eq_of_lang [L.One] [One M] [Tarski.Structure.One L M] (v : Fin 0 → M) : + Tarski.Structure.func (L := L) Language.One.one v = (1 : M) := by + simpa [Matrix.empty_eq, Semiterm.Operator.val, Semiterm.Operator.One.one, + ← Matrix.fun_eq_vec_two] using Tarski.Structure.One.one (L := L) (M := M) + +@[simp] +lemma add_eq_of_lang [L.Add] [Add M] [Tarski.Structure.Add L M] {v : Fin 2 → M} : + Tarski.Structure.func (L := L) Language.Add.add v = v 0 + v 1 := + by + have h := Tarski.Structure.Add.add (L := L) (v 0) (v 1) + simp only [← Matrix.fun_eq_vec_two] at h + exact h + +@[simp] +lemma mul_eq_of_lang [L.Mul] [Mul M] [Tarski.Structure.Mul L M] {v : Fin 2 → M} : + Tarski.Structure.func (L := L) Language.Mul.mul v = v 0 * v 1 := + by + have h := Tarski.Structure.Mul.mul (L := L) (v 0) (v 1) + simp only [← Matrix.fun_eq_vec_two] at h + exact h + +@[simp] +lemma exp_eq_of_lang [L.Exp] [Exp M] [Tarski.Structure.Exp L M] {v : Fin 1 → M} : + Tarski.Structure.func (L := L) Language.Exp.exp v = FFL.Exp.exp (v 0) := + by + have h := Tarski.Structure.Exp.exp (L := L) (v 0) + simp only [← Matrix.fun_eq_vec_one] at h + exact h + +@[simp] +lemma eq_iff_eq [Operator.Eq L] [Tarski.Structure.Eq L M] {v : Fin 2 → M} : + (@Operator.Eq.eq L _).val v ↔ v 0 = v 1 := + by + have h := Tarski.Structure.Eq.eq (L := L) (M := M) (v 0) (v 1) + simp only [← Matrix.fun_eq_vec_two] at h + exact h + +@[simp] +lemma lt_iff_lt [Operator.LT L] [LT M] [Tarski.Structure.LT L M] {v : Fin 2 → M} : + (@Operator.LT.lt L _).val v ↔ v 0 < v 1 := + by + have h := Tarski.Structure.LT.lt (L := L) (M := M) (v 0) (v 1) + simp only [← Matrix.fun_eq_vec_two] at h + exact h + +@[simp] +lemma mem_iff_mem [Operator.Mem L] [Membership M M] [Tarski.Structure.Mem L M] {v : Fin 2 → M} : + (@Operator.Mem.mem L _).val v ↔ v 0 ∈ v 1 := + by + have h := Tarski.Structure.Mem.mem (L := L) (M := M) (v 0) (v 1) + simp only [← Matrix.fun_eq_vec_two] at h + exact h + +lemma le_iff_of_eq_of_lt [Operator.Eq L] [Operator.LT L] [LT M] [Tarski.Structure.Eq L M] + [Tarski.Structure.LT L M] {a b : M} : (@Operator.LE.le L _).val ![a, b] ↔ a = b ∨ a < b := + by simp [Operator.LE.def_of_Eq_of_LT] + +@[simp] +lemma eq_lang [L.Eq] [Tarski.Structure.Eq L M] {v : Fin 2 → M} : + Tarski.Structure.rel (L := L) Language.Eq.eq v ↔ v 0 = v 1 := by + simpa [-eq_iff_eq] using! eq_iff_eq (L := L) (v := v) + +@[simp] +lemma lt_lang [L.LT] [LT M] [Tarski.Structure.LT L M] {v : Fin 2 → M} : + Tarski.Structure.rel (L := L) Language.LT.lt v ↔ v 0 < v 1 := by + simpa [-lt_iff_lt] using! lt_iff_lt (L := L) (v := v) + +@[simp] +lemma mem_lang [L.Mem] [Membership M M] [Tarski.Structure.Mem L M] {v : Fin 2 → M} : + Tarski.Structure.rel (L := L) Language.Mem.mem v ↔ v 0 ∈ v 1 := by + simpa [-mem_iff_mem] using! mem_iff_mem (L := L) (v := v) + +lemma operator_val_ofEquiv_iff (φ : M ≃ N) {k : ℕ} {o : Semiformula.Operator L k} + {v : Fin k → N} : + letI : Tarski.Structure L N := ofEquiv φ + o.val v ↔ o.val (φ.symm ∘ v) := + by simp [Semiformula.Operator.val, eval_ofEquiv_iff, Empty.eq_elim] + +end Structure +end Tarski + +namespace Semiformula + +variable {M : Type*} {s : Tarski.Structure L M} + +variable {e : Fin n → M} {f : ξ → M} {t : Semiterm L ξ n} {φ : Semiformula L ξ (n + 1)} + +@[simp] +lemma eval_ballLT [Operator.LT L] [LT M] [Tarski.Structure.LT L M] : + (φ.ballLT t).Eval e f ↔ ∀ x < t.val e f, φ.Eval (x :> e) f := by simp [ballLT] + +@[simp] +lemma eval_bexsLT [Operator.LT L] [LT M] [Tarski.Structure.LT L M] : + (φ.bexsLT t).Eval e f ↔ ∃ x < t.val e f, φ.Eval (x :> e) f := by simp [bexsLT] + +@[simp] +lemma eval_ballLE [Operator.LE L] [LE M] [Tarski.Structure.LE L M] : + (φ.ballLE t).Eval e f ↔ ∀ x ≤ t.val e f, φ.Eval (x :> e) f := by simp [ballLE] + +@[simp] +lemma eval_bexsLE [Operator.LE L] [LE M] [Tarski.Structure.LE L M] : + (φ.bexsLE t).Eval e f ↔ ∃ x ≤ t.val e f, φ.Eval (x :> e) f := by simp [bexsLE] + +@[simp] +lemma eval_ballMem [Operator.Mem L] [Membership M M] [Tarski.Structure.Mem L M] : + (φ.ballMem t).Eval e f ↔ ∀ x ∈ t.val e f, φ.Eval (x :> e) f := by simp [ballMem] + +@[simp] +lemma eval_bexsMem [Operator.Mem L] [Membership M M] [Tarski.Structure.Mem L M] : + (φ.bexsMem t).Eval e f ↔ ∃ x ∈ t.val e f, φ.Eval (x :> e) f := by simp [bexsMem] + +end Semiformula + +end FirstOrder + +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Tarski/Ultraproduct.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Tarski/Ultraproduct.lean new file mode 100644 index 000000000..ff87c7afa --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Tarski/Ultraproduct.lean @@ -0,0 +1,229 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Tarski.Basic +public import Mathlib.Order.Filter.Ultrafilter.Basic + +/-! Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section +namespace FFL + +namespace FirstOrder + +section + +universe u v + +variable {L : Language.{u}} {ξ : Type v} {I : Type u} (A : I → Type u) + [s : (i : I) → FirstOrder.Tarski.Structure L (A i)] (𝓤 : Ultrafilter I) + +namespace Tarski +namespace Structure + +/-- Data and laws for Uprod in `FFL.FirstOrder.Tarski.Structure`. -/ +structure Uprod (𝓤 : Ultrafilter I) where + /-- The val construction in `FFL.FirstOrder.Tarski.Structure.Uprod`. -/ + val : (i : I) → A i + +instance UprodStruc : Tarski.Structure L (Uprod A 𝓤) + where + func := fun _ f v => ⟨fun i ↦ (s i).func f (fun x ↦ (v x).val i)⟩ + rel := fun _ r v => {i | (s i).rel r (fun x ↦ (v x).val i)} ∈ 𝓤 + +instance [(i : I) → Nonempty (A i)] : Nonempty (Uprod A 𝓤) := + Nonempty.map (⟨·⟩) inferInstance + +@[simp] +lemma func_Uprod {k} (f : L.Func k) (v : Fin k → Uprod A 𝓤) : + Tarski.Structure.func f v = ⟨fun i ↦ (s i).func f (fun x ↦ (v x).val i)⟩ := + rfl + +@[simp] +lemma rel_Uprod {k} (r : L.Rel k) (v : Fin k → Uprod A 𝓤) : + Tarski.Structure.rel r v ↔ {i | (s i).rel r (fun x ↦ (v x).val i)} ∈ 𝓤 := + of_eq rfl + +end Structure +end Tarski + +namespace Semiterm + +open Tarski.Structure + +variable (e : Fin n → Uprod A 𝓤) (ε : ξ → Uprod A 𝓤) + +lemma val_Uprod (t : Semiterm L ξ n) : + t.val e ε = ⟨fun i ↦ t.val (fun x ↦ (e x).val i) (fun x ↦ (ε x).val i)⟩ := by + induction t <;> simp [*, val_func, Function.comp_def] + +end Semiterm + +open Tarski.Structure + +variable {A} {𝓤} + +namespace Semiformula + +variable {e : Fin n → Uprod A 𝓤} {ε : ξ → Uprod A 𝓤} + +lemma val_vecCons_val_eq {z : Uprod A 𝓤} {i : I} : + (z.val i :> fun x ↦ (e x).val i) = (fun x ↦ ((z :> e) x).val i) := by + simp [Matrix.comp_vecCons (Uprod.val · i), Function.comp_def] + +lemma eval_Uprod [(i : I) → Nonempty (A i)] {φ : Semiformula L ξ n} : + φ.Eval e ε ↔ {i | Eval (fun x ↦ (e x).val i) (fun x ↦ (ε x).val i) φ} ∈ 𝓤 := + by + induction φ using rec' + case hverum => + suffices Set.univ ∈ 𝓤 by simp [*] + exact Filter.univ_mem + case hfalsum => simp + case hrel k r v => simp [Semiterm.val_Uprod, Function.comp_def] + case hnrel k r v => + simpa [*, eval_nrel, Semiterm.val_Uprod, Function.comp_def] using! + Ultrafilter.compl_mem_iff_notMem.symm + case hand => + simpa [*, -Filter.inter_mem_iff, Function.comp_def] using! Filter.inter_mem_iff.symm + case hor φ ψ ihp ihq => + simpa [*, -Ultrafilter.union_mem_iff, Function.comp_def] using! + Ultrafilter.union_mem_iff.symm + case hall φ + _ => + suffices + (∀ x : Uprod A 𝓤, {i | (Eval (fun j ↦ ((x :> e) j).val i) fun x ↦ (ε x).val i) φ} ∈ 𝓤) ↔ + {i | ∀ a : A i, (Eval (a :> fun x ↦ (e x).val i) fun z ↦ (ε z).val i) φ} ∈ 𝓤 + by simp [*] + constructor + · intro h + let z : Uprod A 𝓤 := + ⟨fun i => + Classical.epsilon (fun z => ¬Eval (z :> fun x ↦ (e x).val i) (fun x ↦ (ε x).val i) φ)⟩ + exact + Filter.mem_of_superset (h z) + (by + intro i hι a + have : Eval (z.val i :> fun x ↦ (e x).val i) (fun x ↦ (ε x).val i) φ := by + rw [val_vecCons_val_eq]; exact hι + by_contra hc + have : ¬Eval (M := A i) (z.val i :> fun x ↦ (e x).val i) (fun x ↦ (ε x).val i) φ := + Classical.epsilon_spec (p := fun z ↦ ¬(Eval (z :> fun x ↦ (e x).val i) _ φ)) + ⟨a, hc⟩ + contradiction) + · intro h x + exact + Filter.mem_of_superset h (by intro i h; simpa [val_vecCons_val_eq] using h (x.val i)) + case hexs φ + _ => + suffices + (∃ x, {i | (Eval (fun x_1 ↦ ((x :> e) x_1).val i) fun x ↦ (ε x).val i) φ} ∈ 𝓤) ↔ + {i | ∃ x, (Eval (x :> fun x ↦ (e x).val i) fun x ↦ (ε x).val i) φ} ∈ 𝓤 + by simp [*] + constructor + · rintro ⟨x, hx⟩ + exact + Filter.mem_of_superset hx + (by intro i h; use x.val i; simpa [val_vecCons_val_eq] using h) + · intro h + let z : Uprod A 𝓤 := + ⟨fun i => + Classical.epsilon (fun z => Eval (z :> fun x ↦ (e x).val i) (fun x ↦ (ε x).val i) φ)⟩ + use z + exact + Filter.mem_of_superset h + (by + intro i; rintro ⟨x, hx⟩ + have : Eval (z.val i :> fun x ↦ (e x).val i) (fun x ↦ (ε x).val i) φ := + Classical.epsilon_spec (p := fun z ↦ Eval (z :> fun x ↦ (e x).val i) _ φ) ⟨x, hx⟩ + rw [val_vecCons_val_eq] at this; exact this) + +lemma val_Uprod [(i : I) → Nonempty (A i)] {φ : Formula L ξ} : + Evalf ε φ ↔ {i | Evalf (fun x ↦ (ε x).val i) φ} ∈ 𝓤 := by + simp [Evalf, eval_Uprod, Matrix.empty_eq] + +end Semiformula + +lemma models_Uprod [(i : I) → Nonempty (A i)] {φ : Sentence L} : + (Uprod A 𝓤)↓[L] ⊧ φ ↔ {i | (A i)↓[L] ⊧ φ} ∈ 𝓤 := by + simp [models_iff, Semiformula.val_Uprod, Empty.eq_elim] + +variable (A) + +/-- The domain construction in `FFL.FirstOrder.Sentence`. -/ +def Sentence.domain [(i : I) → Nonempty (A i)] (φ : Sentence L) := + {i | (A i)↓[L] ⊧ φ} + +end + +section + +variable {L : Language.{u}} {T : Theory L} + +/-- The Fin Subtheory construction in `FFL.FirstOrder`. -/ +abbrev FinSubtheory (T : Theory L) := + { t : Finset (Sentence L) // ↑t ⊆ T } + +variable (A : FinSubtheory T → Type u) [s : (i : FinSubtheory T) → Tarski.Structure L (A i)] + +instance : Nonempty (FinSubtheory T) := + ⟨∅, by simp⟩ + +lemma ultrafilter_exists [(t : FinSubtheory T) → Nonempty (A t)] + (H : ∀ (i : FinSubtheory T), (A i)↓[L] ⊧* (i.val : Theory L)) : + ∃ 𝓤 : Ultrafilter (FinSubtheory T), Set.image (Sentence.domain A) T ⊆ 𝓤.sets := + Ultrafilter.exists_ultrafilter_of_finite_inter_nonempty _ + (by + have : DecidableEq (Set (FinSubtheory T)) := fun _ _ => Classical.propDecidable _ + intro t ht + have : ∃ t' : Finset (Sentence L), ↑t' ⊆ T ∧ Finset.image (Sentence.domain A) t' = t := by + simpa [Finset.subset_set_image_iff] using ht + rcases this with ⟨t, htT, rfl⟩ + exact + ⟨⟨t, htT⟩, + by + suffices ∀ i ∈ t, (A ⟨t, htT⟩)↓[L] ⊧ i by simpa [Sentence.domain] using this + intro i hi; exact (H ⟨t, htT⟩).models_set hi⟩) + +lemma compactness_aux : + Satisfiable T ↔ ∀ i : FinSubtheory T, Satisfiable (i.val : Theory L) := by + constructor + · rintro h ⟨t, ht⟩; exact Semantics.Satisfiable.of_subset h ht + · intro h + have : ∀ i : FinSubtheory T, ∃ (M : Type u) (_ : Nonempty M) (_ : Tarski.Structure L M), M + ↓[L] ⊧* (i.val : Theory L) := + by intro i; exact satisfiable_iff.mp (h i) + choose A si s hA using this + have : ∃ 𝓤 : Ultrafilter (FinSubtheory T), Set.image (Sentence.domain A) T ⊆ 𝓤.sets := + ultrafilter_exists A hA + rcases this with ⟨𝓤, h𝓤⟩ + have : (Tarski.Structure.Uprod A 𝓤)↓[L] ⊧* T := ⟨by intro σ hσ; exact models_Uprod.mpr (h𝓤 + <| Set.mem_image_of_mem (Sentence.domain A) hσ)⟩ + exact satisfiable_intro (Tarski.Structure.Uprod A 𝓤) this + + + +theorem compact : + Satisfiable T ↔ ∀ u : Finset (Sentence L), ↑u ⊆ T → Satisfiable (u : Theory L) := by + rw [compactness_aux]; simp + +instance : Compact (Tarski.SmallStruc L) := + ⟨compact⟩ + +end + +end FirstOrder + +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/Logic/Calculus.lean b/LeanPool/PointwiseComposition/Foundation/Logic/Calculus.lean new file mode 100644 index 000000000..cc3d4098c --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/Logic/Calculus.lean @@ -0,0 +1,472 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.Propositional.Entailment.Cl +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Multiset + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# Sequent calculus and variants + +This file defines a characterization of Tait style calculus and Gentzen style calculus. + +## Main Definitions +- `FFL.OneSidedLK` +-/ + +@[expose] public section + +namespace FFL + +/-! +## Structural rules -/ + +/-- Weakening and contraction rules for a multiset-indexed derivation family. -/ +class Structural {F : Type*} (𝔇 : Multiset F → Type*) where + /-- The weakening construction in `FFL.Structural`. -/ + weakening : 𝔇 Γ → 𝔇 (Γ + ⦃φ⦄) + /-- The contraction construction in `FFL.Structural`. -/ + contraction : 𝔇 (Γ + ⦃φ, φ⦄) → 𝔇 (Γ + ⦃φ⦄) + +/-! +## One-sided $\mathbf{LK}$ -/ + +/-- The structural and logical rules of the one-sided classical sequent calculus. -/ +class OneSidedLK {F : Type*} [LogicalConnective F] [LogicalNeutral F] [TildeInvolutive F] + [LogicalConnective.DeMorgan F] [LogicalNeutral.DeMorgan F] (𝔇 : Multiset F → Type*) extends + Structural 𝔇 where + /-- The identity construction in `FFL.OneSidedLK`. -/ + identity (φ) : 𝔇 ⦃φ, ∼φ⦄ + /-- The verum construction in `FFL.OneSidedLK`. -/ + verum : 𝔇 ⦃⊤⦄ + /-- The and construction in `FFL.OneSidedLK`. -/ + and : 𝔇 (Γ + ⦃φ⦄) → 𝔇 (Γ + ⦃ψ⦄) → 𝔇 (Γ + ⦃φ ⋏ ψ⦄) + /-- The or construction in `FFL.OneSidedLK`. -/ + or : 𝔇 (Γ + ⦃φ, ψ⦄) → 𝔇 (Γ + ⦃φ ⋎ ψ⦄) + +/-- Data and laws for Cut in `FFL.OneSidedLK`. -/ +class OneSidedLK.Cut {F : Type*} [LogicalConnective F] [LogicalNeutral F] [TildeInvolutive F] + [LogicalConnective.DeMorgan F] [LogicalNeutral.DeMorgan F] (𝔇 : Multiset F → Type*) extends + OneSidedLK 𝔇 where + /-- The cut construction in `FFL.OneSidedLK.Cut`. -/ + cut : 𝔇 (Γ + ⦃φ⦄) → 𝔇 (Δ + ⦃∼φ⦄) → 𝔇 (Γ + Δ) + +namespace Structural + +variable {F : Type*} {𝔇 : Multiset F → Type*} {Γ Δ : Multiset F} {φ : F} + +/-- The cast construction in `FFL.Structural`. -/ +def cast (d : 𝔇 Γ) (h : Γ = Δ := by abel) : 𝔇 Δ := + h ▸ d + +/-- Repeated weakening along a traversal (a routine structural derivation). -/ +def weakenMany [Structural 𝔇] {Γ Δ : Multiset F} + (t : (PointwiseComposition.Multiset.Traversal Δ)) (d : 𝔇 Γ) : 𝔇 (Γ + Δ) := + match t with + | .zero => cast d + | .succ φ t => cast (weakening (φ := φ) (weakenMany t d)) + +/-- Repeated contraction along a traversal (a routine structural derivation). -/ +def contractMany [Structural 𝔇] {Γ Δ : Multiset F} + (t : (PointwiseComposition.Multiset.Traversal Γ)) (d : 𝔇 (Δ + Γ + Γ)) : 𝔇 (Δ + Γ) := + match t with + | .zero => cast d + | @Multiset.Traversal.succ _ Γ φ t => + have d₁ : 𝔇 ((Δ + Γ + Γ) + ⦃φ, φ⦄) := cast d + have d₂ : 𝔇 ((Δ + ⦃φ⦄) + Γ + Γ) := cast (contraction d₁) + cast (contractMany t d₂) + +/-- Absorbs a formula already in the context (a routine structural derivation). -/ +def absorb [Structural 𝔇] [DecidableEq F] (d : 𝔇 (Γ + ⦃φ⦄)) (h : φ ∈ Γ) : 𝔇 Γ := + have he : Γ.erase φ + ⦃φ⦄ = Γ := by + simpa [Multiset.add_atom_eq_cons] using Multiset.cons_erase h + have d' : 𝔇 (Γ.erase φ + ⦃φ, φ⦄) := + cast d (by simpa [add_assoc] using congrArg (· + ⦃φ⦄) he.symm) + cast (contraction d') he + +/-- Contract a traversed subcontext already contained in the target context. -/ +def contractSubset [Structural 𝔇] [DecidableEq F] {Γ : Multiset F} + (t : PointwiseComposition.Multiset.Traversal Γ) (h : Γ ⊆ Δ) (d : 𝔇 (Δ + Γ)) : 𝔇 Δ := + (match t with + | .zero => cast d + | @Multiset.Traversal.succ _ Γ φ t => + have d' : 𝔇 ((Δ + Γ) + ⦃φ⦄) := cast d + have hp : φ ∈ Δ := h (by simp) + contractSubset t (fun ψ hψ ↦ h (by simp [hψ])) (absorb d' (by simp [hp]))) + +/-- Expands multiset inclusion into local structural rules using traversals. -/ +def ofSubset [Structural 𝔇] [DecidableEq F] (tΓ : PointwiseComposition.Multiset.Traversal Γ) + (tΔ : PointwiseComposition.Multiset.Traversal Δ) (d : 𝔇 Γ) (h : Γ ⊆ Δ) : 𝔇 Δ := + contractSubset tΓ h (cast (weakenMany tΔ d)) + +end Structural + +namespace OneSidedLK + +variable {F : Type*} [LogicalConnective F] [LogicalNeutral F] [TildeInvolutive F] + [LogicalConnective.DeMorgan F] [LogicalNeutral.DeMorgan F] {𝔇 : Multiset F → Type*} + +alias cast := Structural.cast + +alias weakenMany := Structural.weakenMany + +alias ofSubset := Structural.ofSubset + +/-- The contra construction in `FFL.OneSidedLK`. -/ +def contra [OneSidedLK 𝔇] [DecidableEq F] (tΓ : (PointwiseComposition.Multiset.Traversal Γ)) + (tΔ : (PointwiseComposition.Multiset.Traversal Δ)) (d : 𝔇 Γ) (h : Γ ⊆ Δ := by simp) : 𝔇 Δ := + ofSubset tΓ tΔ d h + +/-- The close construction in `FFL.OneSidedLK`. -/ +def close [OneSidedLK 𝔇] [DecidableEq F] (φ : F) + (t : (PointwiseComposition.Multiset.Traversal Γ)) (hp : φ ∈ Γ := by simp) + (hn : ∼φ ∈ Γ := by simp) : 𝔇 Γ := + contra ((Multiset.Traversal.atom φ).succ (∼φ)) t (identity φ) + (by + intro ψ hψ + rcases Multiset.mem_add.mp hψ with hψ | hψ <;> simp_all) + +/-- The top construction in `FFL.OneSidedLK`. -/ +def top [OneSidedLK 𝔇] [DecidableEq F] (t : (PointwiseComposition.Multiset.Traversal Γ)) + (h : ⊤ ∈ Γ := by simp) : 𝔇 Γ := + contra (.atom ⊤) t verum (by simpa using h) + +/-- The tensor construction in `FFL.OneSidedLK`. -/ +def tensor [OneSidedLK 𝔇] {φ ψ : F} (tΓ : (PointwiseComposition.Multiset.Traversal Γ)) + (tΔ : (PointwiseComposition.Multiset.Traversal Δ)) (dφ : 𝔇 (Γ + ⦃φ⦄)) (dψ : 𝔇 (Δ + ⦃ψ⦄)) : + 𝔇 (Γ + Δ + ⦃φ ⋏ ψ⦄) := + and (cast (weakenMany tΔ dφ) (by abel)) (cast (weakenMany tΓ dψ) (by abel)) + +alias cut := OneSidedLK.Cut.cut + +/-- The e Cut construction in `FFL.OneSidedLK`. -/ +def eCut [Cut 𝔇] (d₁ : 𝔇 (Γ + ⦃φ⦄)) (d₂ : 𝔇 (Δ + ⦃ψ⦄)) (e : ∼φ = ψ := by simp) : 𝔇 (Γ + Δ) := + cut d₁ (cast d₂ (by simp [e])) + +/-- Eliminating falsum is the routine cut against the verum rule. -/ +def removeBot [Cut 𝔇] (d : 𝔇 (Γ + ⦃⊥⦄)) : 𝔇 Γ := + have dt : 𝔇 ((0 : Multiset F) + ⦃∼⊥⦄) := cast verum (by simp) + cast <| cut (φ := ⊥) (Γ := Γ) (Δ := 0) d dt + +/-- Modus ponens with independent side contexts. This is the routine cut derivation. -/ +def modusPonens [Cut 𝔇] (di : 𝔇 (Γ + ⦃φ ⇒ₗ ψ⦄)) (dp : 𝔇 (Δ + ⦃φ⦄)) : 𝔇 (Γ + Δ + ⦃ψ⦄) := + have h₁ : 𝔇 ⦃∼(φ ⇒ₗ ψ), ∼φ, ψ⦄ := + cast + (tensor (𝔇 := 𝔇) (Γ := ⦃∼φ⦄) (Δ := ⦃ψ⦄) (φ := φ) (ψ := ∼ψ) (.atom _) (.atom _) + (cast (identity φ) (by abel)) (cast (identity (∼ψ)) (by simp; abel))) + (by simp [LogicalConnective.DeMorgan.imply]; abel) + have h₂ : 𝔇 (Γ + ⦃∼φ, ψ⦄) := cast <| cut (φ := φ ⇒ₗ ψ) (Γ := Γ) (Δ := ⦃∼φ, ψ⦄) di (cast h₁) + cast <| cut (φ := φ) (Γ := Δ) (Δ := Γ + ⦃ψ⦄) dp (cast h₂) + +/-- The disj₂ construction in `FFL.OneSidedLK`. -/ +def disj₂ {Γ : List F} {Δ : Multiset F} [OneSidedLK 𝔇] : + 𝔇 ((Γ : Multiset F) + Δ) → 𝔇 (Δ + ⦃⋁Γ⦄) := fun d ↦ + match Γ with + | [] => cast (Structural.weakening (φ := ⊥) (cast d (by simp) : 𝔇 Δ)) (by simp) + | [φ] => + cast d + (by + change φ ::ₘ Δ = Δ + ⦃φ⦄ + exact (Multiset.add_atom_eq_cons φ Δ).symm) + | φ :: ψ :: Γ => + by + have dt : 𝔇 ((Δ + ⦃φ⦄) + ⦃⋁(ψ :: Γ)⦄) := + disj₂ + (cast d + (by + change (φ ::ₘ (↑(ψ :: Γ) : Multiset F)) + Δ = (↑(ψ :: Γ) : Multiset F) + (Δ + ⦃φ⦄) + rw [← Multiset.add_atom_eq_cons] + abel)) + exact or (Γ := Δ) (φ := φ) (ψ := ⋁(ψ :: Γ)) (cast dt (by abel)) +termination_by _ => Γ.length + +/-- The conj₂ construction in `FFL.OneSidedLK`. -/ +def conj₂ [OneSidedLK 𝔇] {Γ : List F} {Δ : Multiset F} + (tΔ : (PointwiseComposition.Multiset.Traversal Δ)) (d : (φ : F) → φ ∈ Γ → 𝔇 (Δ + ⦃φ⦄)) : + 𝔇 (Δ + ⦃⋀Γ⦄) := + match Γ with + | [] => cast (weakenMany tΔ verum) (by simp; abel) + | [φ] => d φ (by simp) + | φ :: ψ :: Γ => + have : 𝔇 (Δ + ⦃⋀(ψ :: Γ)⦄) := conj₂ (Γ := ψ :: Γ) tΔ (fun χ h ↦ d χ (by simp_all)) + and (Γ := Δ) (φ := φ) (ψ := ⋀(ψ :: Γ)) (d φ (by simp)) this + +namespace AxiomDerivation + +variable [OneSidedLK 𝔇] + +/-- The identity With construction in `FFL.OneSidedLK.AxiomDerivation`. -/ +def identityWith (φ : F) (t : (PointwiseComposition.Multiset.Traversal Γ)) : 𝔇 (Γ + ⦃φ, ∼φ⦄) := + cast (Structural.weakenMany t (identity φ)) + +/-- The intro Or construction in `FFL.OneSidedLK.AxiomDerivation`. -/ +def introOr (d : 𝔇 ⦃φ, ψ⦄) : 𝔇 ⦃φ ⋎ ψ⦄ := + cast (or (Γ := 0) (φ := φ) (ψ := ψ) (cast d (by abel))) (by simp) + +/-- The intro Disj construction in `FFL.OneSidedLK.AxiomDerivation`. -/ +def introDisj {Γ : List F} (d : 𝔇 (Γ : Multiset F)) : 𝔇 ⦃⋁Γ⦄ := + cast <| disj₂ (Γ := Γ) (Δ := 0) (cast d) + +/-- +The rule expansion of the classical negation equivalence axiom. This is a routine syntactic +derivation. -/ +def negEquiv (φ : F) : 𝔇 ⦃(φ ⋎ ∼φ ⋎ ⊥) ⋏ (φ ⋏ ⊤ ⋎ ∼φ)⦄ := + have d₁ : 𝔇 ⦃φ ⋎ ∼φ ⋎ ⊥⦄ := + introDisj (Γ := [φ, ∼φ, ⊥]) <| + cast (identityWith φ (.atom ⊥)) (by change ⦃⊥⦄ + ⦃φ, ∼φ⦄ = ⦃φ, ∼φ, ⊥⦄; abel) + have dp : 𝔇 ⦃∼φ, φ⦄ := cast (identity φ) + have dt : 𝔇 ⦃∼φ, ⊤⦄ := cast (Structural.weakening (φ := ∼φ) verum) + have dc : 𝔇 ⦃∼φ, φ ⋏ ⊤⦄ := cast <| and (Γ := ⦃∼φ⦄) (φ := φ) (ψ := ⊤) (cast dp) (cast dt) + cast <| + and (Γ := 0) (φ := φ ⋎ ∼φ ⋎ ⊥) (ψ := φ ⋏ ⊤ ⋎ ∼φ) (cast d₁) + (cast <| introOr (φ := φ ⋏ ⊤) (ψ := ∼φ) <| cast dc (by abel)) + +/-- The rule expansion of the K axiom. This is a routine syntactic derivation. -/ +def implyK (φ ψ : F) : 𝔇 ⦃∼φ ⋎ ∼ψ ⋎ φ⦄ := + introDisj (Γ := [∼φ, ∼ψ, φ]) <| + cast (identityWith φ (.atom (∼ψ))) (by change ⦃∼ψ⦄ + ⦃φ, ∼φ⦄ = ⦃∼φ, ∼ψ, φ⦄; abel) + +/-- The rule expansion of the S axiom. This is a routine syntactic derivation. -/ +def implyS (φ ψ χ : F) : 𝔇 ⦃φ ⋏ ψ ⋏ ∼χ ⋎ φ ⋏ ∼ψ ⋎ ∼φ ⋎ χ⦄ := + let A := φ ⋏ ψ ⋏ ∼χ + let B := φ ⋏ ∼ψ + let C := ∼φ + let D := χ + have dφ : 𝔇 (⦃B, C, D⦄ + ⦃φ⦄) := + cast (identityWith φ ((Multiset.Traversal.atom B).succ D)) (by dsimp [C]; abel) + have dbp : 𝔇 (⦃C, D, ψ⦄ + ⦃φ⦄) := + cast (identityWith φ ((Multiset.Traversal.atom D).succ ψ)) (by dsimp [C]; abel) + have dbn : 𝔇 (⦃C, D, ψ⦄ + ⦃∼ψ⦄) := cast (identityWith ψ ((Multiset.Traversal.atom C).succ D)) + have dψ : 𝔇 (⦃B, C, D⦄ + ⦃ψ⦄) := cast <| and (Γ := ⦃C, D, ψ⦄) (φ := φ) (ψ := ∼ψ) dbp dbn + have dnχ : 𝔇 (⦃B, C, D⦄ + ⦃∼χ⦄) := + cast (identityWith χ ((Multiset.Traversal.atom B).succ C)) (by dsimp [D]; abel) + have dr : 𝔇 (⦃B, C, D⦄ + ⦃ψ ⋏ ∼χ⦄) := and (φ := ψ) (ψ := ∼χ) dψ dnχ + have da : 𝔇 ⦃A, B, C, D⦄ := cast <| and (φ := φ) (ψ := ψ ⋏ ∼χ) dφ dr + introDisj da + +/-- +The rule expansion of the first conjunction axiom. This is a routine syntactic derivation. -/ +def and₁ (φ ψ : F) : 𝔇 ⦃(∼φ ⋎ ∼ψ) ⋎ φ⦄ := + introOr <| cast <| or (Γ := ⦃φ⦄) (φ := ∼φ) (ψ := ∼ψ) (cast <| identityWith φ (.atom (∼ψ))) + +/-- +The rule expansion of the second conjunction axiom. This is a routine syntactic derivation. -/ +def and₂ (φ ψ : F) : 𝔇 ⦃(∼φ ⋎ ∼ψ) ⋎ ψ⦄ := + introOr <| cast <| or (Γ := ⦃ψ⦄) (φ := ∼φ) (ψ := ∼ψ) (cast <| identityWith ψ (.atom (∼φ))) + +/-- The rule expansion of conjunction introduction. This is a routine syntactic derivation. -/ +def and₃ (φ ψ : F) : 𝔇 ⦃∼φ ⋎ ∼ψ ⋎ φ ⋏ ψ⦄ := + have dp : 𝔇 ⦃∼φ, ∼ψ, φ⦄ := cast (identityWith φ (.atom (∼ψ))) + have dq : 𝔇 ⦃∼φ, ∼ψ, ψ⦄ := cast (identityWith ψ (.atom (∼φ))) + introDisj (Γ := [∼φ, ∼ψ, φ ⋏ ψ]) <| + cast <| and (Γ := ⦃∼φ, ∼ψ⦄) (φ := φ) (ψ := ψ) (cast dp (by abel)) (cast dq (by abel)) + +/-- +The rule expansion of the first disjunction axiom. This is a routine syntactic derivation. -/ +def or₁ (φ ψ : F) : 𝔇 ⦃∼φ ⋎ φ ⋎ ψ⦄ := + introDisj (Γ := [∼φ, φ, ψ]) <| + cast (identityWith φ (.atom ψ)) (by change ⦃ψ⦄ + ⦃φ, ∼φ⦄ = ⦃∼φ, φ, ψ⦄; abel) + +/-- +The rule expansion of the second disjunction axiom. This is a routine syntactic derivation. -/ +def or₂ (φ ψ : F) : 𝔇 ⦃∼ψ ⋎ φ ⋎ ψ⦄ := + introDisj (Γ := [∼ψ, φ, ψ]) <| + cast (identityWith ψ (.atom φ)) (by change ⦃φ⦄ + ⦃ψ, ∼ψ⦄ = ⦃∼ψ, φ, ψ⦄; abel) + +/-- The rule expansion of disjunction elimination. This is a routine syntactic derivation. -/ +def or₃ (φ ψ χ : F) : 𝔇 ⦃φ ⋏ ∼χ ⋎ ψ ⋏ ∼χ ⋎ ∼φ ⋏ ∼ψ ⋎ χ⦄ := + let A := φ ⋏ ∼χ + let B := ψ ⋏ ∼χ + let C := ∼φ ⋏ ∼ψ + let D := χ + have dap : 𝔇 (⦃B, D, ∼φ⦄ + ⦃φ⦄) := cast (identityWith φ ((Multiset.Traversal.atom B).succ D)) + have dan : 𝔇 (⦃B, D, ∼φ⦄ + ⦃∼χ⦄) := + cast (identityWith χ ((Multiset.Traversal.atom B).succ (∼φ))) (by dsimp [D]; abel) + have dnp : 𝔇 (⦃A, B, D⦄ + ⦃∼φ⦄) := cast <| and (φ := φ) (ψ := ∼χ) dap dan + have dbp : 𝔇 (⦃A, D, ∼ψ⦄ + ⦃ψ⦄) := cast (identityWith ψ ((Multiset.Traversal.atom A).succ D)) + have dbn : 𝔇 (⦃A, D, ∼ψ⦄ + ⦃∼χ⦄) := + cast (identityWith χ ((Multiset.Traversal.atom A).succ (∼ψ))) (by dsimp [D]; abel) + have dnn : 𝔇 (⦃A, B, D⦄ + ⦃∼ψ⦄) := cast <| and (φ := ψ) (ψ := ∼χ) dbp dbn + have dc : 𝔇 ⦃A, B, C, D⦄ := cast <| and (φ := ∼φ) (ψ := ∼ψ) dnp dnn + introDisj dc + +/-- +The rule expansion of double-negation elimination. This is a routine syntactic derivation. -/ +def dne (φ : F) : 𝔇 ⦃∼φ ⋎ φ⦄ := + introOr <| cast (identity φ) + +end AxiomDerivation + +open Entailment + +/-- A one-sided classical calculus induces classical entailment whenever singleton +derivations can be embedded as proofs. This is the routine translation of the +Hilbert axioms into one-sided sequent rules. -/ +abbrev AxiomDerivation.cl {P : Type*} [Entailment P F] (𝓟 : P) [Entailment.ModusPonens 𝓟] + [OneSidedLK 𝔇] (lift : ∀ {φ}, 𝔇 ⦃φ⦄ → 𝓟 ⊢! φ) : Entailment.Cl 𝓟 + where + negEquivProof + {φ} := + Entailment.cast + (show 𝓟 ⊢! (φ ⋎ ∼φ ⋎ ⊥) ⋏ (φ ⋏ ⊤ ⋎ ∼φ) from lift <| AxiomDerivation.negEquiv φ) + (by simp [Axioms.NegEquiv, LogicalConnective.DeMorgan.imply, LogicalConnective.iff]) + verumProof := lift verum + implyKProof + {φ + ψ} := + Entailment.cast (lift <| AxiomDerivation.implyK φ ψ) + (by simp [LogicalConnective.DeMorgan.imply]) + implySProof + {φ ψ + χ} := + Entailment.cast (lift <| AxiomDerivation.implyS φ ψ χ) + (by simp [LogicalConnective.DeMorgan.imply]) + and₁Proof + {φ + ψ} := + Entailment.cast (lift <| AxiomDerivation.and₁ φ ψ) + (by simp [LogicalConnective.DeMorgan.imply]) + and₂Proof + {φ + ψ} := + Entailment.cast (lift <| AxiomDerivation.and₂ φ ψ) + (by simp [LogicalConnective.DeMorgan.imply]) + and₃Proof + {φ + ψ} := + Entailment.cast (lift <| AxiomDerivation.and₃ φ ψ) + (by simp [LogicalConnective.DeMorgan.imply]) + or₁Proof + {φ + ψ} := + Entailment.cast (lift <| AxiomDerivation.or₁ φ ψ) + (by simp [LogicalConnective.DeMorgan.imply]) + or₂Proof + {φ + ψ} := + Entailment.cast (lift <| AxiomDerivation.or₂ φ ψ) + (by simp [LogicalConnective.DeMorgan.imply]) + or₃Proof + {φ ψ + χ} := + Entailment.cast (lift <| AxiomDerivation.or₃ φ ψ χ) + (by simp [LogicalConnective.DeMorgan.imply]) + dneProof + {φ} := + Entailment.cast (lift <| AxiomDerivation.dne φ) (by simp [LogicalConnective.DeMorgan.imply]) + +/-- An entailment relation which is determined solely by derivability. -/ +class PrincipalEntailment (𝔇 : outParam (Multiset F → Type*)) {P : Type*} [Entailment P F] + (𝓟 : P) where + /-- The equiv construction in `FFL.OneSidedLK.PrincipalEntailment`. -/ + equiv {φ} : 𝓟 ⊢! φ ≃ 𝔇 ⦃φ⦄ + +namespace PrincipalEntailment + +variable {P : Type*} [Entailment P F] {𝓟 : P} [PrincipalEntailment 𝔇 𝓟] + +omit [LogicalConnective F] [LogicalNeutral F] [LogicalConnective.DeMorgan F] + [LogicalNeutral.DeMorgan F] in +lemma provable_iff : 𝓟 ⊢ φ ↔ Nonempty (𝔇 ⦃φ⦄) := by + simpa using! OneSidedLK.PrincipalEntailment.equiv.nonempty_congr + +variable [OneSidedLK.Cut 𝔇] (𝓟) + +instance : Entailment.ModusPonens 𝓟 where + mdpProof {φ ψ} b₁ + b₂ := equiv.symm <| cast <| modusPonens (Γ := 0) (Δ := 0) (equiv b₁) (equiv b₂) + +instance : Entailment.Cl 𝓟 := + AxiomDerivation.cl 𝓟 PrincipalEntailment.equiv.symm + +variable {𝓟} + +lemma derivable_iff_provable_disj {Γ : List F} : Nonempty (𝔇 (Γ : Multiset F)) ↔ 𝓟 ⊢ ⋁Γ := by + classical + constructor + · rintro ⟨d⟩ + have : 𝔇 ((Γ : Multiset F) + 0) := cast d + exact provable_iff.mpr ⟨disj₂ this⟩ + · rintro h + have d₁ : 𝔇 ⦃⋁Γ⦄ := (provable_iff.mp h).some + have d₂ : 𝔇 ((Γ : Multiset F) + ⦃⋀(∼Γ)⦄) := + conj₂ (.ofList Γ) fun φ h ↦ + close φ ((Multiset.Traversal.ofList Γ).succ φ) (by simp) (by simp_all) + exact ⟨cast (eCut (Γ := 0) (Δ := (Γ : Multiset F)) d₁ d₂)⟩ + +end PrincipalEntailment + +/-- The Pullback construction in `FFL.OneSidedLK`. -/ +abbrev Pullback (𝔇 : Multiset F → Type*) {G : Type*} [LogicalConnective G] [LogicalNeutral G] + (f : G →ˡᶜ F) : Multiset G → Type _ := fun Γ ↦ 𝔇 (Γ.map f) + +namespace Pullback + +variable {G : Type*} [LogicalConnective G] [LogicalNeutral G] [TildeInvolutive G] + [LogicalConnective.DeMorgan G] [LogicalNeutral.DeMorgan G] {f : G →ˡᶜ F} + +/-- The cast construction in `FFL.OneSidedLK.Pullback`. -/ +def cast (d : 𝔇 Δ) (h : Δ = Γ.map f := by simp) : Pullback 𝔇 f Γ := + by + unfold Pullback + exact h ▸ d + +/-- The uncast construction in `FFL.OneSidedLK.Pullback`. -/ +def uncast (d : Pullback 𝔇 f Γ) (h : Δ = Γ.map f := by simp) : 𝔇 Δ := + h ▸ d + +instance oneSidedLK [OneSidedLK 𝔇] : OneSidedLK (Pullback 𝔇 f) + where + weakening {Γ φ} + d := cast <| Structural.weakening (Γ := Γ.map f) (φ := f φ) (uncast d (by simp)) + contraction {Γ φ} + d := cast <| Structural.contraction (Γ := Γ.map f) (φ := f φ) (uncast d (by simp)) + identity φ := cast <| identity (𝔇 := 𝔇) (f φ) + verum := cast verum + and {Γ φ ψ} d₁ + d₂ := + cast <| and (Γ := Γ.map f) (φ := f φ) (ψ := f ψ) (uncast d₁ (by simp)) (uncast d₂ (by simp)) + or {Γ φ ψ} d := cast <| or (Γ := Γ.map f) (φ := f φ) (ψ := f ψ) (uncast d (by simp)) + +instance cut [Cut 𝔇] : Cut (Pullback 𝔇 f) where + cut {Γ φ Δ} bp + bn := + have bp : 𝔇 (Γ.map f + ⦃f φ⦄) := uncast bp + have bn : 𝔇 (Δ.map f + ⦃∼f φ⦄) := uncast bn + cast (Cut.cut (φ := f φ) bp bn) + +instance {P : Type*} [Entailment P F] (𝓟 : P) [PrincipalEntailment 𝔇 𝓟] : + PrincipalEntailment (Pullback 𝔇 f) (Entailment.pullback 𝓟 f) where + equiv {φ} := PrincipalEntailment.equiv (φ := f φ) + +omit [TildeInvolutive F] [LogicalConnective.DeMorgan F] [LogicalNeutral.DeMorgan F] + [TildeInvolutive G] [LogicalConnective.DeMorgan G] [LogicalNeutral.DeMorgan G] in +@[simp] +lemma nonempty_iff {Γ} : Nonempty (Pullback 𝔇 f Γ) ↔ Nonempty (𝔇 (Γ.map f)) := by + simp [Pullback] + +omit [TildeInvolutive F] [LogicalConnective.DeMorgan F] [LogicalNeutral.DeMorgan F] + [TildeInvolutive G] [LogicalConnective.DeMorgan G] [LogicalNeutral.DeMorgan G] in +@[simp] +lemma isEmpty_iff {Γ} : IsEmpty (Pullback 𝔇 f Γ) ↔ IsEmpty (𝔇 (Γ.map f)) := by simp [Pullback] + +end Pullback + +end OneSidedLK + +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/Logic/Entailment.lean b/LeanPool/PointwiseComposition/Foundation/Logic/Entailment.lean new file mode 100644 index 000000000..ce45f77e7 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/Logic/Entailment.lean @@ -0,0 +1,785 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.Logic.Semantics +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.AdjunctiveSet + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# Basic definitions and properties of proof system related notions + +This file defines a characterization of the system/proof/provability/calculus of formulae. +Also defines soundness and completeness. + +## Main Definitions +* `FFL.Entailment S F`: a general framework of deductive system `S` for formulae `F`. +* `FFL.Entailment.Inconsistent 𝓢`: a proposition that states that all formulae in `F` is +provable from `𝓢`. +* `FFL.Entailment.Consistent 𝓢`: a proposition that states that `𝓢` is not inconsistent. +* `FFL.Entailment.Sound 𝓢 𝓜`: provability from `𝓢` implies satisfiability on `𝓜`. +* `FFL.Entailment.Complete 𝓢 𝓜`: satisfiability on `𝓜` implies provability from `𝓢`. + +## Notation +* `𝓢 ⊢! φ`: a type of formalized proofs of `φ : F` from deductive system `𝓢 : S`. +* `𝓢 ⊢ φ`: a proposition that states there is a proof of `φ` from `𝓢`, i.e. `φ` is provable from +`𝓢`. +* `𝓢 ⊬ φ`: a proposition that states `φ` is not provable from `𝓢`. +* `𝓢 ⊢!* T`: a type of formalized proofs for each formulae in a set `T` from `𝓢`. +* `𝓢 ⊢* T`: a proposition that states each formulae in `T` is provable from `𝓢`. + +-/ + +@[expose] public section + +namespace FFL + +/-- Entailment relation on proof system `S` and formula `F` -/ +class Entailment (S : Type*) (F : outParam Type*) where + /-- The Prf construction in `FFL.Entailment`. -/ + Prf : S → F → Type* + +/-- The «term ⊢! » construction in `FFL`. -/ +infix:45 " ⊢! " => Entailment.Prf + +namespace Entailment + +variable {F : Type*} {S T U : Type*} [Entailment S F] [Entailment T F] [Entailment U F] + +section + +variable (𝓢 : S) + +/-- Proposition that states `φ` is provable. -/ +def Provable (φ : F) : Prop := + Nonempty (𝓢 ⊢! φ) + +/-- Abbreviation for unprovability. -/ +abbrev Unprovable (φ : F) : Prop := + ¬Provable 𝓢 φ + +/-- The «term ⊢ » construction in `FFL.Entailment`. -/ +infix:45 " ⊢ " => Provable + +/-- The «term ⊬ » construction in `FFL.Entailment`. -/ +infix:45 " ⊬ " => Unprovable + +/-- Proofs of set of formulae. -/ +def PrfSet (s : Set F) : Type _ := + ⦃φ : F⦄ → φ ∈ s → 𝓢 ⊢! φ + +/-- Proposition for existance of proofs of set of formulae. -/ +def ProvableSet (s : Set F) : Prop := + ∀ {φ}, φ ∈ s → 𝓢 ⊢ φ + +/-- The «term ⊢!* » construction in `FFL.Entailment`. -/ +infix:45 " ⊢!* " => PrfSet + +/-- The «term ⊢* » construction in `FFL.Entailment`. -/ +infix:45 " ⊢* " => ProvableSet + +/-- Set of all provable formulae. -/ +def theory : Set F := + {φ | 𝓢 ⊢ φ} + +end + +/-- The cast construction in `FFL.Entailment`. -/ +def cast {𝓢 : S} {φ ψ : F} (b : 𝓢 ⊢! φ) (e : φ = ψ := by simp) : 𝓢 ⊢! ψ := + e ▸ b + +@[grind ⇒] +lemma castProof {𝓢 : S} {φ ψ : F} (b : 𝓢 ⊢ φ) (e : φ = ψ := by simp) : 𝓢 ⊢ ψ := + ⟨cast b.some e⟩ + +lemma unprovable_iff_isEmpty {𝓢 : S} {φ : F} : 𝓢 ⊬ φ ↔ IsEmpty (𝓢 ⊢! φ) := by + simp [Provable, Unprovable] + +/-- The get construction in `FFL.Entailment.Provable`. -/ +noncomputable def Provable.get {𝓢 : S} {φ : F} (h : 𝓢 ⊢ φ) : 𝓢 ⊢! φ := + Classical.choice h + +lemma provableSet_iff {𝓢 : S} {s : Set F} : 𝓢 ⊢* s ↔ Nonempty (𝓢 ⊢!* s) := by + simp [ProvableSet, PrfSet, Provable, Classical.nonempty_pi, ← imp_iff_not_or] + +/-- The get construction in `FFL.Entailment.ProvableSet`. -/ +noncomputable def ProvableSet.get {𝓢 : S} {s : Set F} (h : 𝓢 ⊢* s) : 𝓢 ⊢!* s := + Classical.choice (α := 𝓢 ⊢!* s) (provableSet_iff.mp h : Nonempty (𝓢 ⊢!* s)) + +/-- Provability strength relation of proof systems -/ +class WeakerThan (𝓢 : S) (𝓣 : T) : Prop where + subset : theory 𝓢 ⊆ theory 𝓣 + +/-- The «term ≼ » construction in `FFL.Entailment`. -/ +infix:40 " ≼ " => WeakerThan + +/-- Strict provability strength relation of proof systems -/ +class StrictlyWeakerThan (𝓢 : S) (𝓣 : T) : Prop where + weakerThan : 𝓢 ≼ 𝓣 + notWT : ¬𝓣 ≼ 𝓢 + +/-- The «term ≺ » construction in `FFL.Entailment`. -/ +infix:40 " ≺ " => StrictlyWeakerThan + +/-- Provability equivalence relation of proof systems -/ +class Equiv (𝓢 : S) (𝓣 : T) : Prop where + eq : theory 𝓢 = theory 𝓣 + +/-- The «term ≊ » construction in `FFL.Entailment`. -/ +infix:40 " ≊ " => Equiv + +/-! +### Provability strength -/ + +section WeakerThan + +variable {𝓢 : S} {𝓣 : T} {𝓤 : U} + +@[instance, simp, refl] +protected lemma WeakerThan.refl (𝓢 : S) : 𝓢 ≼ 𝓢 := + ⟨Set.Subset.refl _⟩ + +lemma WeakerThan.wk (h : 𝓢 ≼ 𝓣) {φ} : 𝓢 ⊢ φ → 𝓣 ⊢ φ := + @h.subset φ + +lemma WeakerThan.pbl [h : 𝓢 ≼ 𝓣] {φ} : 𝓢 ⊢ φ → 𝓣 ⊢ φ := + @h.subset φ + +@[trans] +lemma WeakerThan.trans : 𝓢 ≼ 𝓣 → 𝓣 ≼ 𝓤 → 𝓢 ≼ 𝓤 := fun w₁ w₂ ↦ + ⟨Set.Subset.trans w₁.subset w₂.subset⟩ + +instance : Trans (α := S) (β := T) (γ := U) (· ≼ ·) (· ≼ ·) (· ≼ ·) where + trans := WeakerThan.trans + +lemma weakerThan_iff : 𝓢 ≼ 𝓣 ↔ (∀ {φ}, 𝓢 ⊢ φ → 𝓣 ⊢ φ) := + ⟨fun h _ hf ↦ h.subset hf, fun h ↦ ⟨fun _ hf ↦ h hf⟩⟩ + +lemma not_weakerThan_iff : ¬𝓢 ≼ 𝓣 ↔ (∃ φ, 𝓢 ⊢ φ ∧ 𝓣 ⊬ φ) := by + simp [weakerThan_iff, Unprovable]; + +lemma strictlyWeakerThan_iff : 𝓢 ≺ 𝓣 ↔ (∀ {φ}, 𝓢 ⊢ φ → 𝓣 ⊢ φ) ∧ (∃ φ, 𝓢 ⊬ φ ∧ 𝓣 ⊢ φ) := + by + constructor + · rintro ⟨wt, nwt⟩ + obtain ⟨φ, ht, hs⟩ := not_weakerThan_iff.mp nwt + exact ⟨weakerThan_iff.mp wt, φ, hs, ht⟩ + · rintro ⟨h, φ, hs, ht⟩ + exact ⟨weakerThan_iff.mpr h, not_weakerThan_iff.mpr ⟨φ, ht, hs⟩⟩ + +lemma swt_of_swt_of_wt : 𝓢 ≺ 𝓣 → 𝓣 ≼ 𝓤 → 𝓢 ≺ 𝓤 := + by + rintro ⟨h₁, nh₁⟩ h₂ + constructor + · exact WeakerThan.trans h₁ h₂ + · intro h + exact nh₁ (WeakerThan.trans h₂ h) + +lemma swt_of_wt_of_swt : 𝓢 ≼ 𝓣 → 𝓣 ≺ 𝓤 → 𝓢 ≺ 𝓤 := + by + rintro h₁ ⟨h₂, nh₂⟩ + constructor + · exact WeakerThan.trans h₁ h₂ + · intro h + exact nh₂ (WeakerThan.trans h h₁) + +instance [𝓢 ≺ 𝓣] : 𝓢 ≼ 𝓣 := + StrictlyWeakerThan.weakerThan + +lemma StrictlyWeakerThan.trans : 𝓢 ≺ 𝓣 → 𝓣 ≺ 𝓤 → 𝓢 ≺ 𝓤 := fun h₁ h₂ ↦ + swt_of_swt_of_wt h₁ h₂.weakerThan + +instance : Trans (α := S) (β := T) (γ := U) (· ≺ ·) (· ≼ ·) (· ≺ ·) where + trans := swt_of_swt_of_wt + +instance : Trans (α := S) (β := T) (γ := U) (· ≼ ·) (· ≺ ·) (· ≺ ·) where + trans := swt_of_wt_of_swt + +instance : Trans (α := S) (β := T) (γ := U) (· ≺ ·) (· ≺ ·) (· ≺ ·) where + trans := StrictlyWeakerThan.trans + +lemma weakening (h : 𝓢 ≼ 𝓣) {φ} : 𝓢 ⊢ φ → 𝓣 ⊢ φ := + weakerThan_iff.mp h + +lemma StrictlyWeakerThan.of_unprovable_provable {𝓢 : S} {𝓣 : T} [𝓢 ≼ 𝓣] {φ : F} (hS : 𝓢 ⊬ φ) + (hT : 𝓣 ⊢ φ) : 𝓢 ≺ 𝓣 := + ⟨inferInstance, fun h ↦ hS (h.wk hT)⟩ + +lemma Equiv.iff : 𝓢 ≊ 𝓣 ↔ (∀ φ, 𝓢 ⊢ φ ↔ 𝓣 ⊢ φ) := + ⟨fun e ↦ by simpa [Set.ext_iff, theory] using e.eq, fun e ↦ + ⟨by simpa [Set.ext_iff, theory] using e⟩⟩ + +@[instance, simp, refl] +protected lemma Equiv.refl (𝓢 : S) : 𝓢 ≊ 𝓢 := + ⟨rfl⟩ + +@[symm, grind .] +lemma Equiv.symm : 𝓢 ≊ 𝓣 → 𝓣 ≊ 𝓢 := fun e ↦ ⟨Eq.symm e.eq⟩ + +@[trans] +lemma Equiv.trans : 𝓢 ≊ 𝓣 → 𝓣 ≊ 𝓤 → 𝓢 ≊ 𝓤 := fun e₁ e₂ ↦ ⟨Eq.trans e₁.eq e₂.eq⟩ + +@[grind =] +lemma Equiv.antisymm_iff : 𝓢 ≊ 𝓣 ↔ 𝓢 ≼ 𝓣 ∧ 𝓣 ≼ 𝓢 := + by + constructor + · intro e + exact ⟨⟨Set.Subset.antisymm_iff.mp e.eq |>.1⟩, ⟨Set.Subset.antisymm_iff.mp e.eq |>.2⟩⟩ + · rintro ⟨w₁, w₂⟩ + exact ⟨Set.Subset.antisymm w₁.subset w₂.subset⟩ + +alias ⟨_, Equiv.antisymm⟩ := Equiv.antisymm_iff + +@[grind ->] +lemma Equiv.le : 𝓢 ≊ 𝓣 → 𝓢 ≼ 𝓣 := fun e ↦ ⟨by rw [e.eq]⟩ + +instance : Trans (α := S) (β := T) (γ := U) (· ≊ ·) (· ≊ ·) (· ≊ ·) where trans := Equiv.trans + +instance : Trans (α := S) (β := T) (γ := U) (· ≊ ·) (· ≼ ·) (· ≼ ·) where + trans h₁ h₂ := WeakerThan.trans h₁.le h₂ + +instance : Trans (α := S) (β := T) (γ := U) (· ≊ ·) (· ≊ ·) (· ≼ ·) where + trans h₁ h₂ := WeakerThan.trans h₁.le h₂.le + +instance : Trans (α := S) (β := T) (γ := U) (· ≼ ·) (· ≊ ·) (· ≼ ·) where + trans h₁ h₂ := WeakerThan.trans h₁ h₂.le + +instance : Trans (α := S) (β := T) (γ := U) (· ≊ ·) (· ≺ ·) (· ≺ ·) where + trans h₁ h₂ := swt_of_wt_of_swt h₁.le h₂ + +instance : Trans (α := S) (β := T) (γ := U) (· ≺ ·) (· ≊ ·) (· ≺ ·) where + trans h₁ h₂ := swt_of_swt_of_wt h₁ h₂.le + +@[grind =] +lemma iff_strictlyWeakerThan_weakerThan_not_equiv : 𝓢 ≺ 𝓣 ↔ 𝓢 ≼ 𝓣 ∧ ¬(𝓢 ≊ 𝓣) := + by + constructor + · rintro ⟨_, _⟩; grind; + · rintro ⟨_, _⟩; constructor <;> grind; + +/-- Data and laws for Incomparable in `FFL.Entailment`. -/ +class Incomparable (𝓢 : S) (𝓣 : T) where + notWT₁ : ¬𝓢 ≼ 𝓣 + notWT₂ : ¬𝓣 ≼ 𝓢 + +lemma Incomparable.of_unprovable (h₁ : ∃ φ, 𝓢 ⊢ φ ∧ 𝓣 ⊬ φ) (h₂ : ∃ ψ, 𝓣 ⊢ ψ ∧ 𝓢 ⊬ ψ) : + Incomparable (𝓢 : S) (𝓣 : T) := by + constructor <;> · apply Entailment.not_weakerThan_iff.mpr; assumption; + +end WeakerThan + +/-! +### Consistency and inconsistency -/ + +@[simp] +lemma provableSet_theory (𝓢 : S) : 𝓢 ⊢* theory 𝓢 := fun hf ↦ hf + +/-- The Inconsistent construction in `FFL.Entailment`. -/ +def Inconsistent (𝓢 : S) : Prop := + ∀ φ, 𝓢 ⊢ φ + +/-- Data and laws for Consistent in `FFL.Entailment`. -/ +class Consistent (𝓢 : S) : Prop where + not_inconsistent : ¬Inconsistent 𝓢 + +lemma inconsistent_def {𝓢 : S} : Inconsistent 𝓢 ↔ ∀ φ, 𝓢 ⊢ φ := by simp [Inconsistent] + +lemma inconsistent_iff_theory_eq {𝓢 : S} : Inconsistent 𝓢 ↔ theory 𝓢 = Set.univ := by + simp [Inconsistent, Set.ext_iff, theory] + +@[simp] +lemma not_inconsistent_iff_consistent {𝓢 : S} : ¬Inconsistent 𝓢 ↔ Consistent 𝓢 := + ⟨fun h ↦ ⟨h⟩, by rintro ⟨h⟩; exact h⟩ + +alias ⟨_, Consistent.not_inc⟩ := not_inconsistent_iff_consistent + +@[simp] +lemma not_consistent_iff_inconsistent {𝓢 : S} : ¬Consistent 𝓢 ↔ Inconsistent 𝓢 := by + simp [← not_inconsistent_iff_consistent] + +alias ⟨_, Inconsistent.not_con⟩ := not_consistent_iff_inconsistent + +lemma consistent_iff_exists_unprovable {𝓢 : S} : Consistent 𝓢 ↔ ∃ φ, 𝓢 ⊬ φ := by + simp [← not_inconsistent_iff_consistent, inconsistent_def] + +alias ⟨Consistent.exists_unprovable, _⟩ := consistent_iff_exists_unprovable + +lemma Consistent.of_unprovable {𝓢 : S} {φ} (h : 𝓢 ⊬ φ) : Consistent 𝓢 := + ⟨fun hp ↦ h (hp φ)⟩ + +lemma inconsistent_iff_theory_eq_univ {𝓢 : S} : Inconsistent 𝓢 ↔ theory 𝓢 = Set.univ := by + simp [inconsistent_def, theory, Set.ext_iff] + +alias ⟨Inconsistent.theory_eq, _⟩ := inconsistent_iff_theory_eq_univ + +lemma Inconsistent.of_ge {𝓢 : S} {𝓣 : T} (h𝓢 : Inconsistent 𝓢) (h : 𝓢 ≼ 𝓣) : Inconsistent 𝓣 := + fun φ ↦ h.subset (h𝓢 φ) + +lemma Consistent.of_le {𝓢 : S} {𝓣 : T} (h𝓢 : Consistent 𝓢) (h : 𝓣 ≼ 𝓢) : Consistent 𝓣 := + ⟨fun H ↦ not_consistent_iff_inconsistent.mpr (H.of_ge h) h𝓢⟩ + +variable (S) + +/-- Data and laws for Deductive Explosion in `FFL.Entailment`. -/ +class DeductiveExplosion [LogicalNeutral F] where + /-- The dexp construction in `FFL.Entailment.DeductiveExplosion`. -/ + dexp {𝓢 : S} : 𝓢 ⊢! ⊥ → (φ : F) → 𝓢 ⊢! φ + +variable {S} + +section + +variable [LogicalNeutral F] [DeductiveExplosion S] + +theorem DeductiveExplosion.dexpProof {𝓢 : S} (h : 𝓢 ⊢ ⊥) (φ : F) : 𝓢 ⊢ φ := by + rcases h with ⟨b⟩; exact ⟨dexp b φ⟩ + +lemma inconsistent_iff_provable_bot {𝓢 : S} : Inconsistent 𝓢 ↔ 𝓢 ⊢ ⊥ := + ⟨fun h ↦ h ⊥, fun h φ ↦ DeductiveExplosion.dexpProof h φ⟩ + +alias ⟨_, inconsistent_of_provable⟩ := inconsistent_iff_provable_bot + +lemma consistent_iff_unprovable_bot {𝓢 : S} : Consistent 𝓢 ↔ 𝓢 ⊬ ⊥ := by + simp [inconsistent_iff_provable_bot, ← not_inconsistent_iff_consistent] + +@[simp, grind .] +lemma Consistent.not_bot {𝓢 : S} [Consistent 𝓢] : 𝓢 ⊬ ⊥ := + consistent_iff_unprovable_bot.mp inferInstance + +end + +/-! +### Completeness and incompleteness -/ + +section + +variable [Tilde F] (𝓢 : S) + +/-- `𝓢` is complete if, for every formula, either it or its negation is provable by `𝓢`. -/ +class Complete : Prop where + con : ∀ φ, 𝓢 ⊢ φ ∨ 𝓢 ⊢ ∼φ + +/-- A formula `φ` is independent from `𝓢` if, neither it nor its negation is provable by `𝓢`. -/ +def Independent (φ : F) : Prop := + 𝓢 ⊬ φ ∧ 𝓢 ⊬ ∼φ + +/-- +A proof system is incomplete if and only if there exists a formula that is both unprovable and +irrefutable. -/ +class Incomplete : Prop where + indep : ∃ φ, Independent 𝓢 φ + +variable {𝓢 : S} {𝓣 : T} + +lemma complete_def : Complete 𝓢 ↔ ∀ φ, 𝓢 ⊢ φ ∨ 𝓢 ⊢ ∼φ := + ⟨fun h ↦ h.con, Complete.mk⟩ + +lemma incomplete_def : Incomplete 𝓢 ↔ ∃ φ, Independent 𝓢 φ := + ⟨fun h ↦ h.indep, Incomplete.mk⟩ + +omit [Tilde F] in +lemma Equiv.unprovable (e : 𝓢 ≊ 𝓣) {φ : F} : 𝓢 ⊬ φ ↔ 𝓣 ⊬ φ := + not_congr <| Equiv.iff.mp e φ + +lemma Equiv.incomplete (e : 𝓢 ≊ 𝓣) : Incomplete 𝓢 → Incomplete 𝓣 := + by + rintro ⟨φ, hφ⟩ + exact ⟨φ, e.unprovable.mp hφ.1, e.unprovable.mp hφ.2⟩ + +lemma Equiv.incomplete_iff (e : 𝓢 ≊ 𝓣) : Incomplete 𝓢 ↔ Incomplete 𝓣 := + ⟨e.incomplete, e.symm.incomplete⟩ + +@[simp] +lemma not_complete_iff_incomplete : ¬Complete 𝓢 ↔ Incomplete 𝓢 := by + simp [complete_def, incomplete_def, Independent, not_or] + +@[simp] +lemma not_incomplete_iff_complete : ¬Incomplete 𝓢 ↔ Complete 𝓢 := + Iff.symm <| iff_not_comm.mp not_complete_iff_incomplete.symm + +instance consistent_of_incomplete [h : Incomplete 𝓢] : Consistent 𝓢 := + consistent_iff_exists_unprovable.mpr <| by rcases h.indep with ⟨φ, hφ⟩; exact ⟨φ, hφ.1⟩ + +end + +/-! +### Axiomatized provability -/ + +variable (S T) + +/-- Data and laws for Axiomatized in `FFL.Entailment`. -/ +class Axiomatized [AdjunctiveSet F S] where + /-- The prf Axm construction in `FFL.Entailment.Axiomatized`. -/ + prfAxm {𝓢 : S} : 𝓢 ⊢!* AdjunctiveSet.set 𝓢 + /-- The weakening construction in `FFL.Entailment.Axiomatized`. -/ + weakening {𝓢 𝓣 : S} : 𝓢 ⊆ 𝓣 → 𝓢 ⊢! φ → 𝓣 ⊢! φ + +alias wk := Axiomatized.weakening + +/-- Data and laws for Strong Cut in `FFL.Entailment`. -/ +class StrongCut [AdjunctiveSet F T] where + /-- The cut construction in `FFL.Entailment.StrongCut`. -/ + cut {𝓢 : S} {𝓣 : T} {φ} : 𝓢 ⊢!* AdjunctiveSet.set 𝓣 → 𝓣 ⊢! φ → 𝓢 ⊢! φ + +variable {S T} + +section Axiomatized + +namespace Axiomatized + +variable [AdjunctiveSet F S] [Axiomatized S] {𝓢 𝓣 : S} + +/-- The by Axm construction in `FFL.Entailment.Axiomatized`. -/ +def byAxm {𝓢 : S} (h : φ ∈ 𝓢) : 𝓢 ⊢! φ := + prfAxm (by simp [h]) + +lemma by_axm {𝓢 : S} (h : φ ∈ 𝓢) : 𝓢 ⊢ φ := + ⟨byAxm h⟩ + +@[simp] +lemma provable_refl (𝓢 : S) : 𝓢 ⊢* AdjunctiveSet.set 𝓢 := fun hf ↦ ⟨prfAxm hf⟩ + +lemma axm_subset (𝓢 : S) : AdjunctiveSet.set 𝓢 ⊆ theory 𝓢 := fun _ hp ↦ provable_refl 𝓢 hp + +/-- The adjoin construction in `FFL.Entailment.Axiomatized`. -/ +protected def adjoin (φ : F) (𝓢 : S) : adjoin φ 𝓢 ⊢! φ := + prfAxm (by simp) + +@[simp] +theorem adjoinProof (φ : F) (𝓢 : S) : adjoin φ 𝓢 ⊢ φ := + provable_refl _ (by simp) + +lemma le_of_subset (h : 𝓢 ⊆ 𝓣) : 𝓢 ≼ 𝓣 := + ⟨by rintro φ ⟨b⟩; exact ⟨weakening h b⟩⟩ + +lemma weakeningProof (h : 𝓢 ⊆ 𝓣 := by simp) {φ} : 𝓢 ⊢ φ → 𝓣 ⊢ φ := by + rintro ⟨b⟩; + exact ⟨weakening h b⟩ + +/-- The weaker Than Of Subset construction in `FFL.Entailment.Axiomatized`. -/ +abbrev weakerThanOfSubset (h : 𝓢 ⊆ 𝓣) : 𝓢 ≼ 𝓣 := + ⟨fun _ ↦ weakeningProof h⟩ + +/-- The to Adjoin construction in `FFL.Entailment.Axiomatized`. -/ +def toAdjoin {𝓢 : S} : 𝓢 ⊢! ψ → adjoin φ 𝓢 ⊢! ψ := fun b ↦ wk (by simp) b + +theorem to_adjoin {𝓢 : S} : 𝓢 ⊢ ψ → adjoin φ 𝓢 ⊢ ψ := fun b ↦ weakeningProof (by simp) b + +end Axiomatized + +alias byAxm := Axiomatized.byAxm + +alias by_axm := Axiomatized.by_axm + +alias wkProof := Axiomatized.weakeningProof + +section axiomatized + +variable [AdjunctiveSet F S] [AdjunctiveSet F T] [Axiomatized S] + +/-- The Finite Axiomatizable construction in `FFL.Entailment`. -/ +def FiniteAxiomatizable (𝓢 : S) : Prop := + ∃ 𝓕 : S, AdjunctiveSet.Finite 𝓕 ∧ 𝓕 ≊ 𝓢 + +lemma Consistent.of_subset {𝓢 𝓣 : S} (h𝓢 : Consistent 𝓢) (h : 𝓣 ⊆ 𝓢) : Consistent 𝓣 := + h𝓢.of_le (Axiomatized.le_of_subset h) + +lemma Inconsistent.of_supset {𝓢 𝓣 : S} (h𝓢 : Inconsistent 𝓢) (h : 𝓢 ⊆ 𝓣) : Inconsistent 𝓣 := + h𝓢.of_ge (Axiomatized.le_of_subset h) + +end axiomatized + +namespace StrongCut + +variable [AdjunctiveSet F T] [StrongCut S T] + +lemma cutProof {𝓢 : S} {𝓣 : T} {φ : F} (H : 𝓢 ⊢* AdjunctiveSet.set 𝓣) (hp : 𝓣 ⊢ φ) : 𝓢 ⊢ φ := by + rcases hp with ⟨b⟩; exact ⟨StrongCut.cut H.get b⟩ + +end StrongCut + +/-- The of Axm! construction in `FFL.Entailment.WeakerThan`. -/ +noncomputable abbrev WeakerThan.ofAxmProof [AdjunctiveSet F S] [StrongCut S S] {𝓢₁ 𝓢₂ : S} + (B : 𝓢₂ ⊢* AdjunctiveSet.set 𝓢₁) : 𝓢₁ ≼ 𝓢₂ := + ⟨fun _ b ↦ StrongCut.cutProof B b⟩ + +/-- The of Subset construction in `FFL.Entailment.WeakerThan`. -/ +abbrev WeakerThan.ofSubset [AdjunctiveSet F S] [Axiomatized S] {𝓢 𝓣 : S} (h : 𝓢 ⊆ 𝓣) : 𝓢 ≼ 𝓣 := + ⟨fun _ ↦ wkProof h⟩ + +/-! +### Compactness -/ + +variable (S) + +/-- Data and laws for Compact in `FFL.Entailment`. -/ +class Compact [AdjunctiveSet F S] where + /-- The core construction in `FFL.Entailment.Compact`. -/ + core {𝓢 : S} {φ : F} : 𝓢 ⊢! φ → S + /-- The core Prf construction in `FFL.Entailment.Compact`. -/ + corePrf {𝓢 : S} {φ : F} (b : 𝓢 ⊢! φ) : core b ⊢! φ + core_subset {𝓢 : S} {φ : F} (b : 𝓢 ⊢! φ) : core b ⊆ 𝓢 + core_finite {𝓢 : S} {φ : F} (b : 𝓢 ⊢! φ) : AdjunctiveSet.Finite (core b) + +variable {S} + +namespace Compact + +variable [AdjunctiveSet F S] [Compact S] + +lemma finite_provable {𝓢 : S} (h : 𝓢 ⊢ φ) : ∃ 𝓕 : S, 𝓕 ⊆ 𝓢 ∧ AdjunctiveSet.Finite 𝓕 ∧ 𝓕 ⊢ φ := + by + rcases h with ⟨b⟩ + exact ⟨core b, core_subset b, core_finite b, ⟨corePrf b⟩⟩ + +end Compact + +end Axiomatized + +end Entailment + +namespace Entailment + +variable {S : Type*} {F : Type*} [LogicalConnective F] [LogicalNeutral F] [Entailment S F] + +section + +variable [DeductiveExplosion S] [AdjunctiveSet F S] [Axiomatized S] [Compact S] + +omit [LogicalConnective F] in +lemma inconsistent_compact {𝓢 : S} : + Inconsistent 𝓢 ↔ ∃ 𝓕 : S, 𝓕 ⊆ 𝓢 ∧ AdjunctiveSet.Finite 𝓕 ∧ Inconsistent 𝓕 := + by + constructor + · intro h + obtain ⟨𝓕, h𝓕, finite, proof⟩ := Compact.finite_provable (h ⊥) + exact ⟨𝓕, h𝓕, finite, inconsistent_of_provable proof⟩ + · rintro ⟨𝓕, h𝓕, _, h⟩ + exact h.of_supset h𝓕 + +omit [LogicalConnective F] in +lemma consistent_compact {𝓢 : S} : + Consistent 𝓢 ↔ ∀ 𝓕 : S, 𝓕 ⊆ 𝓢 → AdjunctiveSet.Finite 𝓕 → Consistent 𝓕 := by + simp [← not_inconsistent_iff_consistent, inconsistent_compact (𝓢 := 𝓢)] + +end + +/-! +### Deduction theorem -/ + +variable (S) + +/-- Data and laws for Deduction in `FFL.Entailment`. -/ +class Deduction [Adjoin F S] where + /-- The of Insert construction in `FFL.Entailment.Deduction`. -/ + ofInsert {φ ψ : F} {𝓢 : S} : adjoin φ 𝓢 ⊢! ψ → 𝓢 ⊢! φ ⇒ₗ ψ + /-- The inv construction in `FFL.Entailment.Deduction`. -/ + inv {φ ψ : F} {𝓢 : S} : 𝓢 ⊢! φ ⇒ₗ ψ → adjoin φ 𝓢 ⊢! ψ + +variable {S} + +section deduction + +variable [Adjoin F S] [Deduction S] {𝓢 : S} {φ ψ : F} + +alias deduction := Deduction.ofInsert + +omit [LogicalNeutral F] in +lemma Deduction.of_insertProof (h : adjoin φ 𝓢 ⊢ ψ) : 𝓢 ⊢ φ ⇒ₗ ψ := by + rcases h with ⟨b⟩; exact ⟨Deduction.ofInsert b⟩ + +alias deductionProof := Deduction.of_insertProof + +omit [LogicalNeutral F] in +lemma Deduction.invProof (h : 𝓢 ⊢ φ ⇒ₗ ψ) : adjoin φ 𝓢 ⊢ ψ := by + rcases h with ⟨b⟩; exact ⟨Deduction.inv b⟩ + +omit [LogicalNeutral F] in +lemma deduction_iff : adjoin φ 𝓢 ⊢ ψ ↔ 𝓢 ⊢ φ ⇒ₗ ψ := + ⟨deductionProof, Deduction.invProof⟩ + +end deduction + +end Entailment + +/-! +### Soundness and Completeness -/ + +section + +variable {S : Type*} {F : Type*} [Entailment S F] {M : Type*} [Semantics M F] + +/-- Data and laws for Sound in `FFL`. -/ +class Sound (𝓢 : S) (𝓜 : M) : Prop where + sound : ∀ {φ : F}, 𝓢 ⊢ φ → 𝓜 ⊧ φ + +/-- Data and laws for Complete in `FFL`. -/ +class Complete (𝓢 : S) (𝓜 : M) : Prop where + complete : ∀ {φ : F}, 𝓜 ⊧ φ → 𝓢 ⊢ φ + +namespace Sound + +section + +variable {𝓢 𝓣 : S} {𝓜 𝓝 : M} [Sound 𝓢 𝓜] [Sound 𝓣 𝓝] + +lemma not_provable_of_countermodel {φ : F} (hp : 𝓜 ⊭ φ) : 𝓢 ⊬ φ := fun b ↦ hp (Sound.sound b) + +lemma consistent_of_meaningful : Semantics.Meaningful 𝓜 → Entailment.Consistent 𝓢 := fun H ↦ + ⟨fun h ↦ by rcases H with ⟨φ, hf⟩; exact hf (Sound.sound (h φ))⟩ + +lemma consistent_of_model [LogicalNeutral F] [Semantics.Bot M] (𝓜 : M) [Sound 𝓢 𝓜] : + Entailment.Consistent 𝓢 := + consistent_of_meaningful (𝓜 := 𝓜) inferInstance + +lemma modelsSet_of_prfSet {T : Set F} (b : 𝓢 ⊢* T) : 𝓜 ⊧* T := + ⟨fun _ hf ↦ sound (b hf)⟩ + +end + +section + +variable {𝓢 : S} {T : Set F} [Sound 𝓢 (Semantics.models M T)] + +lemma consequence_of_provable {φ : F} : 𝓢 ⊢ φ → T ⊨[M] φ := + sound + +lemma consistent_of_satisfiable [∀ 𝓜 : M, Semantics.Meaningful 𝓜] : + Semantics.Satisfiable M T → Entailment.Consistent 𝓢 := fun H ↦ + consistent_of_meaningful (Semantics.meaningful_iff_satisfiableSet.mp H) + +end + +end Sound + +namespace Complete + +section + +variable {𝓢 : S} {𝓜 : M} [Complete 𝓢 𝓜] + +lemma exists_countermodel_of_not_provable {φ : F} (h : 𝓢 ⊬ φ) : 𝓜 ⊭ φ := by + contrapose! h; + simpa using Complete.complete (𝓢 := 𝓢) h; + +lemma meaningful_of_consistent : Entailment.Consistent 𝓢 → Semantics.Meaningful 𝓜 := + by + contrapose + suffices (∀ (φ : F), 𝓜 ⊧ φ) → Entailment.Inconsistent 𝓢 by + simpa [Semantics.not_meaningful_iff, Entailment.not_consistent_iff_inconsistent] + exact fun h φ ↦ Complete.complete (h φ) + +end + +section + +variable {𝓢 : S} {s : Set F} [Complete 𝓢 (Semantics.models M s)] + +lemma provable_of_consequence {φ : F} : s ⊨[M] φ → 𝓢 ⊢ φ := + complete + +lemma provable_iff_consequence [Sound 𝓢 (Semantics.models M s)] {φ : F} : s ⊨[M] φ ↔ 𝓢 ⊢ φ := + ⟨complete, Sound.sound⟩ + +section + +variable [∀ 𝓜 : M, Semantics.Meaningful 𝓜] + +lemma satisfiable_of_consistent : Entailment.Consistent 𝓢 → Semantics.Satisfiable M s := fun H ↦ + Semantics.meaningful_iff_satisfiableSet.mpr (meaningful_of_consistent H) + +lemma inconsistent_of_unsatisfiable : ¬Semantics.Satisfiable M s → Entailment.Inconsistent 𝓢 := by + contrapose; + simpa [← Entailment.not_consistent_iff_inconsistent] using satisfiable_of_consistent + +lemma consistent_iff_satisfiable [Sound 𝓢 (Semantics.models M s)] : + Entailment.Consistent 𝓢 ↔ Semantics.Satisfiable M s := + ⟨satisfiable_of_consistent, Sound.consistent_of_satisfiable⟩ + +end + +lemma weakerthan_of_models {𝓣 : S} {t : Set F} [Sound 𝓣 (Semantics.models M t)] + (H : ∀ 𝓜 : M, 𝓜 ⊧* s → 𝓜 ⊧* t) : 𝓣 ≼ 𝓢 := + Entailment.weakerThan_iff.mpr <| fun h ↦ + provable_of_consequence <| fun 𝓜 h𝓜 ↦ + Sound.consequence_of_provable (M := M) (T := t) h (H 𝓜 h𝓜) + +end + +end Complete + +end + +namespace Entailment + +variable (S : Type*) {F : Type*} [Entailment S F] + +/-- Data and laws for Pullback in `FFL.Entailment`. -/ +structure Pullback (f : G → F) : Type _ where + /-- The forget construction in `FFL.Entailment.Pullback`. -/ + forget : S + +variable {S} + +/-- The pullback construction in `FFL.Entailment`. -/ +abbrev pullback (𝓢 : S) (f : G → F) : Pullback S f := + ⟨𝓢⟩ + +instance (f : G → F) : Entailment (Pullback S f) G where Prf := fun 𝓢 φ ↦ 𝓢.forget ⊢! f φ + +namespace Pullback + +section basics + +variable {f : G → F} + +omit [Entailment S F] in +@[simp] +lemma pullback_forget (𝓢 : S) : (pullback 𝓢 f).forget = 𝓢 := + rfl + +@[simp] +lemma provable_iff {𝓢 : S} {φ : G} : pullback 𝓢 f ⊢ φ ↔ 𝓢 ⊢ f φ := by rfl + +@[simp] +lemma unprovable_iff {𝓢 : S} {φ : G} : pullback 𝓢 f ⊬ φ ↔ 𝓢 ⊬ f φ := by rfl + +@[simp] +lemma provableSet_iff {𝓢 : S} {s : Set G} : pullback 𝓢 f ⊢* s ↔ 𝓢 ⊢* f '' s := by + simp [ProvableSet] + +@[simp] +lemma theory_eq (𝓢 : S) : theory (pullback 𝓢 f) = f ⁻¹' theory 𝓢 := + rfl + +lemma weakerThan (𝓢 𝓣 : S) (h : 𝓢 ≼ 𝓣) : pullback 𝓢 f ≼ pullback 𝓣 f := by + simp_all [Entailment.weakerThan_iff] + +lemma inconsistent {𝓢 : S} : Inconsistent 𝓢 → Inconsistent (pullback 𝓢 f) := by + simp_all [Inconsistent] + +lemma consistent {𝓢 : S} : Consistent (pullback 𝓢 f) → Consistent 𝓢 := by + contrapose; + simpa using inconsistent + +end basics + +end Pullback + +end Entailment + +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/Logic/ForcingRelation.lean b/LeanPool/PointwiseComposition/Foundation/Logic/ForcingRelation.lean new file mode 100644 index 000000000..e74a29bc0 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/Logic/ForcingRelation.lean @@ -0,0 +1,207 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.Logic.LogicSymbol +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.AdjunctiveSet + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# Forcing relation -/ + +@[expose] public section + +namespace FFL + +/-- Data and laws for Forcing Relation in `FFL`. -/ +class ForcingRelation (W : Type*) (F : outParam Type*) where + /-- The Forces construction in `FFL.ForcingRelation`. -/ + Forces : W → F → Prop + +/-- The «term ⊩ » construction in `FFL`. -/ +infix:45 " ⊩ " => ForcingRelation.Forces + +/-- Data and laws for Forcing Exists in `FFL`. -/ +class ForcingExists (W : Type*) (α : outParam Type*) where + /-- The Forces construction in `FFL.ForcingExists`. -/ + Forces : W → α → Prop + +/-- The «term ⊩↓ » construction in `FFL`. -/ +infix:45 " ⊩↓ " => ForcingExists.Forces + +namespace ForcingRelation + +variable {W : Type*} {F : Type*} [ForcingRelation W F] [LogicalConnective F] [LogicalNeutral F] + +/-- The Not Forces construction in `FFL.ForcingRelation`. -/ +abbrev NotForces (w : W) (φ : F) : Prop := + ¬w ⊩ φ + +/-- The «term ⊮ » construction in `FFL.ForcingRelation`. -/ +infix:45 " ⊮ " => NotForces + +variable (W) + +/-- Data and laws for Basic Semantics in `FFL.ForcingRelation`. -/ +class BasicSemantics where + verum (w : W) : w ⊩ ⊤ + and (w : W) : w ⊩ φ ⋏ ψ ↔ w ⊩ φ ∧ w ⊩ ψ + or (w : W) : w ⊩ φ ⋎ ψ ↔ w ⊩ φ ∨ w ⊩ ψ + +/-- Data and laws for Monotone in `FFL.ForcingRelation`. -/ +class Monotone (R : outParam (W → W → Prop)) where + monotone {w : W} : w ⊩ φ → ∀ v, R w v → v ⊩ φ + +/-- Data and laws for Int Kripke in `FFL.ForcingRelation`. -/ +class IntKripke (R : outParam (W → W → Prop)) extends BasicSemantics W, Monotone W R where + imply (w : W) : w ⊩ φ ⇒ₗ ψ ↔ (∀ v, R w v → v ⊩ φ → v ⊩ ψ) + falsum (w : W) : ¬w ⊩ ⊥ + not (w : W) : w ⊩ ∼φ ↔ (∀ v, R w v → ¬v ⊩ φ) + +variable {W} + +attribute [grind .] BasicSemantics.verum +attribute [simp, grind .] BasicSemantics.and BasicSemantics.or IntKripke.falsum + +attribute [grind .] IntKripke.imply IntKripke.not + +@[grind =, simp] +lemma iff (R : W → W → Prop) [IntKripke W R] : w ⊩ (φ ⇔ₗ ψ) ↔ (∀ v, R w v → (v ⊩ φ ↔ v ⊩ ψ)) := + by simp [LogicalConnective.iff, IntKripke.imply]; grind + +variable (W) + +/-- The All Forces construction in `FFL.ForcingRelation`. -/ +abbrev AllForces (φ : F) : Prop := + ∀ w : W, w ⊩ φ + +/-- The «term ∀⊩ » construction in `FFL.ForcingRelation`. -/ +infix:45 " ∀⊩ " => AllForces + +/-- The All Forces Set construction in `FFL.ForcingRelation`. -/ +abbrev AllForcesSet (s : S) [AdjunctiveSet F S] : Prop := + ∀ φ ∈ s, W ∀⊩ φ + +/-- The «term ∀⊩* » construction in `FFL.ForcingRelation`. -/ +infix:45 " ∀⊩* " => AllForcesSet + +variable {W} + +namespace AllForces + +@[simp] +lemma verum [BasicSemantics W] : W ∀⊩ ⊤ := + BasicSemantics.verum + +@[simp] +lemma and [BasicSemantics W] : W ∀⊩ φ ⋏ ψ ↔ W ∀⊩ φ ∧ W ∀⊩ ψ := by simp [AllForces]; grind + +end AllForces + +end ForcingRelation + +/-! +### Forcing relation for classical logic -/ + +/-- Data and laws for Weak Forcing Relation in `FFL`. -/ +class WeakForcingRelation (ℙ : Type*) (F : outParam Type*) where + /-- The Weakly Forces construction in `FFL.WeakForcingRelation`. -/ + WeaklyForces : ℙ → F → Prop + +/-- The «term ⊩ᶜ » construction in `FFL`. -/ +infix:45 " ⊩ᶜ " => WeakForcingRelation.WeaklyForces + +namespace WeakForcingRelation + +variable {ℙ : Type*} {F : Type*} [WeakForcingRelation ℙ F] [LogicalConnective F] + [LogicalNeutral F] + +/-- The Not Forces construction in `FFL.WeakForcingRelation`. -/ +abbrev NotForces (p : ℙ) (φ : F) : Prop := + ¬p ⊩ᶜ φ + +/-- The «term ⊮ᶜ » construction in `FFL.WeakForcingRelation`. -/ +infix:45 " ⊮ᶜ " => NotForces + +variable (ℙ) + +/-- Data and laws for Basic Semantics in `FFL.WeakForcingRelation`. -/ +class BasicSemantics where + verum (p : ℙ) : p ⊩ᶜ ⊤ + falsum (p : ℙ) : ¬p ⊩ᶜ ⊥ + and (p : ℙ) : p ⊩ᶜ φ ⋏ ψ ↔ p ⊩ᶜ φ ∧ p ⊩ᶜ ψ + +/-- Data and laws for Classical Kripke in `FFL.WeakForcingRelation`. -/ +class ClassicalKripke (R : outParam (ℙ → ℙ → Prop)) extends BasicSemantics ℙ where + or (p : ℙ) : p ⊩ᶜ φ ⋎ ψ ↔ ∀ q, R p q → ∃ x, R q x ∧ (x ⊩ᶜ φ ∨ x ⊩ᶜ ψ) + not (p : ℙ) : p ⊩ᶜ ∼φ ↔ (∀ q, R p q → ¬q ⊩ᶜ φ) + imply (p : ℙ) : p ⊩ᶜ φ ⇒ₗ ψ ↔ (∀ q, R p q → q ⊩ᶜ φ → q ⊩ᶜ ψ) + monotone {p : ℙ} : p ⊩ᶜ φ → ∀ q, R p q → q ⊩ᶜ φ + generic {p : ℙ} : (∀ q, R p q → ∃ r, R q r ∧ r ⊩ᶜ φ) → p ⊩ᶜ φ + +variable {ℙ} + +attribute [grind .] BasicSemantics.verum +attribute [simp, grind .] BasicSemantics.falsum BasicSemantics.and ClassicalKripke.or + ClassicalKripke.imply ClassicalKripke.not + +variable (ℙ) + +/-- The All Forces construction in `FFL.WeakForcingRelation`. -/ +abbrev AllForces (φ : F) : Prop := + ∀ p : ℙ, p ⊩ᶜ φ + +/-- The «term ∀⊩ᶜ » construction in `FFL.WeakForcingRelation`. -/ +infix:45 " ∀⊩ᶜ " => AllForces + +/-- The All Forces Set construction in `FFL.WeakForcingRelation`. -/ +abbrev AllForcesSet (s : S) [AdjunctiveSet F S] : Prop := + ∀ φ ∈ s, ℙ ∀⊩ᶜ φ + +/-- The «term ∀⊩ᶜ* » construction in `FFL.WeakForcingRelation`. -/ +infix:45 " ∀⊩ᶜ* " => AllForcesSet + +variable {ℙ} + +namespace AllForces + +@[simp] +lemma verum [BasicSemantics ℙ] : ℙ ∀⊩ᶜ ⊤ := + BasicSemantics.verum + +@[simp] +lemma falsum [BasicSemantics ℙ] [Nonempty ℙ] : ¬ℙ ∀⊩ᶜ ⊥ := fun h ↦ by + simpa using h (Classical.choice inferInstance) + +@[simp] +lemma and [BasicSemantics ℙ] : ℙ ∀⊩ᶜ φ ⋏ ψ ↔ ℙ ∀⊩ᶜ φ ∧ ℙ ∀⊩ᶜ ψ := by + simp [AllForces]; + grind + /- + @[simp] lemma or [ClassicalKripke ℙ R] : ℙ ∀⊩ᶜ φ ⋎ ψ ↔ ℙ ∀⊩ᶜ φ ∨ ℙ ∀⊩ᶜ ψ := by + simp [AllForces] + constructor + · intro h + by_contra! C + rcases C with ⟨⟨p, hp⟩, ⟨q, hq⟩⟩ + -/ + +end AllForces + +end WeakForcingRelation + +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/Logic/LogicSymbol.lean b/LeanPool/PointwiseComposition/Foundation/Logic/LogicSymbol.lean new file mode 100644 index 000000000..3f5de189a --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/Logic/LogicSymbol.lean @@ -0,0 +1,1122 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.List.Basic +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Multiset +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.NotationClass + +/-! Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +/-! +# Logic Symbols + +This file defines structure that has logical connectives $\top, \bot, \land, \lor, \to, \lnot$ +and their homomorphisms. + +## Main Definitions +* `FFL.LogicalConnective` is defined so that `FFL.LogicalConnective F` is a type that has +logical connectives $\top, \bot, \land, \lor, \to, \lnot$. +* `FFL.LogicalConnective.Hom` is defined so that `f : F →ˡᶜ G` is a homomorphism from `F` to +`G`, i.e., +a function that preserves logical connectives. + +-/ + +namespace FFL + +/-- A class for types with logical connectives $\top, \bot, \land, \lor, \to, \lnot$. +-/ +class LogicalConnective (α : Type*) extends Tilde α, Arrow α, Wedge α, Vee α + +/-- Truth and falsity constants for formulas. -/ +class LogicalNeutral (α : Type*) extends Top α, Bot α + +/-- Data and laws for Tilde Involutive in `FFL`. -/ +class TildeInvolutive (F : Type*) [Tilde F] where + tilde_involutive (φ : F) : ∼∼φ = φ + +/-- Data and laws for De Morgan in `FFL.LogicalConnective`. -/ +class LogicalConnective.DeMorgan (F : Type*) [LogicalConnective F] where + imply (φ ψ : F) : φ ⇒ₗ ψ = ∼φ ⋎ ψ + and (φ ψ : F) : ∼(φ ⋏ ψ) = ∼φ ⋎ ∼ψ + or (φ ψ : F) : ∼(φ ⋎ ψ) = ∼φ ⋏ ∼ψ + +/-- Data and laws for De Morgan in `FFL.LogicalNeutral`. -/ +class LogicalNeutral.DeMorgan (F : Type*) [LogicalNeutral F] [Tilde F] where + verum : ∼(⊤ : F) = ⊥ + falsum : ∼(⊥ : F) = ⊤ + +alias LogicalNeutral.DeMorgan.neg := TildeInvolutive.tilde_involutive + +attribute [simp, grind =] TildeInvolutive.tilde_involutive +attribute [simp, grind =] LogicalNeutral.DeMorgan.verum LogicalNeutral.DeMorgan.falsum + LogicalConnective.DeMorgan.and LogicalConnective.DeMorgan.or + +/-- Introducing `∼φ` as an abbreviation of `φ ⇒ₗ ⊥`. -/ +class NegAbbrev (F : Type*) [Tilde F] [Arrow F] [Bot F] where + protected neg {φ : F} : ∼φ = φ ⇒ₗ ⊥ + +attribute [grind =] NegAbbrev.neg + +/-- Introducing `∼φ`, `φ ⋎ ψ`, `φ ⋏ ψ`, `⊤` as abbreviation. -/ +class ŁukasiewiczAbbrev (F : Type*) [LogicalNeutral F] [LogicalConnective F] extends + NegAbbrev F where + protected top : ⊤ = ∼(⊥ : F) + protected or {φ ψ : F} : φ ⋎ ψ = ∼φ ⇒ₗ ψ + protected and {φ ψ : F} : φ ⋏ ψ = ∼(φ ⇒ₗ ∼ψ) + +attribute [grind =] ŁukasiewiczAbbrev.and ŁukasiewiczAbbrev.or ŁukasiewiczAbbrev.top + +section tilde + +variable {α : Type*} [Tilde α] [TildeInvolutive α] + +@[simp] +lemma TildeInvolutive.tilde_injective : Function.Injective (∼· : α → α) := + by + intro φ ψ h + simpa using congr_arg (∼·) h + +@[simp] +lemma TildeInvolutive.tilde_eq_tilde_iff_eq {φ ψ : α} : ∼φ = ∼ψ ↔ φ = ψ := + Function.Injective.eq_iff TildeInvolutive.tilde_injective + +/-- The invol construction in `FFL.Tilde`. -/ +def Tilde.invol : α ↪ α := + ⟨(∼·), TildeInvolutive.tilde_injective⟩ + +@[simp] +lemma Tilde.invol_app (φ : α) : Tilde.invol φ = ∼φ := + rfl + +end tilde + +namespace LogicalConnective + +section +variable {α : Type*} [LogicalConnective α] + +/-- The iff construction in `FFL.LogicalConnective`. -/ +@[match_pattern] +def iff (a b : α) := + (a ⇒ₗ b) ⋏ (b ⇒ₗ a) + +/-- A defined logical connective for "iff", defined from the logical connectives `⇒ₗ` and `⋏`. +-/ +infix:61 " ⇔ₗ " => LogicalConnective.iff + +end + +@[reducible] +instance PropLogicSymbols : LogicalConnective Prop + where + arrow := fun P Q => (P → Q) + wedge := And + vee := Or + tilde := Not + +instance PropLogicalNeutral : LogicalNeutral Prop + where + top := True + bot := False + +@[simp] +lemma «Prop».top_eq : ⊤ = True := + rfl + +@[simp] +lemma «Prop».bot_eq : ⊥ = False := + rfl + +@[simp] +lemma «Prop».neg_eq (φ : Prop) : ∼φ = ¬φ := + rfl + +@[simp] +lemma «Prop».arrow_eq (φ ψ : Prop) : (φ ⇒ₗ ψ) = (φ → ψ) := + rfl + +@[simp] +lemma «Prop».and_eq (φ ψ : Prop) : (φ ⋏ ψ) = (φ ∧ ψ) := + rfl + +@[simp] +lemma «Prop».or_eq (φ ψ : Prop) : (φ ⋎ ψ) = (φ ∨ ψ) := + rfl + +@[simp] +lemma «Prop».iff_eq (φ ψ : Prop) : (φ ⇔ₗ ψ) = (φ ↔ ψ) := by + simp [LogicalConnective.iff, iff_iff_implies_and_implies] + +instance : TildeInvolutive Prop where tilde_involutive := fun _ => by simp + +instance : LogicalConnective.DeMorgan Prop + where + imply := fun _ _ => by simp [imp_iff_not_or] + and := fun _ _ => by simp [-not_and, not_and_or] + or := fun _ _ => by simp [not_or] + +instance : LogicalNeutral.DeMorgan Prop + where + verum := by simp + falsum := by simp + +/-- +A class for a type `F` which contains homomorphisms (for logical connectives) from `α` to `β`. +-/ +class HomClass (F : Type*) (α β : outParam Type*) [LogicalConnective α] [LogicalNeutral α] + [LogicalConnective β] [LogicalNeutral β] [FunLike F α β] where + map_top : ∀ (f : F), f ⊤ = ⊤ + map_bot : ∀ (f : F), f ⊥ = ⊥ + map_neg : ∀ (f : F) (φ : α), f (∼φ) = ∼f φ + map_imply : ∀ (f : F) (φ ψ : α), f (φ ⇒ₗ ψ) = f φ ⇒ₗ f ψ + map_and : ∀ (f : F) (φ ψ : α), f (φ ⋏ ψ) = f φ ⋏ f ψ + map_or : ∀ (f : F) (φ ψ : α), f (φ ⋎ ψ) = f φ ⋎ f ψ + +attribute [simp, grind =] HomClass.map_top HomClass.map_bot HomClass.map_neg HomClass.map_imply + HomClass.map_and HomClass.map_or + +namespace HomClass + +variable (F : Type*) (α β : outParam Type*) [LogicalConnective α] [LogicalNeutral α] + [LogicalConnective β] [LogicalNeutral β] [FunLike F α β] +variable [HomClass F α β] +variable (f : F) (a b : α) + +instance : CoeFun F (fun _ => α → β) := + ⟨DFunLike.coe⟩ + +@[simp] +lemma map_iff : f (a ⇔ₗ b) = f a ⇔ₗ f b := by simp [LogicalConnective.iff] + +end HomClass + +variable (α β γ : Type*) [LogicalConnective α] [LogicalConnective β] [LogicalConnective γ] + [LogicalNeutral α] [LogicalNeutral β] [LogicalNeutral γ] + +/-- Data and laws for Hom in `FFL.LogicalConnective`. -/ +structure Hom where + /-- The to Tr construction in `FFL.LogicalConnective.Hom`. -/ + toTr : α → β + map_top' : toTr ⊤ = ⊤ + map_bot' : toTr ⊥ = ⊥ + map_neg' : ∀ φ, toTr (∼φ) = ∼toTr φ + map_imply' : ∀ φ ψ, toTr (φ ⇒ₗ ψ) = toTr φ ⇒ₗ toTr ψ + map_and' : ∀ φ ψ, toTr (φ ⋏ ψ) = toTr φ ⋏ toTr ψ + map_or' : ∀ φ ψ, toTr (φ ⋎ ψ) = toTr φ ⋎ toTr ψ + +/-- A structure for homomorphisms (for logical connectives) from `α` to `β`. +-/ +infix:25 " →ˡᶜ " => Hom + +namespace Hom +variable {α β γ} + +instance : FunLike (α →ˡᶜ β) α β where + coe := toTr + coe_injective := by intro f g h; rcases f; rcases g; simpa using h + +instance : CoeFun (α →ˡᶜ β) (fun _ => α → β) := + DFunLike.toCoeFun + +@[ext] +lemma ext (f g : α →ˡᶜ β) (h : ∀ x, f x = g x) : f = g := + DFunLike.ext f g h + +instance : HomClass (α →ˡᶜ β) α β where + map_top := map_top' + map_bot := map_bot' + map_neg := map_neg' + map_imply := map_imply' + map_and := map_and' + map_or := map_or' + +variable (f : α →ˡᶜ β) (a b : α) + +/-- The id construction in `FFL.LogicalConnective.Hom`. -/ +protected def id : α →ˡᶜ α where + toTr := id + map_top' := by simp + map_bot' := by simp + map_neg' := by simp + map_imply' := by simp + map_and' := by simp + map_or' := by simp + +@[simp] +lemma app_id (a : α) : LogicalConnective.Hom.id a = a := + rfl + +/-- The comp construction in `FFL.LogicalConnective.Hom`. -/ +def comp (g : β →ˡᶜ γ) (f : α →ˡᶜ β) : α →ˡᶜ γ + where + toTr := g ∘ f + map_top' := by simp + map_bot' := by simp + map_neg' := by simp + map_imply' := by simp + map_and' := by simp + map_or' := by simp + +@[simp] +lemma app_comp (g : β →ˡᶜ γ) (f : α →ˡᶜ β) (a : α) : g.comp f a = g (f a) := + rfl + +end Hom + +/-- Data and laws for And Or Closed in `FFL.LogicalConnective`. -/ +class AndOrClosed {F} [LogicalConnective F] [LogicalNeutral F] (C : F → Prop) where + verum : C ⊤ + falsum : C ⊥ + and {f g : F} : C f → C g → C (f ⋏ g) + or {f g : F} : C f → C g → C (f ⋎ g) + +/-- Data and laws for Closed in `FFL.LogicalConnective`. -/ +class Closed {F} [LogicalConnective F] [LogicalNeutral F] (C : F → Prop) extends + AndOrClosed C where + not {f : F} : C f → C (∼f) + imply {f g : F} : C f → C g → C (f ⇒ₗ g) + +end LogicalConnective + +/- +section Subclosed + +class Tilde.Subclosed [Tilde F] (C : F → Prop) where + tilde_closed : C (∼φ) → C φ + +class Arrow.Subclosed [Arrow F] (C : F → Prop) where + arrow_closed : C (φ ⇒ₗ ψ) → C φ ∧ C ψ + +class Wedge.Subclosed [Wedge F] (C : F → Prop) where + wedge_closed : C (φ ⋏ ψ) → C φ ∧ C ψ + +class Vee.Subclosed [Vee F] (C : F → Prop) where + vee_closed : C (φ ⋎ ψ) → C φ ∧ C ψ + +attribute [aesop safe 5 forward] + Tilde.Subclosed.tilde_closed + Arrow.Subclosed.arrow_closed + Wedge.Subclosed.wedge_closed + Vee.Subclosed.vee_closed + +class LogicalConnective.Subclosed [LogicalConnective F] (C : F → Prop) extends + Tilde.Subclosed C, + Arrow.Subclosed C, + Wedge.Subclosed C, + Vee.Subclosed C + +end Subclosed +-/ + +section conjdisj + +variable {α β : Type*} [LogicalConnective α] [LogicalConnective β] [LogicalNeutral α] + [LogicalNeutral β] + +/-- The conj Lt construction in `FFL`. -/ +def conjLt (φ : ℕ → α) : ℕ → α + | 0 => ⊤ + | k + 1 => φ k ⋏ conjLt φ k + +@[simp] +lemma conjLt_zero (φ : ℕ → α) : conjLt φ 0 = ⊤ := + rfl + +@[simp] +lemma conjLt_succ (φ : ℕ → α) (k) : conjLt φ (k + 1) = φ k ⋏ conjLt φ k := + rfl + +/-- Homomorphisms commute with `k`-ary conjunctions. +-/ +@[simp] +lemma hom_conj_prop [FunLike F α Prop] [LogicalConnective.HomClass F α Prop] (f : F) + (φ : ℕ → α) : f (conjLt φ k) ↔ ∀ i < k, f (φ i) := by + induction k with + | zero => simp [*] + | succ k + ih => + suffices (f (φ k) ∧ ∀ i < k, f (φ i)) ↔ ∀ i < k + 1, f (φ i) by simp [*] + constructor + · rintro ⟨hk, h⟩ + intro i hi + rcases Nat.eq_or_lt_of_le (Nat.le_of_lt_succ hi) with (rfl | hi) + · exact hk + · exact h i hi + · grind + +/-- The disj Lt construction in `FFL`. -/ +def disjLt (φ : ℕ → α) : ℕ → α + | 0 => ⊥ + | k + 1 => φ k ⋎ disjLt φ k + +@[simp] +lemma disjLt_zero (φ : ℕ → α) : disjLt φ 0 = ⊥ := + rfl + +@[simp] +lemma disjLt_succ (φ : ℕ → α) (k) : disjLt φ (k + 1) = φ k ⋎ disjLt φ k := + rfl + +/-- Homomorphisms commute with `k`-ary disjunctions. +-/ +@[simp] +lemma hom_disj_prop [FunLike F α Prop] [LogicalConnective.HomClass F α Prop] (f : F) + (φ : ℕ → α) : f (disjLt φ k) ↔ ∃ i < k, f (φ i) := by + induction k with + | zero => simp [*] + | succ k + ih => + suffices (f (φ k) ∨ ∃ i < k, f (φ i)) ↔ ∃ i < k + 1, f (φ i) by simp [*] + grind + +end conjdisj + +end FFL + +open FFL + +namespace Matrix + +open _root_.Matrix +variable {α : Type*} + +section conjunction + +variable [Top α] [Wedge α] + +/-- The conjunction of a vector of elements of type `α`, where `α` is a type with `Wedge α`. -/ +def conj : {n : ℕ} → (Fin n → α) → α + | 0, _ => ⊤ + | _ + 1, v => v 0 ⋏ conj (vecTail v) + +@[simp] +lemma conj_nil (v : Fin 0 → α) : conj v = ⊤ := + rfl + +@[simp] +lemma conj_cons {a : α} {v : Fin n → α} : conj (a :> v) = a ⋏ conj v := + rfl + +end conjunction + +section disjunction + +variable [Bot α] [Vee α] + +/-- The disjunction of a vector of elements of type `α`, where `α` is a type with `Vee α`. -/ +def disj : {n : ℕ} → (Fin n → α) → α + | 0, _ => ⊥ + | _ + 1, v => v 0 ⋎ disj (vecTail v) + +@[simp] +lemma disj_nil (v : Fin 0 → α) : disj v = ⊥ := + rfl + +@[simp] +lemma disj_cons {a : α} {v : Fin n → α} : disj (a :> v) = a ⋎ disj v := + rfl + +end disjunction + +variable [LogicalConnective α] [LogicalConnective β] [LogicalNeutral α] [LogicalNeutral β] + +/-- Homomorphisms commute with `k`-ary conjunctions (vector version). +-/ +@[simp] +lemma conj_hom_prop [FunLike F α Prop] [LogicalConnective.HomClass F α Prop] (f : F) + (v : Fin n → α) : f (conj v) = ∀ i, f (v i) := by + induction n with + | zero => simp [conj] + | succ n + ih => + suffices (f (v 0) ∧ ∀ (i : Fin n), f (vecTail v i)) ↔ ∀ (i : Fin (n + 1)), f (v i) by + simpa [conj, ih] + constructor + · intro ⟨hz, hs⟩ i; cases i using Fin.cases; + { exact hz + }; + { exact hs _ + } + · intro h; exact ⟨h 0, fun i => h _⟩ + +/-- Homomorphisms commute with `k`-ary disjunctions (vector version). +-/ +@[simp] +lemma disj_hom_prop [FunLike F α Prop] [LogicalConnective.HomClass F α Prop] (f : F) + (v : Fin n → α) : f (disj v) = ∃ i, f (v i) := by + induction n with + | zero => simp [disj] + | succ n + ih => + suffices (f (v 0) ∨ ∃ i, f (vecTail v i)) ↔ ∃ i, f (v i) by simpa [disj, ih] + constructor + · rintro (H | ⟨i, H⟩); + { exact ⟨0, H⟩ + }; + { exact ⟨i.succ, H⟩ + } + · rintro ⟨i, h⟩ + cases i using Fin.cases; + { left; exact h + }; + { right; exact ⟨_, h⟩ + } + +@[simp] +lemma hom_conj [FunLike F α β] [LogicalConnective.HomClass F α β] (f : F) (v : Fin n → α) : + f (conj v) = conj (f ∘ v) := by + induction n with + | zero => simp [conj] + | succ n ih => simp [conj, ih] + +lemma hom_conj₂ [FunLike F α β] [LogicalConnective.HomClass F α β] (f : F) (v : Fin n → α) : + f (conj v) = conj fun i => f (v i) := + hom_conj f v + +@[simp] +lemma hom_disj [FunLike F α β] [LogicalConnective.HomClass F α β] (f : F) (v : Fin n → α) : + f (disj v) = disj (f ∘ v) := by + induction n with + | zero => simp [disj] + | succ n ih => simp [disj, ih] + +lemma hom_disj' [FunLike F α β] [LogicalConnective.HomClass F α β] (f : F) (v : Fin n → α) : + f (disj v) = disj fun i => f (v i) := + hom_disj f v + +end Matrix + +namespace List + +open _root_.List +variable {α : Type*} + +variable {φ ψ : α} + +section tilde + +variable [Tilde α] + +instance : Tilde (List α) := + ⟨fun l ↦ l.map (∼·)⟩ + +lemma tilde_def (l : List α) : ∼l = l.map (∼·) := + rfl + +@[simp] +lemma tilde_nil : ∼([] : List α) = [] := + rfl + +@[simp] +lemma tilde_cons (a : α) (l : List α) : ∼(a :: l) = ∼a :: ∼l := + rfl + +@[simp] +lemma tilde_append (l k : List α) : ∼(l ++ k) = ∼l ++ ∼k := by + induction l with + | nil => simp [*] + | cons a as ih => simp [*, List.cons_append] + +@[simp] +lemma mem_tilde_iff [TildeInvolutive α] {a : α} {l : List α} : a ∈ ∼l ↔ ∼a ∈ l := by + induction l with + | nil => simp [*] + | cons b bs ih => + suffices a = ∼b ↔ ∼a = b by simp [ih, this] + constructor <;> + { rintro rfl; simp + } + +instance [TildeInvolutive α] : TildeInvolutive (List α) where + tilde_involutive + l := by + induction l with + | nil => simp [*] + | cons a as ih => simp [ih, TildeInvolutive.tilde_involutive a] + +end tilde + +section conjunction + +variable [Top α] [Wedge α] + +/-- The conj construction in `List`. -/ +def conj : List α → α + | [] => ⊤ + | a :: as => a ⋏ (PointwiseComposition.List.conj as) + +@[simp] +lemma conj_nil : conj (α := α) [] = ⊤ := + rfl + +@[simp] +lemma conj_cons {a : α} {as : List α} : + conj (a :: as) = a ⋏ (PointwiseComposition.List.conj as) := + rfl + +/-- Remark: `[φ].conj₂ = φ ≠ φ ⋏ ⊤ = [φ].conj`. -/ +def conj₂ : List α → α + | [] => ⊤ + | [φ] => φ + | φ :: ψ :: rs => φ ⋏ (PointwiseComposition.List.conj₂ (ψ :: rs)) + +/-- The conjunction of a list of members of type `α`. +-/ +prefix:80 "⋀" => List.conj₂ + +@[simp] +lemma conj₂_nil : ⋀[] = (⊤ : α) := + rfl + +@[simp] +lemma conj₂_singleton : ⋀[φ] = φ := + rfl + +@[simp] +lemma conj₂_doubleton : ⋀[φ, ψ] = φ ⋏ ψ := + rfl + +@[simp] +lemma conj₂_cons_nonempty {a : α} {as : List α} (h : as ≠ [] := by assumption) : + ⋀(a :: as) = a ⋏ ⋀as := by + cases as with + | nil => contradiction; + | cons ψ rs => simp [List.conj₂] + +/-- The conj' construction in `List`. -/ +def conj' (f : ι → α) (l : List ι) : α := + (PointwiseComposition.List.conj₂ (l.map f)) + +@[simp] +lemma conj'_nil (f : ι → α) : conj' f [] = ⊤ := + rfl + +@[simp] +lemma conj'_singleton (f : ι → α) (i : ι) : conj' f [i] = f i := + rfl + +@[simp] +lemma conj'_cons (f : ι → α) (i j : ι) (is : List ι) : + conj' f (i :: j :: is) = f i ⋏ conj' f (j :: is) := + rfl + +end conjunction + +section disjunction + +variable [Bot α] [Vee α] + +/-- The disj construction in `List`. -/ +def disj : List α → α + | [] => ⊥ + | a :: as => a ⋎ (PointwiseComposition.List.disj as) + +@[simp] +lemma disj_nil : disj (α := α) [] = ⊥ := + rfl + +@[simp] +lemma disj_cons {a : α} {as : List α} : + disj (a :: as) = a ⋎ (PointwiseComposition.List.disj as) := + rfl + +/-- Remark: `[φ].disj₂ = φ ≠ φ ⋎ ⊥ = [φ].disj`. -/ +def disj₂ : List α → α + | [] => ⊥ + | [φ] => φ + | φ :: ψ :: rs => φ ⋎ (PointwiseComposition.List.disj₂ (ψ :: rs)) + +/-- The disjunction of a list of members of type `α`. +-/ +prefix:80 "⋁" => disj₂ + +@[simp] +lemma disj₂_nil : ⋁[] = (⊥ : α) := + rfl + +@[simp] +lemma disj₂_singleton : ⋁[φ] = φ := + rfl + +@[simp] +lemma disj₂_doubleton : ⋁[φ, ψ] = φ ⋎ ψ := + rfl + +@[simp] +lemma disj₂_cons_nonempty {a : α} {as : List α} (h : as ≠ [] := by assumption) : + ⋁(a :: as) = a ⋎ ⋁as := by + cases as with + | nil => contradiction; + | cons ψ rs => simp [disj₂] + +/-- The disj' construction in `List`. -/ +def disj' (f : ι → α) (l : List ι) : α := + (PointwiseComposition.List.disj₂ (l.map f)) + +@[simp] +lemma disj'_nil (f : ι → α) : disj' f [] = ⊥ := + rfl + +@[simp] +lemma disj'_singleton (f : ι → α) (i : ι) : disj' f [i] = f i := + rfl + +@[simp] +lemma disj'_cons (f : ι → α) (i j : ι) (is : List ι) : + disj' f (i :: j :: is) = f i ⋎ disj' f (j :: is) := + rfl + +end disjunction + +section tilde + +variable [LogicalConnective α] [LogicalNeutral α] [LogicalNeutral.DeMorgan α] + [LogicalConnective.DeMorgan α] + +/-- Variadic de Morgan's law for lists of elements of type `α`. +-/ +@[simp] +lemma tilde_conj (l : List α) : + ∼(PointwiseComposition.List.disj l) = (PointwiseComposition.List.conj (∼l)) := by + match l with + | [] => simp + | a :: l => simp [tilde_conj l] + +/-- Variadic de Morgan's law for lists of elements of type `α`. +-/ +@[simp] +lemma tilde_disj (l : List α) : + ∼(PointwiseComposition.List.conj l) = (PointwiseComposition.List.disj (∼l)) := by + match l with + | [] => simp + | a :: l => simp [tilde_disj l] + +/-- Variadic de Morgan's law for lists of elements of type `α`. +-/ +@[simp] +lemma tilde_conj₂ (l : List α) : ∼⋁l = ⋀(∼l) := by + match l with + | [] => simp + | [a] => simp + | a :: b :: l => simp [tilde_conj₂ (b :: l)] + +/-- Variadic de Morgan's law for lists of elements of type `α`. +-/ +@[simp] +lemma tilde_disj₂ (l : List α) : ∼⋀l = ⋁(∼l) := by + match l with + | [] => simp + | [a] => simp + | a :: b :: l => simp [tilde_disj₂ (b :: l)] + +end tilde + +section + +variable [LogicalConnective α] [LogicalNeutral α] [LogicalConnective β] [LogicalNeutral β] + [FunLike G α β] [LogicalConnective.HomClass G α β] + +lemma map_tilde (f : G) (l : List α) : (∼l : List α).map f = ∼(l.map f) := by + induction l <;> simp [*] + +lemma map_conj (f : G) (l : List α) : + f (PointwiseComposition.List.conj l) = (PointwiseComposition.List.conj (l.map f)) := by + induction l <;> simp [*] + +lemma map_conj₂ (f : G) (l : List α) : + f (PointwiseComposition.List.conj₂ l) = (PointwiseComposition.List.conj₂ (l.map f)) := by + induction l using List.inductionWithSingleton' <;> simp [*] + +lemma map_conj' (F : G) (l : List ι) (f : ι → α) : + F ((PointwiseComposition.List.conj' · l) f) = + (PointwiseComposition.List.conj' · l) (F ∘ f) := + by induction l using List.inductionWithSingleton' <;> simp [*] + +lemma map_disj (f : G) (l : List α) : + f (PointwiseComposition.List.disj l) = (PointwiseComposition.List.disj (l.map f)) := by + induction l <;> simp [*] + +lemma map_disj₂ (f : G) (l : List α) : + f (PointwiseComposition.List.disj₂ l) = (PointwiseComposition.List.disj₂ (l.map f)) := by + induction l using List.inductionWithSingleton' <;> simp [*] + +lemma map_disj' (F : G) (l : List ι) (f : ι → α) : + F ((PointwiseComposition.List.disj' · l) f) = + (PointwiseComposition.List.disj' · l) (F ∘ f) := + by induction l using List.inductionWithSingleton' <;> simp [*] + +end + +section + +variable [LogicalConnective α] [LogicalNeutral α] [FunLike G α Prop] + [LogicalConnective.HomClass G α Prop] + +@[simp] +lemma map_conj_prop {f : G} {l : List α} : + f (PointwiseComposition.List.conj l) ↔ ∀ a ∈ l, f a := by induction l <;> simp [*] + +@[simp] +lemma map_conj₂_prop {f : G} {l : List α} : + f (PointwiseComposition.List.conj₂ l) ↔ ∀ a ∈ l, f a := by + induction l using List.inductionWithSingleton' <;> simp [*] + +lemma map_conj_append_prop (f : G) (l₁ l₂ : List α) : + f (PointwiseComposition.List.conj (l₁ ++ l₂)) ↔ + f ((PointwiseComposition.List.conj l₁) ⋏ (PointwiseComposition.List.conj l₂)) := + by induction l₁ <;> induction l₂ <;> aesop; + +@[simp] +lemma map_conj'_prop {F : G} {l : List ι} {f : ι → α} : + F ((PointwiseComposition.List.conj' · l) f) ↔ ∀ i ∈ l, F (f i) := by + induction l using List.inductionWithSingleton' <;> simp [*] + +@[simp] +lemma map_disj_prop {f : G} {l : List α} : + f (PointwiseComposition.List.disj l) ↔ ∃ a ∈ l, f a := by induction l <;> simp [*] + +@[simp] +lemma map_disj₂_prop {f : G} {l : List α} : + f (PointwiseComposition.List.disj₂ l) ↔ ∃ a ∈ l, f a := by + induction l using List.inductionWithSingleton' <;> simp [*] + +lemma map_disj_append_prop (f : G) (l₁ l₂ : List α) : + f (PointwiseComposition.List.disj (l₁ ++ l₂)) ↔ + f ((PointwiseComposition.List.disj l₁) ⋎ (PointwiseComposition.List.disj l₂)) := + by induction l₁ <;> induction l₂ <;> aesop; + +@[simp] +lemma map_disj'_prop {F : G} {l : List ι} {f : ι → α} : + F ((PointwiseComposition.List.disj' · l) f) ↔ ∃ i ∈ l, F (f i) := by + induction l using List.inductionWithSingleton' <;> simp [*] + +end + +end List + +namespace Multiset + +open _root_.Multiset +section + +variable {α : Type*} [Tilde α] + +instance : Tilde (Multiset α) := + ⟨fun Γ ↦ Γ.map (∼·)⟩ + +lemma tilde_def (Γ : Multiset α) : ∼Γ = Γ.map (∼·) := + rfl + +@[simp] +lemma tilde_zero : ∼(0 : Multiset α) = 0 := + rfl + +@[simp] +lemma tilde_add (Γ Δ : Multiset α) : ∼(Γ + Δ) = ∼Γ + ∼Δ := by simp [tilde_def] + +@[simp] +lemma tilde_atom (φ : α) : ∼(⦃φ⦄ : Multiset α) = ⦃∼φ⦄ := by simp [tilde_def] + +@[simp] +lemma mem_tilde_iff [TildeInvolutive α] {φ : α} {Γ : Multiset α} : φ ∈ ∼Γ ↔ ∼φ ∈ Γ := + by + rw [tilde_def] + constructor + · intro h + rcases Multiset.mem_map.mp h with ⟨ψ, hψ, rfl⟩ + simpa using hψ + · intro hφ + simpa using Multiset.mem_map_of_mem (fun ψ ↦ ∼ψ) hφ + +instance [TildeInvolutive α] : TildeInvolutive (Multiset α) where + tilde_involutive Γ := by simp [tilde_def, Multiset.map_map] + +end + +lemma map_tilde_comm [LogicalNeutral α] [LogicalConnective α] [LogicalNeutral β] + [LogicalConnective β] {Γ : Multiset α} (f : α →ˡᶜ β) : (∼Γ).map f = ∼Γ.map f := by + simp [Multiset.tilde_def] + +end Multiset + +namespace Finset + +open _root_.Finset + +variable {α : Type*} + +section tilde + +variable [Tilde α] [TildeInvolutive α] + +instance : Tilde (Finset α) := + ⟨fun l ↦ l.map Tilde.invol⟩ + +lemma tilde_def (s : Finset α) : ∼s = s.map Tilde.invol := + rfl + +@[simp] +lemma mem_tilde_iff {a : α} {s : Finset α} : a ∈ ∼s ↔ ∼a ∈ s := by simp [tilde_def]; grind + +instance : TildeInvolutive (Finset α) where tilde_involutive s := by ext a; simp + +@[simp] +lemma tilde_empty : ∼(∅ : Finset α) = ∅ := + rfl + +open _root_.Classical in +@[simp] +lemma tilde_insert (a : α) (s : Finset α) : ∼(insert a s) = insert (∼a) (∼s) := by + simp [tilde_def] + +open _root_.Classical in +@[simp] +lemma tilde_union (s t : Finset α) : ∼(s ∪ t) = ∼s ∪ ∼t := by simp [tilde_def, Finset.map_union] + +end tilde + +/-- The conj construction in `Finset`. -/ +noncomputable def conj [Top α] [Wedge α] (s : Finset α) : α := + (PointwiseComposition.List.conj₂ s.toList) + +/-- The conj' construction in `Finset`. -/ +noncomputable def conj' [Top α] [Wedge α] (s : Finset ι) (f : ι → α) : α := + (PointwiseComposition.List.conj' · s.toList) f + +/-- The uconj construction in `Finset`. -/ +noncomputable def uconj [Top α] [Wedge α] [Fintype ι] (f : ι → α) : α := + (PointwiseComposition.Finset.conj' (Finset.univ : Finset ι)) f + +/-- The disj construction in `Finset`. -/ +noncomputable def disj [Bot α] [Vee α] (s : Finset α) : α := + (PointwiseComposition.List.disj₂ s.toList) + +/-- The disj' construction in `Finset`. -/ +noncomputable def disj' [Bot α] [Vee α] (s : Finset ι) (f : ι → α) : α := + (PointwiseComposition.List.disj' · s.toList) f + +/-- The udisj construction in `Finset`. -/ +noncomputable def udisj [Bot α] [Vee α] [Fintype ι] (f : ι → α) : α := + (PointwiseComposition.Finset.disj' (Finset.univ : Finset ι)) f + +section + +open _root_.Lean Lean PrettyPrinter Delaborator SubExpr + +/-- - `⋀ i ∈ s, φ i` is notation for `s.conj' fun i ↦ φ i` +- `⋀ i, φ i` is notation for `uconj fun i ↦ φ i` +-/ +syntax (name := biguconj) "⋀ " Parser.Term.funBinder (" : "term)? (" ∈ "term)? ", " term:0 : + term + +macro_rules (kind := biguconj) + | `(⋀ $i:ident : $ι, $v) => `(uconj fun $i : $ι ↦ $v) + | `(⋀ $i:ident, $v) => `(uconj fun $i ↦ $v) + | `(⋀ $i:ident : $ι ∈ $s:term, $v) => `(Finset.conj' $s fun $i : $ι ↦ $v) + | `(⋀ $i:ident ∈ $s:term, $v) => `(Finset.conj' $s fun $i ↦ $v) + + + + + + + +/-- The uconj Unexpsnder construction in `Finset`. -/ +@[app_unexpander uconj] +meta def uconjUnexpsnder : Unexpander + | `($_ fun $i ↦ $v) => `(⋀ $i, $v) + | _ => throw () + + + + + + + +/-- The conj'Unexpsnder construction in `Finset`. -/ +@[app_unexpander Finset.conj'] +meta def conj'Unexpsnder : Unexpander + | `($_ $s fun $i ↦ $v) => `(⋀ $i ∈ $s, $v) + | _ => throw () + + + + + + + +/-- - `⋁ i ∈ s, φ i` is notation for `s.disj' fun i ↦ φ i` +- `⋁ i, φ i` is notation for `udisj fun i ↦ φ i` +-/ +syntax (name := bigudisj) "⋁ " Parser.Term.funBinder (" : "term)? (" ∈ "term)? ", " term:0 : + term + +macro_rules (kind := bigudisj) + | `(⋁ $i:ident : $ι, $v) => `(udisj fun $i : $ι ↦ $v) + | `(⋁ $i:ident, $v) => `(udisj fun $i ↦ $v) + | `(⋁ $i:ident : $ι ∈ $s:term, $v) => `(Finset.disj' $s fun $i : $ι ↦ $v) + | `(⋁ $i:ident ∈ $s:term, $v) => `(Finset.disj' $s fun $i ↦ $v) + + + + + + + +/-- The udisj Unexpsnder construction in `Finset`. -/ +@[app_unexpander udisj] +meta def udisjUnexpsnder : Unexpander + | `($_ fun $i ↦ $v) => `(⋁ $i, $v) + | _ => throw () + + + + + + + +/-- The disj'Unexpsnder construction in `Finset`. -/ +@[app_unexpander Finset.disj'] +meta def disj'Unexpsnder : Unexpander + | `($_ $s fun $i ↦ $v) => `(⋁ $i ∈ $s, $v) + | _ => throw () + + + + + + + +end + +section conjunction + +variable [Top α] [Wedge α] + +@[simp] +lemma conj_empty : conj (∅ : Finset α) = ⊤ := by simp [conj] + +@[simp] +lemma conj_singleton (a : α) : conj { a } = a := by simp [conj] + +@[simp] +lemma conj'_empty (f : ι → α) : (PointwiseComposition.Finset.conj' (∅ : Finset ι)) f = ⊤ := by + simp [conj'] + +@[simp] +lemma conj'_singleton (f : ι → α) {i : ι} : + (PointwiseComposition.Finset.conj' ({ i } : Finset ι)) f = f i := by simp [conj'] + +@[simp] +lemma uconj_empty [Fintype ι] [IsEmpty ι] (f : ι → α) : uconj f = ⊤ := by simp [uconj] + +@[simp] +lemma uconj_singleton [Fintype ι] [Unique ι] (f : ι → α) : uconj f = f default := by + simp [uconj] + +end conjunction + +section disjunction + +variable [Bot α] [Vee α] + +@[simp] +lemma disj_empty : (PointwiseComposition.Finset.disj (∅ : Finset α)) = ⊥ := by simp [disj] + +@[simp] +lemma disj_singleton (a : α) : (PointwiseComposition.Finset.disj ({ a } : Finset α)) = a := by + simp [disj] + +@[simp] +lemma disj'_empty (f : ι → α) : (PointwiseComposition.Finset.disj' (∅ : Finset ι)) f = ⊥ := by + simp [disj'] + +@[simp] +lemma disj'_singleton (f : ι → α) (i : ι) : + (PointwiseComposition.Finset.disj' ({ i } : Finset ι)) f = f i := by simp [disj'] + +@[simp] +lemma udisj_empty [Fintype ι] [IsEmpty ι] (f : ι → α) : udisj f = ⊥ := by simp [udisj] + +@[simp] +lemma udisj_singleton [Fintype ι] [Unique ι] (f : ι → α) : udisj f = f default := by + simp [udisj] + +end disjunction + +variable [LogicalConnective α] [LogicalNeutral α] [LogicalConnective β] [LogicalNeutral β] + +@[simp] +lemma map_conj_prop [FunLike F α Prop] [LogicalConnective.HomClass F α Prop] {f : F} + {s : Finset α} : f (PointwiseComposition.Finset.conj s) ↔ ∀ a ∈ s, f a := by simp [conj] + +lemma map_conj_union [DecidableEq α] [FunLike F α Prop] [LogicalConnective.HomClass F α Prop] + (f : F) (s₁ s₂ : Finset α) : + f (PointwiseComposition.Finset.conj (s₁ ∪ s₂)) ↔ + f ((PointwiseComposition.Finset.conj s₁) ⋏ (PointwiseComposition.Finset.conj s₂)) := + by + suffices (∀ (a : α), a ∈ s₁ ∨ a ∈ s₂ → f a) ↔ (∀ a ∈ s₁, f a) ∧ ∀ a ∈ s₂, f a by simpa + grind + +lemma map_conj' [FunLike F α β] [LogicalConnective.HomClass F α β] (Φ : F) (s : Finset ι) + (f : ι → α) : Φ (⋀ i ∈ s, f i) = ⋀ i ∈ s, Φ (f i) := by + simp [conj', Function.comp_def, List.map_conj'] + +@[simp] +lemma map_conj'_prop [FunLike F α Prop] [LogicalConnective.HomClass F α Prop] {f : F} + {s : Finset ι} {p : ι → α} : + f ((PointwiseComposition.Finset.conj' s) p) ↔ ∀ i ∈ s, f (p i) := by simp [conj'] + +lemma map_uconj [FunLike F α β] [LogicalConnective.HomClass F α β] (Φ : F) [Fintype ι] + (f : ι → α) : Φ (⋀ i, f i) = ⋀ i, Φ (f i) := by simp [uconj, map_conj'] + +@[simp] +lemma map_uconj_prop [FunLike F α Prop] [LogicalConnective.HomClass F α Prop] {Φ : F} + [Fintype ι] {f : ι → α} : Φ (uconj f) ↔ ∀ i, Φ (f i) := by simp [uconj] + +@[simp] +lemma map_disj_prop [FunLike F α Prop] [LogicalConnective.HomClass F α Prop] (f : F) + (s : Finset α) : f (PointwiseComposition.Finset.disj s) ↔ ∃ a ∈ s, f a := by simp [disj] + +lemma map_disj_union [DecidableEq α] [FunLike F α Prop] [LogicalConnective.HomClass F α Prop] + (f : F) (s₁ s₂ : Finset α) : + f (PointwiseComposition.Finset.disj (s₁ ∪ s₂)) ↔ + f ((PointwiseComposition.Finset.disj s₁) ⋎ (PointwiseComposition.Finset.disj s₂)) := + by + suffices (∃ a, (a ∈ s₁ ∨ a ∈ s₂) ∧ f a) ↔ (∃ a ∈ s₁, f a) ∨ ∃ a ∈ s₂, f a by + simpa [map_disj_prop] + grind + +lemma map_disj' [FunLike F α β] [LogicalConnective.HomClass F α β] (Φ : F) (s : Finset ι) + (f : ι → α) : Φ (⋁ i ∈ s, f i) = ⋁ i ∈ s, Φ (f i) := by + simp [disj', List.map_disj', Function.comp_def] + +@[simp] +lemma map_disj'_prop [FunLike F α Prop] [LogicalConnective.HomClass F α Prop] {f : F} + {s : Finset ι} {p : ι → α} : + f ((PointwiseComposition.Finset.disj' s) p) ↔ ∃ i ∈ s, f (p i) := by simp [disj'] + +lemma map_udisj [FunLike F α β] [LogicalConnective.HomClass F α β] (Φ : F) [Fintype ι] + (f : ι → α) : Φ (⋁ i, f i) = ⋁ i, Φ (f i) := by simp [udisj, map_disj'] + +@[simp] +lemma map_udisj_prop [FunLike F α Prop] [LogicalConnective.HomClass F α Prop] {Φ : F} + [Fintype ι] {f : ι → α} : Φ (udisj f) ↔ ∃ i, Φ (f i) := by simp [udisj] + +end Finset + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/Logic/Semantics.lean b/LeanPool/PointwiseComposition/Foundation/Logic/Semantics.lean new file mode 100644 index 000000000..0f81ff018 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/Logic/Semantics.lean @@ -0,0 +1,424 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. +public import LeanPool.PointwiseComposition.Foundation.Logic.LogicSymbol + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# Basic definitions and properties of semantics-related notions + +This file defines the semantics of formulas based on Tarski's truth definitions. +Also provides 𝓜 characterization of compactness. + +## Main Definitions +* `FFL.Semantics`: The realization of 𝓜 formula. +* `FFL.Compact`: The semantic compactness of Foundation. + +## Notation +* `𝓜 ⊧ φ`: a proposition that states `𝓜` satisfies `φ`. +* `𝓜 ⊧* T`: a proposition that states that `𝓜` satisfies each formulae in a set `T`. + +-/ + +@[expose] public section + +namespace FFL + +/-- `Semantics M F` denotes semantics of formulae `F for models `M` -/ +class Semantics (M : Type*) (F : outParam Type*) where + /-- The Models construction in `FFL.Semantics`. -/ + Models : M → F → Prop + +variable {M : Type*} {F : Type*} [𝓢 : Semantics M F] + +namespace Semantics + +/-- The «term ⊧ » construction in `FFL.Semantics`. -/ +infix:45 " ⊧ " => Models + +/-- The negation of `𝓜 ⊧ φ` -/ +abbrev NotModels (𝓜 : M) (φ : F) : Prop := + ¬𝓜 ⊧ φ + +/-- The «term ⊭ » construction in `FFL.Semantics`. -/ +infix:45 " ⊭ " => NotModels + +/-! +### Tarski's truth definitions -/ + +section + +variable [LogicalConnective F] [LogicalNeutral F] (M) + +/-- Tarski's truth definition for `⊤`. -/ +protected class Top where + models_verum (𝓜 : M) : 𝓜 ⊧ (⊤ : F) + +/-- Tarski's truth definition for `⊥`. -/ +protected class Bot where + models_falsum (𝓜 : M) : ¬𝓜 ⊧ (⊥ : F) + +/-- Tarski's truth definition for `⋏`. -/ +protected class And where + models_and {𝓜 : M} {φ ψ : F} : 𝓜 ⊧ φ ⋏ ψ ↔ 𝓜 ⊧ φ ∧ 𝓜 ⊧ ψ + +/-- Tarski's truth definition for `⋎`. -/ +protected class Or where + models_or {𝓜 : M} {φ ψ : F} : 𝓜 ⊧ φ ⋎ ψ ↔ 𝓜 ⊧ φ ∨ 𝓜 ⊧ ψ + +/-- Tarski's truth definition for `⇒ₗ`. -/ +protected class Imp where + models_imply {𝓜 : M} {φ ψ : F} : 𝓜 ⊧ φ ⇒ₗ ψ ↔ (𝓜 ⊧ φ → 𝓜 ⊧ ψ) + +/-- Tarski's truth definition for `∼`. -/ +protected class Not where + models_not {𝓜 : M} {φ : F} : 𝓜 ⊧ ∼φ ↔ ¬𝓜 ⊧ φ + +/-- Tarski's truth definitions. -/ +class Tarski extends Semantics.Top M, Semantics.Bot M, Semantics.And M, Semantics.Or M, + Semantics.Imp M, Semantics.Not M where + +attribute [simp, grind .] Top.models_verum Bot.models_falsum + +attribute [simp, grind =] Not.models_not And.models_and Or.models_or Imp.models_imply + +variable {M} + +variable [Tarski M] + +variable {𝓜 : M} + +@[simp] +lemma models_iff {φ ψ : F} : 𝓜 ⊧ φ ⇔ₗ ψ ↔ (𝓜 ⊧ φ ↔ 𝓜 ⊧ ψ) := by + simp [LogicalConnective.iff, iff_iff_implies_and_implies] + +@[simp] +lemma models_list_conj {l : List F} : 𝓜 ⊧ (PointwiseComposition.List.conj l) ↔ ∀ φ ∈ l, 𝓜 ⊧ φ := + by induction l <;> simp [*] + +@[simp] +lemma models_list_conj₂ {l : List F} : 𝓜 ⊧ ⋀l ↔ ∀ φ ∈ l, 𝓜 ⊧ φ := by + induction l using List.induction_with_singleton <;> simp [*] + +@[simp] +lemma models_list_conj' {l : List α} {ι : α → F} : + 𝓜 ⊧ (PointwiseComposition.List.conj' · l) ι ↔ ∀ i ∈ l, 𝓜 ⊧ ι i := by simp [List.conj'] + +@[simp] +lemma models_finset_conj {s : Finset F} : + 𝓜 ⊧ (PointwiseComposition.Finset.conj s) ↔ ∀ φ ∈ s, 𝓜 ⊧ φ := by simp [Finset.conj] + +@[simp] +lemma models_finset_conj' {s : Finset α} {ι : α → F} : + 𝓜 ⊧ (PointwiseComposition.Finset.conj' s) ι ↔ ∀ i ∈ s, 𝓜 ⊧ ι i := by simp [Finset.conj'] + +@[simp] +lemma models_list_disj {l : List F} : 𝓜 ⊧ (PointwiseComposition.List.disj l) ↔ ∃ φ ∈ l, 𝓜 ⊧ φ := + by induction l <;> simp [*] + +@[simp] +lemma models_list_disj₂ {l : List F} : 𝓜 ⊧ ⋁l ↔ ∃ φ ∈ l, 𝓜 ⊧ φ := by + induction l using List.induction_with_singleton <;> simp [*] + +@[simp] +lemma models_list_disj' {l : List α} {ι : α → F} : + 𝓜 ⊧ (PointwiseComposition.List.disj' · l) ι ↔ ∃ i ∈ l, 𝓜 ⊧ ι i := by simp [List.disj'] + +@[simp] +lemma models_finset_disj {s : Finset F} : + 𝓜 ⊧ (PointwiseComposition.Finset.disj s) ↔ ∃ φ ∈ s, 𝓜 ⊧ φ := by simp [Finset.disj] + +@[simp] +lemma models_finset_disj' {s : Finset α} {ι : α → F} : + 𝓜 ⊧ (PointwiseComposition.Finset.disj' s) ι ↔ ∃ i ∈ s, 𝓜 ⊧ ι i := by simp [Finset.disj'] + +end + +/-! +### A semantics and satisfiability over a set of formulas -/ + +/-- `𝓜 ⊧* T` denotes `𝓜 ⊧ φ` for all `φ` in `T`. -/ +class ModelsSet (𝓜 : M) (T : Set F) : Prop where + models_set : ∀ ⦃φ⦄, φ ∈ T → Models 𝓜 φ + +/-- The «term ⊧* » construction in `FFL.Semantics`. -/ +infix:45 " ⊧* " => ModelsSet + +variable (M) + +/-- The Valid construction in `FFL.Semantics`. -/ +def Valid (φ : F) : Prop := + ∀ 𝓜 : M, 𝓜 ⊧ φ + +/-- The Satisfiable construction in `FFL.Semantics`. -/ +def Satisfiable (T : Set F) : Prop := + ∃ 𝓜 : M, 𝓜 ⊧* T + +/-- A set of models satisfies set of formulae `T`. -/ +def models (T : Set F) : Set M := + {𝓜 | 𝓜 ⊧* T} + +variable {M} + +/-- A set of formulae satisfied by model `𝓜`. -/ +def theory (𝓜 : M) : Set F := + {φ | 𝓜 ⊧ φ} + +/-- Data and laws for Meaningful in `FFL.Semantics`. -/ +class Meaningful (𝓜 : M) : Prop where + exists_unmodels : ∃ φ, 𝓜 ⊭ φ + +instance [LogicalNeutral F] [Semantics.Bot M] (𝓜 : M) : Meaningful 𝓜 := + ⟨⟨⊥, by grind⟩⟩ + +lemma meaningful_iff {𝓜 : M} : Meaningful 𝓜 ↔ ∃ φ, 𝓜 ⊭ φ := + ⟨by rintro ⟨h⟩; exact h, fun h ↦ ⟨h⟩⟩ + +lemma not_meaningful_iff (𝓜 : M) : ¬Meaningful 𝓜 ↔ ∀ φ, 𝓜 ⊧ φ := by simp [meaningful_iff] + +lemma modelsSet_iff {𝓜 : M} {T : Set F} : 𝓜 ⊧* T ↔ ∀ ⦃φ⦄, φ ∈ T → Models 𝓜 φ := + ⟨by rintro ⟨h⟩ φ hf; exact h hf, by intro h; exact ⟨h⟩⟩ + +@[simp] +lemma modelsTheory_theory (𝓜 : M) : 𝓜 ⊧* theory 𝓜 := + ⟨by simp [theory]⟩ + +@[simp] +lemma theory_satisfiable (𝓜 : M) : Satisfiable M (theory 𝓜) := + ⟨𝓜, by simp⟩ + +lemma not_satisfiable_finset [LogicalConnective F] [LogicalNeutral F] [Tarski M] [DecidableEq F] + (t : Finset F) : + ¬Satisfiable M (t : Set F) ↔ Valid M (PointwiseComposition.Finset.disj (t.image (∼·))) := by + simp [Satisfiable, modelsSet_iff, Valid]; + +@[simp] +lemma satisfiable_conj₂ [LogicalConnective F] [LogicalNeutral F] [Tarski M] (l : List F) : + Satisfiable M {⋀l} ↔ Satisfiable M {φ | φ ∈ l} := by + classical simp [Satisfiable, modelsSet_iff] + +@[simp] +lemma satisfiable_fconj [LogicalConnective F] [LogicalNeutral F] [Tarski M] (s : Finset F) : + Satisfiable M {Finset.conj s} ↔ Satisfiable M {φ | φ ∈ s} := by + classical simp [Satisfiable, modelsSet_iff] + +lemma satisfiableSet_iff_models_nonempty {T : Set F} : + Satisfiable M T ↔ (models M T).Nonempty := + ⟨by rintro ⟨𝓜, h𝓜⟩; exact ⟨𝓜, h𝓜⟩, by rintro ⟨𝓜, h𝓜⟩; exact ⟨𝓜, h𝓜⟩⟩ + +namespace ModelsSet + +lemma models {T : Set F} (𝓜 : M) [𝓜 ⊧* T] (hf : φ ∈ T) : 𝓜 ⊧ φ := + models_set hf + +lemma of_subset {T U : Set F} {𝓜 : M} (h : 𝓜 ⊧* U) (ss : T ⊆ U) : 𝓜 ⊧* T := + ⟨fun _ hf => h.models_set (ss hf)⟩ + +lemma of_subset' {T U : Set F} {𝓜 : M} [𝓜 ⊧* U] (ss : T ⊆ U) : 𝓜 ⊧* T := + of_subset (𝓜 := 𝓜) inferInstance ss + +instance empty' (𝓜 : M) : 𝓜 ⊧* (∅ : Set F) := + ⟨by simp⟩ + +@[simp] +lemma empty (𝓜 : M) : 𝓜 ⊧* (∅ : Set F) := + ⟨by simp⟩ + +@[simp] +lemma singleton_iff {φ : F} {𝓜 : M} : 𝓜 ⊧* { φ } ↔ 𝓜 ⊧ φ := by simp [modelsSet_iff] + +@[simp] +lemma insert_iff {T : Set F} {φ : F} {𝓜 : M} : 𝓜 ⊧* insert φ T ↔ 𝓜 ⊧ φ ∧ 𝓜 ⊧* T := by + simp [modelsSet_iff] + +@[simp] +lemma union_iff {T U : Set F} {𝓜 : M} : 𝓜 ⊧* T ∪ U ↔ 𝓜 ⊧* T ∧ 𝓜 ⊧* U := + by + simp only [modelsSet_iff, Set.mem_union] + constructor + · intro h + exact ⟨fun _ hf => h (Or.inl hf), fun _ hf => h (Or.inr hf)⟩ + · rintro ⟨h₁, h₂⟩ φ (h | h) + · exact h₁ h + · exact h₂ h + +@[simp] +lemma image_iff {ι} {φ : ι → F} {A : Set ι} {𝓜 : M} : 𝓜 ⊧* φ '' A ↔ ∀ i ∈ A, 𝓜 ⊧ φ i := by + simp [modelsSet_iff] + +@[simp] +lemma range_iff {ι} {φ : ι → F} {𝓜 : M} : 𝓜 ⊧* Set.range φ ↔ ∀ i, 𝓜 ⊧ φ i := by + simp [modelsSet_iff] + +@[simp] +lemma setOf_iff {P : F → Prop} {𝓜 : M} : 𝓜 ⊧* Set.ofPred P ↔ ∀ φ, P φ → 𝓜 ⊧ φ := + by + rw [modelsSet_iff] + exact Iff.rfl + +end ModelsSet + +lemma valid_neg_iff [LogicalConnective F] [LogicalNeutral F] [Tarski M] (φ : F) : + Valid M (∼φ) ↔ ¬Satisfiable M { φ } := by simp [Valid, Satisfiable] + +lemma Satisfiable.of_subset {T U : Set F} (h : Satisfiable M U) (ss : T ⊆ U) : + Satisfiable M T := by rcases h with ⟨𝓜, h⟩; exact ⟨𝓜, ModelsSet.of_subset h ss⟩ + +variable (M) + +instance : Semantics (Set M) F := + ⟨fun s φ ↦ ∀ ⦃𝓜⦄, 𝓜 ∈ s → 𝓜 ⊧ φ⟩ + +@[simp] +lemma empty_models (φ : F) : (∅ : Set M) ⊧ φ := by rintro h; simp + +/-! +Logical consequence -/ + +/-- The logical conseqence. -/ +def Consequence (T : Set F) (φ : F) : Prop := + models M T ⊧ φ + +/-- The «term ⊨[ ] » construction in `FFL.Semantics`. -/ +notation T:45 " ⊨[" M "] " φ:46 => Consequence M T φ + +variable {M} + +lemma set_models_iff {s : Set M} : s ⊧ φ ↔ ∀ 𝓜 ∈ s, 𝓜 ⊧ φ := + iff_of_eq rfl + +instance [LogicalNeutral F] [Semantics.Top M] : Semantics.Top (Set M) := + ⟨fun s ↦ by simp [set_models_iff]⟩ + +lemma set_meaningful_iff_nonempty [∀ 𝓜 : M, Meaningful 𝓜] {s : Set M} : + Meaningful s ↔ s.Nonempty := by + constructor; + · rintro ⟨φ, hf⟩; by_contra A; rcases Set.not_nonempty_iff_eq_empty.mp A; + simp [NotModels] at hf; + · rintro ⟨𝓜, h𝓜⟩; rcases Meaningful.exists_unmodels (self := by tauto) with ⟨φ, hf⟩; + exact ⟨φ, by simpa [NotModels, set_models_iff] using ⟨𝓜, h𝓜, hf⟩⟩ + +lemma meaningful_iff_satisfiableSet [∀ 𝓜 : M, Meaningful 𝓜] : + Satisfiable M T ↔ Meaningful (models M T) := by + simp [set_meaningful_iff_nonempty, satisfiableSet_iff_models_nonempty] + +lemma consequence_iff {T : Set F} {φ} : T ⊨[M] φ ↔ ∀ {𝓜 : M}, 𝓜 ⊧* T → 𝓜 ⊧ φ := + iff_of_eq rfl + +lemma consequence_iff' {T : Set F} {φ : F} : T ⊨[M] φ ↔ (∀ (𝓜 : M) [𝓜 ⊧* T], 𝓜 ⊧ φ) := + ⟨fun h _ _ => consequence_iff.mp h inferInstance, fun H 𝓜 hs => @H 𝓜 hs⟩ + +lemma consequence_iff_not_satisfiable [LogicalConnective F] [LogicalNeutral F] [Tarski M] + {φ : F} : T ⊨[M] φ ↔ ¬Satisfiable M (insert (∼φ) T) := + by + suffices (∀ {𝓜 : M}, 𝓜 ⊧* T → 𝓜 ⊧ φ) ↔ ∀ (x : M), x ⊭ φ → ¬x ⊧* T by + simpa [consequence_iff, Satisfiable] + constructor + · intro h 𝓜 hf hT; have : 𝓜 ⊧ φ := h hT; contradiction + · intro h 𝓜; contrapose; exact h 𝓜 + +lemma weakening {T U : Set F} {φ} (h : T ⊨[M] φ) (ss : T ⊆ U) : U ⊨[M] φ := + consequence_iff.mpr fun hs => consequence_iff.mp h (ModelsSet.of_subset hs ss) + +lemma of_mem {T : Set F} {φ} (h : φ ∈ T) : T ⊨[M] φ := fun _ hs => hs.models_set h + +end Semantics + +/-! +Compactness -/ + +/-- A cumulative sequence of sets. -/ +def Cumulative (T : ℕ → Set F) : Prop := + ∀ s, T s ⊆ T (s + 1) + +namespace Cumulative + +lemma subset_of_le {T : ℕ → Set F} (H : Cumulative T) {s₁ s₂ : ℕ} (h : s₁ ≤ s₂) : T s₁ ⊆ T s₂ := + by + suffices ∀ s d, T s ⊆ T (s + d) by simpa [Nat.add_sub_of_le h] using this s₁ (s₂ - s₁) + intro s d + induction d with + | zero => simp + | succ d ih => simpa only [Nat.add_succ, add_zero] using subset_trans ih (H (s + d)) + +lemma finset_mem {T : ℕ → Set F} (H : Cumulative T) {u : Finset F} (hu : ↑u ⊆ ⋃ s, T s) : + ∃ s, ↑u ⊆ T s := by + have := Classical.decEq + induction u using Finset.induction + case empty => exact ⟨0, by simp⟩ + case insert φ u _ + ih => + have hu : insert φ ↑u ⊆ ⋃ s, T s := by simpa using hu + have : ∃ s, ↑u ⊆ T s := ih (subset_trans (Set.subset_insert _ _) hu) + rcases this with ⟨s, hs⟩ + have : ∃ s', φ ∈ T s' := by simpa using (Set.insert_subset_iff.mp hu).1 + rcases this with ⟨s', hs'⟩ + exact + ⟨max s s', by + simpa using + Set.insert_subset (subset_of_le H (Nat.le_max_right s s') hs') + (subset_trans hs (subset_of_le H <| Nat.le_max_left s s'))⟩ + +end Cumulative + +variable (M) + +/-- +A `Semantics M F` is compact if, for any set of formulas, the satisfiability of the set is +equivalent to the satisfiability of every finite subset of it. -/ +class Compact : Prop where + compact {T : Set F} : + Semantics.Satisfiable M T ↔ (∀ u : Finset F, ↑u ⊆ T → Semantics.Satisfiable M (u : Set F)) + +variable {M} + +namespace Compact + +variable [Compact M] + +variable {𝓜 : M} + +lemma conseq_compact [LogicalConnective F] [LogicalNeutral F] [Semantics.Tarski M] {φ : F} : + T ⊨[M] φ ↔ ∃ u : Finset F, ↑u ⊆ T ∧ u ⊨[M] φ := by + classical + suffices + (∃ x : Finset F, ↑x ⊆ insert (∼φ) T ∧ ¬Semantics.Satisfiable M ↑x) ↔ + ∃ u : Finset F, ↑u ⊆ T ∧ ¬Semantics.Satisfiable M (insert (∼φ) ↑u) + by simpa [Semantics.consequence_iff_not_satisfiable, compact (T := insert (∼φ) T)] + constructor + · intro ⟨u, ss, hu⟩ + refine ⟨Finset.erase u (∼φ), by simp [ss], ?_⟩ + simp only [Finset.coe_erase, Set.insert_sdiff_singleton] + intro h; exact hu (Semantics.Satisfiable.of_subset h (by simp)) + · intro ⟨u, ss, hu⟩ + exact ⟨insert (∼φ) u, by simpa using Set.insert_subset_insert ss, by simpa using hu⟩ + +lemma compact_cumulative {T : ℕ → Set F} (hT : Cumulative T) : + Semantics.Satisfiable M (⋃ s, T s) ↔ ∀ s, Semantics.Satisfiable M (T s) := + ⟨by + intro H s + exact H.of_subset (Set.subset_iUnion T s), + by + intro H + apply compact.mpr + intro u hu + rcases hT.finset_mem hu with ⟨s, hs⟩ + exact (H s).of_subset hs⟩ + +end Compact + +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/Meta/ClProver.lean b/LeanPool/PointwiseComposition/Foundation/Meta/ClProver.lean new file mode 100644 index 000000000..2c129e683 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/Meta/ClProver.lean @@ -0,0 +1,509 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.Meta.ClProverTheorems +public meta import LeanPool.PointwiseComposition.Foundation.Meta.ClProverTheorems +public import Mathlib.Util.AtomM + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# Proof automation based on the proof search on $\mathbf{LK}$ +-/ + +public meta section + +namespace FFL +namespace Meta + +open _root_.Lean Mathlib _root_.Qq Qq Lean Elab Meta Tactic + +namespace ClProver + +initialize + registerTraceClass `cl_prover + +/-- The cl prover construction in `FFL.Meta.ClProver`. -/ +structure Context where + /-- The level F construction in `FFL.Meta.ClProver.Context`. -/ + levelF : Level + /-- The level S construction in `FFL.Meta.ClProver.Context`. -/ + levelS : Level + /-- The level E construction in `FFL.Meta.ClProver.Context`. -/ + levelE : Level + /-- The F construction in `FFL.Meta.ClProver.Context`. -/ + F : Q(Type levelF) + /-- The LC construction in `FFL.Meta.ClProver.Context`. -/ + LC : Q(LogicalConnective $F) + /-- The LN construction in `FFL.Meta.ClProver.Context`. -/ + LN : Q(LogicalNeutral $F) + /-- The S construction in `FFL.Meta.ClProver.Context`. -/ + S : Q(Type levelS) + /-- The E construction in `FFL.Meta.ClProver.Context`. -/ + E : Q(Entailment.{_, _, levelE} $S $F) + /-- The 𝓢 construction in `FFL.Meta.ClProver.Context`. -/ + 𝓢 : Q($S) + /-- The CL construction in `FFL.Meta.ClProver.Context`. -/ + CL : Q(Entailment.Cl $𝓢) + +/-- The monad for `cl_prover` contains. -/ +abbrev M := + ReaderT Context AtomM + +/-- Apply the function + `n : ∀ {F} [LogicalConnective F] [LogicalNeutral F] {S} [Entailment S F] {𝓢} [Entailment.Cl + 𝓢], _` to the +implicit parameters in the context, and the given list of arguments. -/ +def Context.app (c : Context) (n : Name) : Array Expr → Expr := + mkAppN <| + mkAppN (Expr.const n [c.levelF, c.levelS, c.levelE]) #[c.F, c.LC, c.LN, c.S, c.E, c.𝓢, c.CL] + +/-- The iapp construction in `FFL.Meta.ClProver`. -/ +def iapp (n : Name) (xs : Array Expr) : M Expr := do + let c ← read + return c.app n xs + +/-- The get Goal Two Sided construction in `FFL.Meta.ClProver`. -/ +def getGoalTwoSided (e : Q(Prop)) : MetaM ((c : Context) × List Q($c.F) × List Q($c.F)) := do + let ~q(@Entailment.TwoSided $F $LC $LN $S $E $𝓢 $p $q) := e | throwError + m!"(getGoal) error: {e} not a form of _ ⊢ _" + let .some CL ← trySynthInstanceQ q(Entailment.Cl $𝓢) + | throwError m! "error: failed to find instance Entailment.Cl {𝓢}" + let Γ ← Qq.ofQList p + let Δ ← Qq.ofQList q + return ⟨⟨_, _, _, F, LC, LN, S, E, 𝓢, CL⟩, Γ, Δ⟩ + + + + + + + +/-- The get Goal Provable construction in `FFL.Meta.ClProver`. -/ +def getGoalProvable (e : Q(Prop)) : MetaM ((c : Context) × Q($c.F)) := do + let ~q(@Entailment.Provable $F $S $E $𝓢 $p) := e | throwError + m!"(getGoal) error: {e} not a form of _ ⊢ _" + let .some LC ← trySynthInstanceQ q(LogicalConnective $F) + | throwError m! "error: failed to find instance LogicalConnective {F}" + let .some LN ← trySynthInstanceQ q(LogicalNeutral $F) + | throwError m! "error: failed to find instance LogicalNeutral {F}" + let .some CL ← trySynthInstanceQ q(Entailment.Cl $𝓢) + | throwError m! "error: failed to find instance Entailment.Cl {𝓢}" + return ⟨⟨_, _, _, F, LC, LN, S, E, 𝓢, CL⟩, p⟩ + + + + + + + +/-- The Sequent construction in `FFL.Meta.ClProver`. -/ +abbrev Sequent := + List Lit + +/-- The lit To Expr construction in `FFL.Meta.ClProver`. -/ +def litToExpr (φ : Lit) : M Expr := do + let c ← read + return Litform.toExpr c.LC c.LN φ + +/-- The expr To Lit construction in `FFL.Meta.ClProver`. -/ +def exprToLit (e : Expr) : M Lit := do + let c ← read + Litform.denote c.LC c.LN e + +/-- The to Expr List construction in `FFL.Meta.ClProver.Sequent`. -/ +def Sequent.toExprList (Γ : Sequent) : M (List Expr) := do + let c ← read + return Γ.map (Litform.toExpr c.LC c.LN) + +/-- The expr List To Lit List construction in `FFL.Meta.ClProver`. -/ +def exprListToLitList (l : List Expr) : M (List Lit) := do + let c ← read + l.mapM (m := MetaM) (Litform.denote c.LC c.LN) + +/-- The to Expr construction in `FFL.Meta.ClProver.Sequent`. -/ +def Sequent.toExpr (Γ : Sequent) : M Expr := do + let c ← read + return toQList <| Γ.map (Litform.toExpr c.LC c.LN) + +/-- The try Right Close construction in `FFL.Meta.ClProver`. -/ +def tryRightClose (φ : Lit) (Γ Δ : Sequent) : M (Option Expr) := do + match ← memQListOptional' (← litToExpr φ) (← Γ.toExprList) with + | .none => + return none + | .some e => + do + let eΓ ← Sequent.toExpr Γ + let eΔ ← Sequent.toExpr Δ + let eφ ← litToExpr φ + return some (← iapp ``FFL.Meta.ClProver.Theorems.right_closed #[eΓ, eΔ, eφ, e]) + +/-- The try Left Close construction in `FFL.Meta.ClProver`. -/ +def tryLeftClose (φ : Lit) (Γ Δ : Sequent) : M (Option Expr) := do + match ← memQListOptional' (← litToExpr φ) (← Δ.toExprList) with + | .none => + return none + | .some e => + do + let eΓ ← Sequent.toExpr Γ + let eΔ ← Sequent.toExpr Δ + let eφ ← litToExpr φ + return some (← iapp ``FFL.Meta.ClProver.Theorems.left_closed #[eΓ, eΔ, eφ, e]) + +/-- The rotate Right construction in `FFL.Meta.ClProver`. -/ +def rotateRight (Γ Δ : Sequent) (φ : Lit) (e : Expr) : M Expr := do + let eΓ ← Sequent.toExpr Γ + let eΔ ← Sequent.toExpr Δ + let eφ ← litToExpr φ + iapp ``FFL.Meta.ClProver.Theorems.rotate_right #[eΓ, eΔ, eφ, e] + +/-- The rotate Left construction in `FFL.Meta.ClProver`. -/ +def rotateLeft (Γ Δ : Sequent) (φ : Lit) (e : Expr) : M Expr := do + let eΓ ← Sequent.toExpr Γ + let eΔ ← Sequent.toExpr Δ + let eφ ← litToExpr φ + iapp ``FFL.Meta.ClProver.Theorems.rotate_left #[eΓ, eΔ, eφ, e] + +/-- The verum Right construction in `FFL.Meta.ClProver`. -/ +def verumRight (Γ Δ : Sequent) : M Expr := do + let eΓ ← Sequent.toExpr Γ + let eΔ ← Sequent.toExpr Δ + iapp ``FFL.Meta.ClProver.Theorems.verum_right #[eΓ, eΔ] + +/-- The falsum Right construction in `FFL.Meta.ClProver`. -/ +def falsumRight (Γ Δ : Sequent) (e : Expr) : M Expr := do + let eΓ ← Sequent.toExpr Γ + let eΔ ← Sequent.toExpr Δ + iapp ``FFL.Meta.ClProver.Theorems.falsum_right #[eΓ, eΔ, e] + +/-- The and Right construction in `FFL.Meta.ClProver`. -/ +def andRight (Γ Δ : Sequent) (φ ψ : Lit) (e₁ e₂ : Expr) : M Expr := do + let eΓ ← Sequent.toExpr Γ + let eΔ ← Sequent.toExpr Δ + let eφ ← litToExpr φ + let eψ ← litToExpr ψ + iapp ``FFL.Meta.ClProver.Theorems.and_right #[eΓ, eΔ, eφ, eψ, e₁, e₂] + +/-- The or Right construction in `FFL.Meta.ClProver`. -/ +def orRight (Γ Δ : Sequent) (φ ψ : Lit) (e : Expr) : M Expr := do + let eΓ ← Sequent.toExpr Γ + let eΔ ← Sequent.toExpr Δ + let eφ ← litToExpr φ + let eψ ← litToExpr ψ + iapp ``FFL.Meta.ClProver.Theorems.or_right #[eΓ, eΔ, eφ, eψ, e] + +/-- The neg Right construction in `FFL.Meta.ClProver`. -/ +def negRight (Γ Δ : Sequent) (φ : Lit) (e : Expr) : M Expr := do + let eΓ ← Sequent.toExpr Γ + let eΔ ← Sequent.toExpr Δ + let eφ ← litToExpr φ + iapp ``FFL.Meta.ClProver.Theorems.neg_right #[eΓ, eΔ, eφ, e] + +/-- The imply Right construction in `FFL.Meta.ClProver`. -/ +def implyRight (Γ Δ : Sequent) (φ ψ : Lit) (e : Expr) : M Expr := do + let eΓ ← Sequent.toExpr Γ + let eΔ ← Sequent.toExpr Δ + let eφ ← litToExpr φ + let eψ ← litToExpr ψ + iapp ``FFL.Meta.ClProver.Theorems.imply_right #[eΓ, eΔ, eφ, eψ, e] + +/-- The iff Right construction in `FFL.Meta.ClProver`. -/ +def iffRight (Γ Δ : Sequent) (φ ψ : Lit) (e₁ e₂ : Expr) : M Expr := do + let eΓ ← Sequent.toExpr Γ + let eΔ ← Sequent.toExpr Δ + let eφ ← litToExpr φ + let eψ ← litToExpr ψ + iapp ``FFL.Meta.ClProver.Theorems.iff_right #[eΓ, eΔ, eφ, eψ, e₁, e₂] + +/-- The verum Left construction in `FFL.Meta.ClProver`. -/ +def verumLeft (Γ Δ : Sequent) (e : Expr) : M Expr := do + let eΓ ← Sequent.toExpr Γ + let eΔ ← Sequent.toExpr Δ + iapp ``FFL.Meta.ClProver.Theorems.verum_left #[eΓ, eΔ, e] + +/-- The falsum Left construction in `FFL.Meta.ClProver`. -/ +def falsumLeft (Γ Δ : Sequent) : M Expr := do + let eΓ ← Sequent.toExpr Γ + let eΔ ← Sequent.toExpr Δ + iapp ``FFL.Meta.ClProver.Theorems.falsum_left #[eΓ, eΔ] + +/-- The and Left construction in `FFL.Meta.ClProver`. -/ +def andLeft (Γ Δ : Sequent) (φ ψ : Lit) (e : Expr) : M Expr := do + let eΓ ← Sequent.toExpr Γ + let eΔ ← Sequent.toExpr Δ + let eφ ← litToExpr φ + let eψ ← litToExpr ψ + iapp ``FFL.Meta.ClProver.Theorems.and_left #[eΓ, eΔ, eφ, eψ, e] + +/-- The or Left construction in `FFL.Meta.ClProver`. -/ +def orLeft (Γ Δ : Sequent) (φ ψ : Lit) (e₁ e₂ : Expr) : M Expr := do + let eΓ ← Sequent.toExpr Γ + let eΔ ← Sequent.toExpr Δ + let eφ ← litToExpr φ + let eψ ← litToExpr ψ + iapp ``FFL.Meta.ClProver.Theorems.or_left #[eΓ, eΔ, eφ, eψ, e₁, e₂] + +/-- The neg Left construction in `FFL.Meta.ClProver`. -/ +def negLeft (Γ Δ : Sequent) (φ : Lit) (e : Expr) : M Expr := do + let eΓ ← Sequent.toExpr Γ + let eΔ ← Sequent.toExpr Δ + let eφ ← litToExpr φ + iapp ``FFL.Meta.ClProver.Theorems.neg_left #[eΓ, eΔ, eφ, e] + +/-- The imply Left construction in `FFL.Meta.ClProver`. -/ +def implyLeft (Γ Δ : Sequent) (φ ψ : Lit) (e₁ e₂ : Expr) : M Expr := do + let eΓ ← Sequent.toExpr Γ + let eΔ ← Sequent.toExpr Δ + let eφ ← litToExpr φ + let eψ ← litToExpr ψ + iapp ``FFL.Meta.ClProver.Theorems.imply_left #[eΓ, eΔ, eφ, eψ, e₁, e₂] + +/-- The iff Left construction in `FFL.Meta.ClProver`. -/ +def iffLeft (Γ Δ : Sequent) (φ ψ : Lit) (e₁ e₂ : Expr) : M Expr := do + let eΓ ← Sequent.toExpr Γ + let eΔ ← Sequent.toExpr Δ + let eφ ← litToExpr φ + let eψ ← litToExpr ψ + iapp ``FFL.Meta.ClProver.Theorems.iff_left #[eΓ, eΔ, eφ, eψ, e₁, e₂] + +/-- The to Provable construction in `FFL.Meta.ClProver`. -/ +def toProvable (φ : Expr) (e : Expr) : M Expr := do + iapp ``FFL.Meta.ClProver.Theorems.to_provable #[φ, e] + +/-- The prover construction in `FFL.Meta.ClProver`. -/ +def prover (k : ℕ) (b : Bool) (Γ Δ : Sequent) : M Expr := do + --logInfo m!"step: {k}, case: {b}, {← Sequent.toExpr Γ} ⟹ {← Sequent.toExpr Δ}" + match k, b with + | 0, _ => throwError m!"Proof search failed: {← Sequent.toExpr Γ} ⟹ {← Sequent.toExpr Δ}" + | k + 1, false => + match Δ with + | [] => prover k true Γ [] + | φ :: Δ => do + let e ← tryRightClose φ Γ Δ + match e with + | some h => return h + | none => + match φ with + | .atom a => + let e ← prover k true Γ (Δ ++ [.atom a]) + rotateRight Γ Δ (.atom a) e + | ⊤ => verumRight Γ Δ + | ⊥ => do + let e ← prover k true Γ Δ + falsumRight Γ Δ e + | φ ⋏ ψ => do + let e₁ ← prover k true Γ (Δ ++ [φ]) + let e₂ ← prover k true Γ (Δ ++ [ψ]) + andRight Γ Δ φ ψ e₁ e₂ + | φ ⋎ ψ => do + let e ← prover k true Γ (Δ ++ [φ, ψ]) + orRight Γ Δ φ ψ e + | ∼φ => do + let e ← prover k true (Γ ++ [φ]) Δ + negRight Γ Δ φ e + | φ ⇒ₗ ψ => do + let e ← prover k true (Γ ++ [φ]) (Δ ++ [ψ]) + implyRight Γ Δ φ ψ e + | .iff φ ψ => do + let e₁ ← prover k true (Γ ++ [φ]) (Δ ++ [ψ]) + let e₂ ← prover k true (Γ ++ [ψ]) (Δ ++ [φ]) + iffRight Γ Δ φ ψ e₁ e₂ + | k + 1, true => + match Γ with + | [] => prover k false [] Δ + | φ :: Γ => do + let e ← tryLeftClose φ Γ Δ + match e with + | some h => return h + | none => + match φ with + | .atom a => + let e ← prover k false (Γ ++ [.atom a]) Δ + rotateLeft Γ Δ (.atom a) e + | ⊤ => do + let e ← prover k false Γ Δ + verumLeft Γ Δ e + | ⊥ => do + falsumLeft Γ Δ + | φ ⋏ ψ => do + let e ← prover k false (Γ ++ [φ, ψ]) Δ + andLeft Γ Δ φ ψ e + | φ ⋎ ψ => do + let e₁ ← prover k false (Γ ++ [φ]) Δ + let e₂ ← prover k false (Γ ++ [ψ]) Δ + orLeft Γ Δ φ ψ e₁ e₂ + | ∼φ => do + let e ← prover k false Γ (Δ ++ [φ]) + negLeft Γ Δ φ e + | φ ⇒ₗ ψ => do + let e₁ ← prover k false Γ (Δ ++ [φ]) + let e₂ ← prover k false (Γ ++ [ψ]) Δ + implyLeft Γ Δ φ ψ e₁ e₂ + | .iff φ ψ => do + let e₁ ← prover k false Γ (Δ ++ [φ, ψ]) + let e₂ ← prover k false (Γ ++ [φ, ψ]) Δ + iffLeft Γ Δ φ ψ e₁ e₂ + + + +/-- Data and laws for Hyp Info in `FFL.Meta.ClProver`. -/ +structure HypInfo where + /-- The level F construction in `FFL.Meta.ClProver.HypInfo`. -/ + levelF : Level + /-- The level S construction in `FFL.Meta.ClProver.HypInfo`. -/ + levelS : Level + /-- The level E construction in `FFL.Meta.ClProver.HypInfo`. -/ + levelE : Level + /-- The F construction in `FFL.Meta.ClProver.HypInfo`. -/ + F : Q(Type levelF) + /-- The S construction in `FFL.Meta.ClProver.HypInfo`. -/ + S : Q(Type levelS) + /-- The E construction in `FFL.Meta.ClProver.HypInfo`. -/ + E : Q(Entailment.{_, _, levelE} $S $F) + /-- The 𝓢 construction in `FFL.Meta.ClProver.HypInfo`. -/ + 𝓢 : Q($S) + /-- The φ construction in `FFL.Meta.ClProver.HypInfo`. -/ + φ : Q($F) + /-- The proof construction in `FFL.Meta.ClProver.HypInfo`. -/ + proof : Q($𝓢 ⊢ $φ) + + + + + + + +/-- The synth Provable construction in `FFL.Meta.ClProver`. -/ +def synthProvable (e : Expr) : MetaM HypInfo := do + let (ty : Q(Prop)) ← inferType e + let ~q(@Entailment.Provable $F $S $E $𝓢 $φ) := ty | throwError + m!"(getGoal) error: {e} not a form of _ ⊢ _" + return ⟨_, _, _, F, S, E, 𝓢, φ, e⟩ + + + + + + + +/-- Data and laws for Compatible Hyp Info in `FFL.Meta.ClProver`. -/ +structure CompatibleHypInfo where + /-- The 𝓢 construction in `FFL.Meta.ClProver.CompatibleHypInfo`. -/ + 𝓢 : Expr + /-- The WT construction in `FFL.Meta.ClProver.CompatibleHypInfo`. -/ + WT : Expr + /-- The φ construction in `FFL.Meta.ClProver.CompatibleHypInfo`. -/ + φ : Lit + /-- The proof construction in `FFL.Meta.ClProver.CompatibleHypInfo`. -/ + proof : Expr + +/-- The to Compatible construction in `FFL.Meta.ClProver.HypInfo`. -/ +def HypInfo.toCompatible (h : HypInfo) : M CompatibleHypInfo := do + let c ← read + if (← isDefEq (← whnf h.F) (← whnf c.F)) && (← isDefEq (← whnf h.S) (← whnf c.S)) && (← + isDefEq (← whnf h.E) (← whnf c.E)) then + let e := @Expr.const ``FFL.Entailment.WeakerThan [c.levelF, c.levelS, c.levelS, c.levelE, + c.levelE] + |>.app c.F |>.app c.S |>.app c.S |>.app c.E |>.app c.E |>.app h.𝓢 |>.app c.𝓢 + let .some wt ← trySynthInstance e + | throwError m! "error: failed to find instance {e}" + return ⟨h.𝓢, wt, ← exprToLit h.φ, h.proof⟩ + else throwError m! "error: proof not compatible: {h.proof}" + + + + + + + +/-- The add Hyp construction in `FFL.Meta.ClProver`. -/ +def addHyp (𝓣 wt : Expr) (Γ Δ : Sequent) (φ : Lit) (E e : Expr) : M Expr := do + let eΓ ← Sequent.toExpr Γ + let eΔ ← Sequent.toExpr Δ + let eφ ← litToExpr φ + iapp ``FFL.Meta.ClProver.Theorems.add_hyp #[𝓣, wt, eΓ, eΔ, eφ, E, e] + +/-- The add Hyps construction in `FFL.Meta.ClProver`. -/ +def addHyps (prover : (Γ Δ : Sequent) → M Expr) (Γ Δ : Sequent) : List HypInfo → M Expr + | [] => prover Γ Δ + | h :: hyps => do + let H ← h.toCompatible + addHyp H.𝓢 H.WT Γ Δ H.φ H.proof <| ← addHyps prover (H.φ :: Γ) Δ hyps + +/-- The main construction in `FFL.Meta.ClProver`. -/ +def main (n : ℕ) (hyps : Array HypInfo) (L R : List Expr) : M Expr := do + let Γ ← exprListToLitList L + let Δ ← exprListToLitList R + addHyps (prover n false) Γ Δ hyps.toList + +/-- The term Seq construction in `FFL.Meta.ClProver`. -/ +syntax termSeq := "["(term,*)"]" + +/-- Prove a two-sided classical sequent, optionally supplying a search depth and hypotheses. -/ +elab "cl_prover_2s" n:(num)? seq:(termSeq)? : tactic => withMainContext do + let ⟨c, L, R⟩ ← getGoalTwoSided <| ← whnfR <| ← getMainTarget + let n : ℕ := + match n with + | some n => n.getNat + | none => 32 + let hyps ← (match seq with + | some seq => + match seq with + | `(termSeq| [ $ss,* ] ) => do + ss.getElems.mapM fun s ↦ do synthProvable (← Term.elabTerm s none true) + | _ => + return #[] + | _ => + return #[]) + closeMainGoal `cl_prover <| ← AtomM.run .reducible <| ReaderT.run (main n hyps L R) c + + + + + + + +/-- Prove a classical entailment, optionally supplying a search depth and hypotheses. -/ +elab "cl_prover" n:(num)? seq:(termSeq)? : tactic => withMainContext do + let ⟨c, φ⟩ ← getGoalProvable <| ← whnfR <| ← getMainTarget + let n : ℕ := + match n with + | some n => n.getNat + | none => 32 + let hyps ← (match seq with + | some seq => + match seq with + | `(termSeq| [ $ss,* ] ) => do + ss.getElems.mapM fun s ↦ do synthProvable (← Term.elabTerm s none true) + | _ => + return #[] + | _ => + return #[]) + closeMainGoal `cl_prover <| ← AtomM.run .reducible <| ReaderT.run (r := c) do + let e ← main n hyps [] [φ] + toProvable φ e + + + + + + + +end ClProver + +end Meta +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/Meta/ClProverTheorems.lean b/LeanPool/PointwiseComposition/Foundation/Meta/ClProverTheorems.lean new file mode 100644 index 000000000..9dd429486 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/Meta/ClProverTheorems.lean @@ -0,0 +1,127 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public meta import LeanPool.PointwiseComposition.Foundation.Meta.Lit +public meta import LeanPool.PointwiseComposition.Foundation.Meta.TwoSided +public import LeanPool.PointwiseComposition.Foundation.Meta.Lit +public import LeanPool.PointwiseComposition.Foundation.Meta.TwoSided + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# Proof automation based on the proof search on $\mathbf{LK}$ +-/ + +public meta section + +namespace FFL +namespace Meta + +open _root_.Lean Mathlib _root_.Qq Qq Lean Elab Meta Tactic + +namespace ClProver + +namespace Theorems + +open Entailment TwoSided FiniteContext + +variable {F : Type*} [LogicalConnective F] [LogicalNeutral F] [DecidableEq F] {S : Type*} + [Entailment S F] (𝓢 : S) [Entailment.Cl 𝓢] + +local notation Γ:45 " ⟹ " Δ:46 => TwoSided 𝓢 Γ Δ + +omit [DecidableEq F] in +lemma to_provable (φ) (h : [] ⟹ [φ]) : 𝓢 ⊢ φ := by classical exact TwoSided.to_provable h + +omit [DecidableEq F] in +lemma rotate_right (Γ Δ φ) (hφ : Γ ⟹ Δ ++ [φ]) : Γ ⟹ φ :: Δ := by + classical exact TwoSided.rotate_right hφ + +omit [DecidableEq F] in +lemma rotate_left (Γ Δ φ) (hφ : (Γ ++ [φ]) ⟹ Δ) : (φ :: Γ) ⟹ Δ := by + classical exact TwoSided.rotate_left hφ + +omit [DecidableEq F] in +lemma add_hyp (𝒯 : S) (s : 𝒯 ≼ 𝓢) (Γ Δ φ) (hφ : 𝒯 ⊢ φ) (h : (φ :: Γ) ⟹ Δ) : Γ ⟹ Δ := by + classical exact TwoSided.add_hyp hφ h + +omit [DecidableEq F] in +lemma right_closed (Γ Δ φ) (h : φ ∈ Γ) : Γ ⟹ φ :: Δ := by + classical exact TwoSided.right_closed h + +omit [DecidableEq F] in +lemma left_closed (Γ Δ φ) (h : φ ∈ Δ) : (φ :: Γ) ⟹ Δ := by + classical exact TwoSided.left_closed h + +omit [DecidableEq F] in +lemma verum_right (Γ Δ) : Γ ⟹ ⊤ :: Δ := by classical exact TwoSided.verum_right + +omit [DecidableEq F] in +lemma falsum_left (Γ Δ) : (⊥ :: Γ) ⟹ Δ := by classical exact TwoSided.falsum_left + +omit [DecidableEq F] in +lemma falsum_right (Γ Δ) (h : Γ ⟹ Δ) : Γ ⟹ ⊥ :: Δ := by classical exact TwoSided.falsum_right h + +omit [DecidableEq F] in +lemma verum_left (Γ Δ) (h : Γ ⟹ Δ) : (⊤ :: Γ) ⟹ Δ := by classical exact TwoSided.verum_left h + +omit [DecidableEq F] in +lemma and_right (Γ Δ φ ψ) (hφ : Γ ⟹ Δ ++ [φ]) (hψ : Γ ⟹ Δ ++ [ψ]) : Γ ⟹ φ ⋏ ψ :: Δ := by + classical exact TwoSided.and_right (weakening hφ) (weakening hψ) + +omit [DecidableEq F] in +lemma or_left (Γ Δ φ ψ) (hφ : (Γ ++ [φ]) ⟹ Δ) (hψ : (Γ ++ [ψ]) ⟹ Δ) : (φ ⋎ ψ :: Γ) ⟹ Δ := by + classical exact TwoSided.or_left (weakening hφ) (weakening hψ) + +omit [DecidableEq F] in +lemma or_right (Γ Δ φ ψ) (h : Γ ⟹ Δ ++ [φ, ψ]) : Γ ⟹ φ ⋎ ψ :: Δ := by + classical exact TwoSided.or_right (weakening h) + +omit [DecidableEq F] in +lemma and_left (Γ Δ φ ψ) (h : (Γ ++ [φ, ψ]) ⟹ Δ) : (φ ⋏ ψ :: Γ) ⟹ Δ := by + classical exact TwoSided.and_left (weakening h) + +omit [DecidableEq F] in +lemma neg_right (Γ Δ φ) (h : (Γ ++ [φ]) ⟹ Δ) : Γ ⟹ ∼φ :: Δ := by + classical exact TwoSided.neg_right_cl (weakening h) + +omit [DecidableEq F] in +lemma neg_left (Γ Δ φ) (h : Γ ⟹ Δ ++ [φ]) : (∼φ :: Γ) ⟹ Δ := by + classical exact TwoSided.neg_left (weakening h) + +omit [DecidableEq F] in +lemma imply_right (Γ Δ φ ψ) (h : (Γ ++ [φ]) ⟹ Δ ++ [ψ]) : Γ ⟹ (φ ⇒ₗ ψ) :: Δ := by + classical exact TwoSided.imply_right_cl (weakening h) + +omit [DecidableEq F] in +lemma imply_left (Γ Δ φ ψ) (hφ : Γ ⟹ Δ ++ [φ]) (hψ : (Γ ++ [ψ]) ⟹ Δ) : ((φ ⇒ₗ ψ) :: Γ) ⟹ Δ := by + classical exact TwoSided.imply_left (weakening hφ) (weakening hψ) + +omit [DecidableEq F] in +lemma iff_right (Γ Δ φ ψ) (hr : (Γ ++ [φ]) ⟹ Δ ++ [ψ]) (hl : (Γ ++ [ψ]) ⟹ Δ ++ [φ]) : + Γ ⟹ (φ ⇔ₗ ψ) :: Δ := by classical exact TwoSided.iff_right_cl (weakening hr) (weakening hl) + +omit [DecidableEq F] in +lemma iff_left (Γ Δ φ ψ) (hr : Γ ⟹ Δ ++ [φ, ψ]) (hl : (Γ ++ [φ, ψ]) ⟹ Δ) : + ((φ ⇔ₗ ψ) :: Γ) ⟹ Δ := by classical exact TwoSided.iff_left (weakening hr) (weakening hl) + +end Theorems + +end ClProver + +end Meta +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/Meta/Lit.lean b/LeanPool/PointwiseComposition/Foundation/Meta/Lit.lean new file mode 100644 index 000000000..de8550252 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/Meta/Lit.lean @@ -0,0 +1,189 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.Meta.Qq +public import LeanPool.PointwiseComposition.Foundation.Logic.LogicSymbol + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +public section + +namespace FFL +namespace Meta + +open _root_.Lean Mathlib _root_.Qq Qq Lean Elab Meta Tactic + +/-- Data and laws for Litform in `FFL.Meta`. -/ +inductive Litform (α : Type*) : Type _ + | atom (a : α) : Litform α + | verum : Litform α + | falsum : Litform α + | and : Litform α → Litform α → Litform α + | or : Litform α → Litform α → Litform α + | neg : Litform α → Litform α + | imply : Litform α → Litform α → Litform α + | iff : Litform α → Litform α → Litform α + +namespace Litform + +instance : LogicalConnective (Litform α) + where + wedge := Litform.and + vee := Litform.or + arrow := Litform.imply + tilde := Litform.neg + +instance : LogicalNeutral (Litform α) + where + top := Litform.verum + bot := Litform.falsum + +section ToString + +/-- The to Str construction in `FFL.Meta.Litform`. -/ +def toStr [ToString α] : Litform α → String + | ⊤ => "⊤" + | ⊥ => "⊥" + | atom a => s! "atom {toString a}" + | ∼φ => "(¬" ++ toStr φ ++ ")" + | φ ⋏ ψ => "(" ++ toStr φ ++ " ∧ " ++ toStr ψ ++ ")" + | φ ⋎ ψ => "(" ++ toStr φ ++ " ∨ " ++ toStr ψ ++ ")" + | φ ⇒ₗ ψ => "(" ++ toStr φ ++ " → " ++ toStr ψ ++ ")" + | iff φ ψ => "(" ++ toStr φ ++ " ↔ " ++ toStr ψ ++ ")" + +instance [ToString α] : ToString (Litform α) := + ⟨toStr⟩ + +/-- The format construction in `FFL.Meta.Litform`. -/ +def format [Repr α] : Litform α → Format + | ⊤ => s!"⊤" + | ⊥ => s!"⊥" + | atom a => repr a + | ∼φ => s! "(¬{format φ})" + | φ ⋏ ψ => s!"({(format φ)} ∧ {format ψ})" + | φ ⋎ ψ => s!"({(format φ)} ∨ {format ψ})" + | φ ⇒ₗ ψ => s!"({(format φ)} → {format ψ})" + | iff φ ψ => s!"({(format φ)} ↔ {format ψ})" + +instance [Repr α] : Repr (Litform α) := + ⟨fun t _ ↦ format t⟩ + +end ToString + +variable (F : Q(Type*)) (ls : Q(LogicalConnective $F)) (ln : Q(LogicalNeutral $F)) + +/-- The Lit construction in `FFL.Meta`. -/ +abbrev _root_.PointwiseComposition.FFL.Meta.Lit := + Litform Expr + +variable {F} + +/-- The to Expr construction in `FFL.Meta.Litform`. -/ +abbrev toExpr : Lit → Q($F) + | atom e => e + | ⊤ => q(⊤) + | ⊥ => q(⊥) + | φ ⋏ ψ => q($(toExpr φ) ⋏ $(toExpr ψ)) + | φ ⋎ ψ => q($(toExpr φ) ⋎ $(toExpr ψ)) + | ∼φ => q(∼$(toExpr φ)) + | φ ⇒ₗ ψ => q($(toExpr φ) ⇒ₗ $(toExpr ψ)) + | iff φ ψ => q($(toExpr φ) ⇔ₗ $(toExpr ψ)) + + + +/-- The summands At Depth construction in `FFL.Meta.Litform`. -/ +def summandsAtDepth {α : Q(Type $u)} (inst : Q(Add $α)) : + ℕ → Q($α) → MetaM (List Q($α)) + | 0, expression => return [expression] + | depth + 1, expression => do + match expression with + | ~q($x + $y) => + return (← summandsAtDepth inst depth x) ++ (← summandsAtDepth inst depth y) + | _ => return [expression] + + + +/-- The summands construction in `FFL.Meta.Litform`. -/ +def summands {α : Q(Type $u)} (inst : Q(Add $α)) (expression : Q($α)) : MetaM (List Q($α)) := do + let expression ← instantiateMVars expression + summandsAtDepth inst (expression.approxDepth.toNat + 1) expression + +/-- The denote At Depth construction in `FFL.Meta.Litform`. -/ +def denoteAtDepth : ℕ → Q($F) → MetaM Lit + | 0, expression => return atom expression + | depth + 1, expression => do + match expression with + | ~q(⊤) => return ⊤ + | ~q(⊥) => return ⊥ + | ~q($φ ⋏ $ψ) => return (← denoteAtDepth depth φ) ⋏ (← denoteAtDepth depth ψ) + | ~q($φ ⋎ $ψ) => return (← denoteAtDepth depth φ) ⋎ (← denoteAtDepth depth ψ) + | ~q($φ ⇒ₗ $ψ) => return (← denoteAtDepth depth φ) ⇒ₗ (← denoteAtDepth depth ψ) + | ~q($φ ⇔ₗ $ψ) => return iff (← denoteAtDepth depth φ) (← denoteAtDepth depth ψ) + | ~q(∼$φ) => return ∼(← denoteAtDepth depth φ) + | _ => return atom expression + + + +/-- Reify the input's structural depth, keeping any remaining subexpression atomic. -/ +def denote (expression : Q($F)) : MetaM Lit := do + let expression ← instantiateMVars expression + denoteAtDepth ls ln (expression.approxDepth.toNat + 1) expression + +/-- The complexity construction in `FFL.Meta.Litform`. -/ +@[simp] +def complexity : Litform α → ℕ + | atom _ => 0 + | ⊤ => 0 + | ⊥ => 0 + | φ ⋏ ψ => max φ.complexity ψ.complexity + 1 + | φ ⋎ ψ => max φ.complexity ψ.complexity + 1 + | ∼φ => φ.complexity + 1 + | φ ⇒ₗ ψ => max φ.complexity ψ.complexity + 1 + | iff φ ψ => max φ.complexity ψ.complexity + 1 + +end Litform + +namespace Lit + +/-- The DEq construction in `FFL.Meta.Lit`. -/ +def DEq : Lit → Lit → MetaM Bool + | .atom e, .atom e' => Lean.Meta.isDefEq e e' + | ⊤, ⊤ => return true + | ⊥, ⊥ => return true + | ∼φ, ∼ψ => return (← DEq φ ψ) + | φ₁ ⋏ ψ₁, φ₂ ⋏ ψ₂ => return (← DEq φ₁ φ₂) && (← DEq ψ₁ ψ₂) + | φ₁ ⋎ ψ₁, φ₂ ⋎ ψ₂ => return (← DEq φ₁ φ₂) && (← DEq ψ₁ ψ₂) + | φ₁ ⇒ₗ ψ₁, φ₂ ⇒ₗ ψ₂ => return (← DEq φ₁ φ₂) && (← DEq ψ₁ ψ₂) + | .iff φ₁ ψ₁, .iff φ₂ ψ₂ => return (← DEq φ₁ φ₂) && (← DEq ψ₁ ψ₂) + | _, _ => return false + +/-- The d Mem construction in `FFL.Meta.Lit`. -/ +def dMem (φ : Lit) (Δ : List Lit) : MetaM Bool := + Δ.foldrM (fun ψ ih ↦ return (← DEq φ ψ) || ih) false + +/-- The d Subset List construction in `FFL.Meta.Lit`. -/ +def dSubsetList (Γ Δ : List Lit) : MetaM Bool := do + match Γ with + | [] => + return true + | φ :: Γ => + return (← φ.dMem Δ) && (← dSubsetList Γ Δ) + +end Lit + +end Meta +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/Meta/Qq.lean b/LeanPool/PointwiseComposition/Foundation/Meta/Qq.lean new file mode 100644 index 000000000..7de33f95e --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/Meta/Qq.lean @@ -0,0 +1,88 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import Mathlib.Util.Qq +public meta import Mathlib.Util.Qq +public import Mathlib.Tactic.TypeStar +public meta import Lean.Meta.LitValues + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public meta section + +namespace Qq + +open _root_.Qq + +open _root_.Lean Mathlib _root_.Qq Qq Lean Elab Meta Tactic + +/-- The rfl Q construction in `Qq`. -/ +def rflQ {α : Q(Sort u)} (a : Q($α)) : Q($a = $a) := q(rfl) + + + + + + + +/-- The to QList construction in `Qq`. -/ +def toQList {α : Q(Type u)} : List Q($α) → Q(List $α) + | [] => q([]) + | a :: v => q($a :: $(toQList v)) + + + + + + + +lemma List.mem_of_eq {a b : α} {l} (h : a = b) : a ∈ b :: l := by simp [h] + +lemma List.mem_of_mem {a b : α} {l : List α} (h : a ∈ l) : a ∈ b :: l := by simp [h] + +lemma List.mem_singleton_of_eq (a b : α) (h : a = b) : a ∈ [b] := by simp [h] + +/-- The mem QList? construction in `Qq`. -/ +def memQListOptional {α : Q(Type u)} (a : Q($α)) : (l : List Q($α)) → MetaM <| Option Q($a ∈ + $(toQList l)) + | [] => return none + | b :: l => do + if (← isDefEq (← whnf a) (← whnf b)) then + let e : Q($a = $b) := rflQ a + return some q(List.mem_of_eq $e) + else + let some h ← memQListOptional a l | return none + return some q(List.mem_of_mem $h) + + + + + + + +/-- The mem QList?' construction in `Qq`. -/ +def memQListOptional' (a : Expr) (l : List Expr) : MetaM (Option Expr) := do + let ⟨u, _, a⟩ ← inferTypeQ' a + memQListOptional (u := u) a l + +/-- The of QList construction in `Qq`. -/ +def ofQList {α : Q(Type u)} (l : Q(List $α)) : MetaM <| List Q($α) := do + let some entries ← getListLit? (← whnf l) + | throwError "Expected an explicit list of formulas" + return entries.toList + +end Qq + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/Meta/TwoSided.lean b/LeanPool/PointwiseComposition/Foundation/Meta/TwoSided.lean new file mode 100644 index 000000000..2257bf265 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/Meta/TwoSided.lean @@ -0,0 +1,473 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.Propositional.Entailment.Cl + +/-! Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace FFL +namespace Entailment + +open FiniteContext + +variable {F : Type*} [LogicalConnective F] [LogicalNeutral F] [DecidableEq F] {S : Type*} + [Entailment S F] + +variable (𝓢 : S) + +/-- The Two Sided construction in `FFL.Entailment`. -/ +abbrev TwoSided (Γ Δ : List F) : Prop := + Γ ⊢[𝓢] (PointwiseComposition.List.disj Δ) + +variable {𝓢} [Entailment.Int 𝓢] + +local notation:40 Γ:45 " ⟹ " Δ:46 => TwoSided 𝓢 Γ Δ + +namespace TwoSided + +variable {Γ Γ₁ Γ₂ Δ Δ₁ Δ₂ : List F} {φ ψ χ : F} + +omit [DecidableEq F] in +lemma weakening (h : Γ₁ ⟹ Δ₁) (HΓ : Γ₁ ⊆ Γ₂ := by classical simp) (HΔ : Δ₁ ⊆ Δ₂ := by simp) : + Γ₂ ⟹ Δ₂ := + FiniteContext.weakening HΓ <| left_Disj_intro Δ₁ (fun _ hψ ↦ right_Disj_intro _ (HΔ hψ))⨀h + +omit [DecidableEq F] in +lemma remove_left (hφ : Γ ⟹ Δ) : φ :: Γ ⟹ Δ := by classical exact weakening hφ +omit [DecidableEq F] in +lemma remove_right (hφ : Γ ⟹ Δ) : Γ ⟹ φ :: Δ := by classical exact weakening hφ +omit [DecidableEq F] in +lemma rotate_right (hφ : Γ ⟹ Δ ++ [φ]) : Γ ⟹ φ :: Δ := by classical exact weakening hφ +omit [DecidableEq F] in +lemma rotate_left (hφ : (Γ ++ [φ]) ⟹ Δ) : (φ :: Γ) ⟹ Δ := by classical exact weakening hφ +omit [DecidableEq F] in +lemma rotate_right_inv (hφ : Γ ⟹ φ :: Δ) : Γ ⟹ Δ ++ [φ] := by classical exact weakening hφ +omit [DecidableEq F] in +lemma rotate_left_inv (hφ : (φ :: Γ) ⟹ Δ) : (Γ ++ [φ]) ⟹ Δ := by + classical + exact + weakening hφ +-- `DecidableEq F` is not referenced in the proof term itself, but the ambient +-- instance is needed for elaboration to disambiguate the overloaded `⨀` +-- notation; omitting it (as the `unusedSectionVars` linter suggests) breaks +-- elaboration, so the false-positive warning is suppressed here. +omit [DecidableEq F] in +lemma to_provable {φ} (h : [] ⟹ [φ]) : 𝓢 ⊢ φ := by + classical exact FiniteContext.provable_iff_provable.mpr <| left_Disj_intro [φ] (by simp)⨀h +omit [DecidableEq F] in +lemma add_hyp {𝒯 : S} [𝒯 ≼ 𝓢] (hφ : 𝒯 ⊢ φ) (h : (φ :: Γ) ⟹ Δ) : Γ ⟹ Δ := by + classical exact deduct h⨀of' (WeakerThan.pbl hφ) +omit [DecidableEq F] in +lemma right_closed (h : φ ∈ Γ) : Γ ⟹ φ :: Δ := by + classical exact right_Disj_intro _ (φ := φ) (by simp)⨀(FiniteContext.by_axm h) +omit [DecidableEq F] in +lemma left_closed (h : φ ∈ Δ) : (φ :: Γ) ⟹ Δ := by + classical exact right_Disj_intro _ (φ := φ) h⨀FiniteContext.by_axm +omit [DecidableEq F] in +lemma verum_right : Γ ⟹ ⊤ :: Δ := by + classical exact right_Disj_intro _ (φ := ⊤) (by simp)⨀(by simp) +omit [DecidableEq F] in +lemma falsum_left : (⊥ :: Γ) ⟹ Δ := + efq⨀by_axm₀ + +omit [DecidableEq F] in +lemma falsum_right (h : Γ ⟹ Δ) : Γ ⟹ ⊥ :: Δ := by classical exact weakening h +omit [DecidableEq F] in +lemma verum_left (h : Γ ⟹ Δ) : (⊤ :: Γ) ⟹ Δ := by classical exact weakening h +omit [DecidableEq F] in +lemma and_right (hφ : Γ ⟹ Δ ++ [φ]) (hψ : Γ ⟹ Δ ++ [ψ]) : Γ ⟹ φ ⋏ ψ :: Δ := by + classical + have : + Γ ⊢[𝓢] + (PointwiseComposition.List.disj (φ :: Δ)) ⇒ₗ + (PointwiseComposition.List.disj (ψ :: Δ)) ⇒ₗ + (PointwiseComposition.List.disj (φ ⋏ ψ :: Δ)) := + by + apply left_Disj_intro + rintro χ hχ + rcases show χ = φ ∨ χ ∈ Δ by simpa using hχ with (rfl | hχ) + · apply deduct + apply left_Disj_intro + intro ξ hξ + rcases show ξ = ψ ∨ ξ ∈ Δ by simpa using hξ with (rfl | hξ) + · exact + deduct <| + right_Disj_intro (χ ⋏ ξ :: Δ) (φ := χ ⋏ ξ) + List.mem_cons_self⨀(K_intro by_axm₁ by_axm₀) + · exact right_Disj_intro _ (by simp [hξ]) + · exact deduct <| dhyp <| right_Disj_intro _ (φ := χ) (by simp [hχ])⨀by_axm₀ + exact this⨀weakening hφ⨀weakening hψ + +omit [DecidableEq F] in +lemma or_left (hφ : Γ ++ [φ] ⟹ Δ) (hψ : Γ ++ [ψ] ⟹ Δ) : φ ⋎ ψ :: Γ ⟹ Δ := by + classical + apply deductInv + apply left_A_intro + · apply deduct <| weakening hφ + · apply deduct <| weakening hψ + +omit [DecidableEq F] in +lemma or_right (h : Γ ⟹ Δ ++ [φ, ψ]) : Γ ⟹ φ ⋎ ψ :: Δ := by + classical + have : + Γ ⊢[𝓢] + (PointwiseComposition.List.disj (φ :: ψ :: Δ)) ⇒ₗ + (PointwiseComposition.List.disj (φ ⋎ ψ :: Δ)) := + by + apply left_Disj_intro + intro χ hχ + rcases show χ = φ ∨ χ = ψ ∨ χ ∈ Δ by simpa using hχ with (rfl | rfl | hχ) + · apply right_Disj_intro' (χ ⋎ ψ :: Δ) (φ := χ ⋎ ψ) (by simp) or₁ + · apply right_Disj_intro' (φ ⋎ χ :: Δ) (φ := φ ⋎ χ) (by simp) or₂ + · apply right_Disj_intro _ (by simp [hχ]) + exact this⨀weakening h + +omit [DecidableEq F] in +lemma and_left (h : Γ ++ [φ, ψ] ⟹ Δ) : (φ ⋏ ψ :: Γ) ⟹ Δ := by + classical + have : φ :: ψ :: Γ ⟹ Δ := weakening h + have : (φ ⋏ ψ :: Γ) ⊢[𝓢] ψ ⇒ₗ φ ⇒ₗ (PointwiseComposition.List.disj Δ) := + wkProof (by simp) (deduct <| deduct this) + exact this⨀(deductInv and₂)⨀(deductInv and₁) + +omit [DecidableEq F] in +lemma neg_right_int (h : Γ ++ [φ] ⟹ []) : Γ ⟹ ∼φ :: Δ := by + classical + have : φ :: Γ ⟹ [] := weakening h + have : Γ ⊢[𝓢] ∼φ := N_iff_CO.mpr <| deduct this + have : Γ ⟹ [∼φ] := (right_Disj_intro _ (by simp))⨀this + exact weakening this + +omit [DecidableEq F] in +omit [Entailment.Int 𝓢] in +lemma neg_right_cl [Entailment.Cl 𝓢] (h : Γ ++ [φ] ⟹ Δ) : Γ ⟹ ∼φ :: Δ := by + classical + have hφ : Γ ⊢[𝓢] φ ⇒ₗ (PointwiseComposition.List.disj (∼φ :: Δ)) := + by + apply deduct + suffices + (φ :: Γ) ⊢[𝓢] + (PointwiseComposition.List.disj Δ) ⇒ₗ (PointwiseComposition.List.disj (∼φ :: Δ)) + from this⨀weakening h + apply left_Disj_intro + intro ψ hψ + apply right_Disj_intro _ (by simp [hψ]) + have hnφ : Γ ⊢[𝓢] ∼φ ⇒ₗ (PointwiseComposition.List.disj (∼φ :: Δ)) := + right_Disj_intro _ (by simp) + exact left_A_intro hφ hnφ⨀lem + +omit [DecidableEq F] in +lemma neg_left_int (h : Γ ++ [∼φ] ⟹ Δ ++ [φ]) : ∼φ :: Γ ⟹ Δ := by + classical + have h : ∼φ :: Γ ⟹ φ :: Δ := weakening h + suffices + (∼φ :: Γ) ⊢[𝓢] + (PointwiseComposition.List.disj (φ :: Δ)) ⇒ₗ (PointwiseComposition.List.disj Δ) + from this⨀(wkProof (by simp) h) + apply left_Disj_intro + intro ψ hψ + rcases show ψ = φ ∨ ψ ∈ Δ by simpa using hψ with (rfl | hψ) + · apply deductInv + exact CNC + · apply right_Disj_intro _ (by simp [hψ]) + +omit [DecidableEq F] in +lemma neg_left (h : Γ ⟹ Δ ++ [φ]) : ∼φ :: Γ ⟹ Δ := by classical exact neg_left_int (weakening h) +omit [DecidableEq F] in +lemma imply_left_int (hφ : Γ ++ [φ ⇒ₗ ψ] ⟹ Δ ++ [φ]) (hψ : Γ ++ [ψ] ⟹ Δ) : (φ ⇒ₗ ψ) :: Γ ⟹ Δ := + by + classical + have hφ : (φ ⇒ₗ ψ) :: Γ ⟹ φ :: Δ := weakening hφ + have hψ : ψ :: Γ ⟹ Δ := weakening hψ + suffices + ((φ ⇒ₗ ψ) :: Γ) ⊢[𝓢] + (PointwiseComposition.List.disj (φ :: Δ)) ⇒ₗ (PointwiseComposition.List.disj Δ) + from this⨀wkProof (by simp) hφ + apply left_Disj_intro + intro χ hχ + rcases show χ = φ ∨ χ ∈ Δ by simpa using hχ with (rfl | hχ) + · apply deduct + have : Γ ⊢[𝓢] ψ ⇒ₗ (PointwiseComposition.List.disj Δ) := deduct hψ + apply (wkProof (by simp) this)⨀(by_axm₁⨀by_axm₀) + · apply right_Disj_intro _ (by simp [hχ]) + +omit [DecidableEq F] in +lemma imply_left (hφ : Γ ⟹ Δ ++ [φ]) (hψ : Γ ++ [ψ] ⟹ Δ) : (φ ⇒ₗ ψ) :: Γ ⟹ Δ := by + classical exact imply_left_int (weakening hφ) (weakening hψ) +omit [DecidableEq F] in +lemma imply_right_int (h : Γ ++ [φ] ⟹ [ψ]) : Γ ⟹ (φ ⇒ₗ ψ) :: Δ := by + classical + have h : φ :: Γ ⟹ [ψ] := weakening h + have : (φ :: Γ) ⊢[𝓢] ψ := (left_Disj_intro _ <| by simp)⨀h + exact (right_Disj_intro _ <| by simp)⨀deduct this + +omit [DecidableEq F] in +omit [Entailment.Int 𝓢] in +lemma imply_right_cl [Entailment.Cl 𝓢] (h : Γ ++ [φ] ⟹ Δ ++ [ψ]) : Γ ⟹ (φ ⇒ₗ ψ) :: Δ := by + classical + have h : φ :: Γ ⟹ ψ :: Δ := weakening h + have hnφ : Γ ⊢[𝓢] ∼φ ⇒ₗ (PointwiseComposition.List.disj ((φ ⇒ₗ ψ) :: Δ)) := + by + apply right_Disj_intro' ((φ ⇒ₗ ψ) :: Δ) (φ := φ ⇒ₗ ψ) (by simp) + exact CNC + have hφ : Γ ⊢[𝓢] φ ⇒ₗ (PointwiseComposition.List.disj ((φ ⇒ₗ ψ) :: Δ)) := + by + apply deduct + suffices + (φ :: Γ) ⊢[𝓢] + (PointwiseComposition.List.disj (ψ :: Δ)) ⇒ₗ + (PointwiseComposition.List.disj ((φ ⇒ₗ ψ) :: Δ)) + from this⨀h + apply left_Disj_intro + intro χ hχ + rcases show χ = ψ ∨ χ ∈ Δ by simpa using hχ with (rfl | hχ) + · apply right_Disj_intro' _ (φ := φ ⇒ₗ χ) (by simp) + exact implyK + · apply right_Disj_intro + simp [hχ] + exact left_A_intro hφ hnφ⨀lem + +omit [DecidableEq F] in +omit [Entailment.Int 𝓢] in +lemma iff_right_cl [Entailment.Cl 𝓢] (hr : Γ ++ [φ] ⟹ Δ ++ [ψ]) (hl : Γ ++ [ψ] ⟹ Δ ++ [φ]) : + Γ ⟹ (φ ⇔ₗ ψ) :: Δ := by + classical + apply and_right + · apply rotate_right_inv + apply imply_right_cl + assumption + · apply rotate_right_inv + apply imply_right_cl + assumption + +omit [DecidableEq F] in +lemma iff_left (hr : Γ ⟹ Δ ++ [φ, ψ]) (hl : Γ ++ [φ, ψ] ⟹ Δ) : (φ ⇔ₗ ψ) :: Γ ⟹ Δ := by + classical + apply and_left + suffices (φ ⇒ₗ ψ) :: (ψ ⇒ₗ φ) :: Γ ⟹ Δ from weakening this + apply imply_left + · apply imply_left + · exact weakening hr + · suffices (φ :: Γ) ⟹ φ :: Δ from weakening this + apply deductInv + apply right_Disj_intro _ (by simp) + · suffices (ψ ⇒ₗ φ) :: ψ :: Γ ⟹ Δ from weakening this + apply imply_left + · suffices (ψ :: Γ) ⟹ ψ :: Δ from weakening this + apply deductInv + apply right_Disj_intro _ (by simp) + · exact weakening hl + +end TwoSided + +variable (F) + +/-- Data and laws for Sequent in `FFL.Entailment.Tableaux`. -/ +structure Tableaux.Sequent where + /-- The antecedent construction in `FFL.Entailment.Tableaux.Sequent`. -/ + antecedent : List F + /-- The succedent construction in `FFL.Entailment.Tableaux.Sequent`. -/ + succedent : List F + +/-- The Tableaux construction in `FFL.Entailment`. -/ +abbrev Tableaux := + List (Tableaux.Sequent F) + +variable {F} (𝓢) + +/-- Data and laws for Valid in `FFL.Entailment.Tableaux`. -/ +inductive Tableaux.Valid : Tableaux F → Prop where + | head {Γ Δ τ} : Γ ⟹ Δ → Valid (⟨Γ, Δ⟩ :: τ) + | tail {S τ} : Valid τ → Valid (S :: τ) + +variable {𝓢} + +namespace Tableaux +namespace Valid + +variable {T U V : Tableaux F} {Γ Γ₁ Γ₂ Δ Δ₁ Δ₂ Ξ Ξ₁ Ξ₂ Λ Λ₁ Λ₂ : List F} {φ ψ χ : F} + +local notation:0 Γ:45 " ⟶ " Δ:46 => Tableaux.Sequent.mk Γ Δ + +omit [DecidableEq F] [Entailment.Int 𝓢] + +@[simp] +lemma not_nil : ¬Valid 𝓢 [] := by rintro ⟨⟩ + +lemma of_mem (H : Γ ⟹ Δ) (h : (Γ ⟶ Δ) ∈ τ) : Valid 𝓢 τ := by + match τ with + | [] => simp_all + | + (Ξ ⟶ Λ) :: + τ => + rcases show Γ = Ξ ∧ Δ = Λ ∨ (Γ ⟶ Δ) ∈ τ by simpa using h with (⟨rfl, rfl⟩ | h) + · exact Valid.head H + · exact (Valid.of_mem H h).tail + +lemma of_subset (h : Valid 𝓢 σ) (ss : σ ⊆ τ := by simp) : Valid 𝓢 τ := by + match σ with + | [] => simp_all + | (Γ ⟶ Δ) :: ε => + have ss : (Γ ⟶ Δ) ∈ τ ∧ ε ⊆ τ := by simpa using ss + rcases h with (h | h) + · exact Valid.of_mem h ss.1 + · exact h.of_subset ss.2 + +lemma of_single_uppercedent (H : (Γ ⟹ Δ) → (Ξ ⟹ Λ)) (h : Valid 𝓢 ((Γ ⟶ Δ) :: T)) : + Valid 𝓢 ((Ξ ⟶ Λ) :: T) := + by + have h : Valid 𝓢 ((Γ ⟶ Δ) :: T) := h.of_subset + rcases h with (h | h) + · exact Valid.head (H h) + · exact h.tail + +lemma of_double_uppercedent (H : (Γ₁ ⟹ Δ₁) → (Γ₂ ⟹ Δ₂) → (Ξ ⟹ Λ)) + (h₁ : Valid 𝓢 ((Γ₁ ⟶ Δ₁) :: T)) (h₂ : Valid 𝓢 ((Γ₂ ⟶ Δ₂) :: T)) : Valid 𝓢 ((Ξ ⟶ Λ) :: T) := + by + have h₁ : Valid 𝓢 ((Γ₁ ⟶ Δ₁) :: T) := h₁.of_subset + have h₂ : Valid 𝓢 ((Γ₂ ⟶ Δ₂) :: T) := h₂.of_subset + rcases h₁ with (h₁ | h₁) + · rcases h₂ with (h₂ | h₂) + · exact Valid.head (H h₁ h₂) + · exact h₂.tail + · exact h₁.tail + +lemma remove : Valid 𝓢 T → Valid 𝓢 ((Γ ⟶ Δ) :: T) := + of_subset + +variable [DecidableEq F] [Entailment.Int 𝓢] + +omit [DecidableEq F] in +lemma to_provable (h : Valid 𝓢 [[] ⟶ [φ]]) : 𝓢 ⊢ φ := by + classical + rcases h + · exact TwoSided.to_provable <| by assumption + · simp_all + +omit [DecidableEq F] in +lemma right_closed (h : φ ∈ Γ) : Valid 𝓢 ((Γ ⟶ φ :: Δ) :: T) := by + classical exact head <| TwoSided.right_closed h +omit [DecidableEq F] in +lemma left_closed (h : φ ∈ Δ) : Valid 𝓢 ((φ :: Γ ⟶ Δ) :: T) := by + classical exact head <| TwoSided.left_closed h +omit [DecidableEq F] in +lemma remove_right : Valid 𝓢 ((Γ ⟶ Δ) :: T) → Valid 𝓢 ((Γ ⟶ φ :: Δ) :: T) := by + classical exact of_single_uppercedent TwoSided.remove_right +omit [DecidableEq F] in +lemma remove_left : Valid 𝓢 ((Γ ⟶ Δ) :: T) → Valid 𝓢 ((φ :: Γ ⟶ Δ) :: T) := by + classical exact of_single_uppercedent TwoSided.remove_left +omit [DecidableEq F] in +lemma rotate_right : Valid 𝓢 ((Γ ⟶ Δ ++ [φ]) :: T) → Valid 𝓢 ((Γ ⟶ φ :: Δ) :: T) := by + classical exact of_single_uppercedent TwoSided.rotate_right +omit [DecidableEq F] in +lemma rotate_left : Valid 𝓢 ((Γ ++ [φ] ⟶ Δ) :: T) → Valid 𝓢 ((φ :: Γ ⟶ Δ) :: T) := by + classical exact of_single_uppercedent TwoSided.rotate_left +omit [DecidableEq F] in +lemma verum_right : Valid 𝓢 ((Γ ⟶ ⊤ :: Δ) :: T) := by + classical exact Valid.head TwoSided.verum_right +omit [DecidableEq F] in +lemma falsum_left : Valid 𝓢 ((⊥ :: Γ ⟶ Δ) :: T) := + Valid.head TwoSided.falsum_left + +omit [DecidableEq F] in +lemma falsum_right : Valid 𝓢 ((Γ ⟶ Δ) :: T) → Valid 𝓢 ((Γ ⟶ ⊥ :: Δ) :: T) := by + classical exact of_single_uppercedent TwoSided.falsum_right +omit [DecidableEq F] in +lemma verum_left : Valid 𝓢 ((Γ ⟶ Δ) :: T) → Valid 𝓢 ((⊤ :: Γ ⟶ Δ) :: T) := by + classical exact of_single_uppercedent TwoSided.verum_left +omit [DecidableEq F] in +lemma and_right : + Valid 𝓢 ((Γ ⟶ Δ ++ [φ]) :: T) → + Valid 𝓢 ((Γ ⟶ Δ ++ [ψ]) :: T) → Valid 𝓢 ((Γ ⟶ φ ⋏ ψ :: Δ) :: T) := + by classical exact of_double_uppercedent TwoSided.and_right +omit [DecidableEq F] in +lemma or_left : + Valid 𝓢 ((Γ ++ [φ] ⟶ Δ) :: T) → + Valid 𝓢 ((Γ ++ [ψ] ⟶ Δ) :: T) → Valid 𝓢 ((φ ⋎ ψ :: Γ ⟶ Δ) :: T) := + by classical exact of_double_uppercedent TwoSided.or_left +omit [DecidableEq F] in +lemma or_right : Valid 𝓢 ((Γ ⟶ Δ ++ [φ, ψ]) :: T) → Valid 𝓢 ((Γ ⟶ φ ⋎ ψ :: Δ) :: T) := by + classical exact of_single_uppercedent TwoSided.or_right +omit [DecidableEq F] in +lemma and_left : Valid 𝓢 ((Γ ++ [φ, ψ] ⟶ Δ) :: T) → Valid 𝓢 ((φ ⋏ ψ :: Γ ⟶ Δ) :: T) := by + classical exact of_single_uppercedent TwoSided.and_left +omit [DecidableEq F] in +lemma neg_right : + Valid 𝓢 ((Γ ++ [φ] ⟶ []) :: (Γ ⟶ Δ ++ [∼φ]) :: T) → Valid 𝓢 ((Γ ⟶ ∼φ :: Δ) :: T) := by + classical + exact + fun h ↦ by + rcases h with (h | h) + · exact Valid.head <| TwoSided.neg_right_int h + · rcases h with (h | h) + · apply head + exact TwoSided.weakening h + · exact h.tail +omit [DecidableEq F] in +lemma neg_right' : + Valid 𝓢 ((Γ ++ [φ] ⟶ []) :: (Γ ⟶ Δ) :: T) → Valid 𝓢 ((Γ ⟶ ∼φ :: Δ) :: T) := by + classical + exact + fun h ↦ by + rcases h with (h | h) + · exact Valid.head <| TwoSided.neg_right_int h + · rcases h with (h | h) + · apply head + exact TwoSided.weakening h + · exact h.tail +omit [DecidableEq F] in +lemma neg_left : Valid 𝓢 ((Γ ++ [∼φ] ⟶ Δ ++ [φ]) :: T) → Valid 𝓢 ((∼φ :: Γ ⟶ Δ) :: T) := by + classical exact of_single_uppercedent TwoSided.neg_left_int +omit [DecidableEq F] in +lemma imply_right : + Valid 𝓢 ((Γ ++ [φ] ⟶ [ψ]) :: (Γ ⟶ Δ ++ [φ ⇒ₗ ψ]) :: T) → Valid 𝓢 ((Γ ⟶ (φ ⇒ₗ ψ) :: Δ) :: T) + := by + classical + exact + fun h ↦ by + have h : Valid 𝓢 ((Γ ++ [φ] ⟶ [ψ]) :: (Γ ⟶ Δ ++ [φ ⇒ₗ ψ]) :: T) := h.of_subset + rcases h with (h | h) + · exact Valid.head <| TwoSided.imply_right_int h + · rcases h with (h | h) + · apply head + exact TwoSided.weakening h + · exact h.tail + +omit [DecidableEq F] in +lemma imply_right' : + Valid 𝓢 ((Γ ++ [φ] ⟶ [ψ]) :: (Γ ⟶ Δ) :: T) → Valid 𝓢 ((Γ ⟶ (φ ⇒ₗ ψ) :: Δ) :: T) := by + classical + exact + fun h ↦ by + have h : Valid 𝓢 ((Γ ++ [φ] ⟶ [ψ]) :: (Γ ⟶ Δ) :: T) := h.of_subset + rcases h with (h | h) + · exact Valid.head <| TwoSided.imply_right_int h + · rcases h with (h | h) + · apply head + exact TwoSided.weakening h + · exact h.tail +omit [DecidableEq F] in +lemma imply_left : + Valid 𝓢 ((Γ ++ [φ ⇒ₗ ψ] ⟶ Δ ++ [φ]) :: T) → + Valid 𝓢 ((Γ ++ [ψ] ⟶ Δ) :: T) → Valid 𝓢 (((φ ⇒ₗ ψ) :: Γ ⟶ Δ) :: T) := + by classical exact of_double_uppercedent TwoSided.imply_left_int +end Valid +end Tableaux + +end Entailment +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/Propositional/Entailment/Cl.lean b/LeanPool/PointwiseComposition/Foundation/Propositional/Entailment/Cl.lean new file mode 100644 index 000000000..7bc68868c --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/Propositional/Entailment/Cl.lean @@ -0,0 +1,433 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. +public import LeanPool.PointwiseComposition.Foundation.Propositional.Entailment.Int + +/-! Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace FFL +namespace Axioms + +variable {F : Type*} [LogicalConnective F] +variable (φ ψ χ : F) + +/-- The DNE construction in `FFL.Axioms`. -/ +protected abbrev DNE := + ∼∼φ ⇒ₗ φ + +/-- The LEM construction in `FFL.Axioms`. -/ +protected abbrev LEM := + φ ⋎ ∼φ + +/-- The Peirce construction in `FFL.Axioms`. -/ +protected abbrev Peirce := + ((φ ⇒ₗ ψ) ⇒ₗ φ) ⇒ₗ φ + +/-- The Elim Contra construction in `FFL.Axioms`. -/ +protected abbrev ElimContra := + (∼ψ ⇒ₗ ∼φ) ⇒ₗ (φ ⇒ₗ ψ) + +end Axioms +end FFL + +namespace FFL +namespace Entailment + +variable {S F : Type*} [LogicalConnective F] [Entailment S F] +variable {𝓢 : S} {φ ψ χ : F} + +/-- Proofs of double-negation elimination in the given proof system. -/ +class HasAxiomDNE (𝓢 : S) where + /-- The dne! construction in `FFL.Entailment`. -/ + dneProof {φ : F} : 𝓢 ⊢! Axioms.DNE φ +export HasAxiomDNE (dneProof) + +@[simp] +lemma dne [HasAxiomDNE 𝓢] : 𝓢 ⊢ ∼∼φ ⇒ₗ φ := + ⟨dneProof⟩ + +/-- The of NN! construction in `FFL.Entailment`. -/ +def ofNNProof [ModusPonens 𝓢] [HasAxiomDNE 𝓢] (b : 𝓢 ⊢! ∼∼φ) : 𝓢 ⊢! φ := + dneProof⨀b +@[grind ⇒] +lemma of_NN [ModusPonens 𝓢] [HasAxiomDNE 𝓢] (h : 𝓢 ⊢ ∼∼φ) : 𝓢 ⊢ φ := + ⟨ofNNProof h.some⟩ + +section + +variable [LogicalNeutral F] [Entailment.Minimal 𝓢] + +namespace FiniteContext + +instance [Entailment.HasAxiomDNE 𝓢] (Γ : FiniteContext F 𝓢) : HasAxiomDNE Γ := + ⟨ofProof dneProof⟩ + +end FiniteContext + +namespace Context + +instance [Entailment.HasAxiomDNE 𝓢] (Γ : Context F 𝓢) : HasAxiomDNE Γ := + ⟨ofProof dneProof⟩ + +end Context + +end + +/-- Proofs of excluded middle in the given proof system. -/ +class HasAxiomLEM (𝓢 : S) where + /-- The lem! construction in `FFL.Entailment`. -/ + lemProof {φ : F} : 𝓢 ⊢! Axioms.LEM φ +export HasAxiomLEM (lemProof) + +@[simp] +lemma lem [HasAxiomLEM 𝓢] : 𝓢 ⊢ φ ⋎ ∼φ := + ⟨lemProof⟩ + +section + +variable [LogicalNeutral F] [Entailment.Minimal 𝓢] + +namespace FiniteContext + +instance [Entailment.HasAxiomLEM 𝓢] (Γ : FiniteContext F 𝓢) : HasAxiomLEM Γ := + ⟨ofProof lemProof⟩ + +end FiniteContext + +namespace Context + +instance [Entailment.HasAxiomLEM 𝓢] (Γ : Context F 𝓢) : HasAxiomLEM Γ := + ⟨ofProof lemProof⟩ + +end Context + +end + +/-- Proofs of Peirce's law in the given proof system. -/ +class HasAxiomPeirce (𝓢 : S) where + /-- The peirce! construction in `FFL.Entailment`. -/ + peirceProof {φ ψ : F} : 𝓢 ⊢! Axioms.Peirce φ ψ +export HasAxiomPeirce (peirceProof) + +@[simp] +lemma peirce [HasAxiomPeirce 𝓢] : 𝓢 ⊢ ((φ ⇒ₗ ψ) ⇒ₗ φ) ⇒ₗ φ := + ⟨peirceProof⟩ + +section + +variable [LogicalNeutral F] [Entailment.Minimal 𝓢] + +namespace FiniteContext + +instance [Entailment.HasAxiomPeirce 𝓢] (Γ : FiniteContext F 𝓢) : HasAxiomPeirce Γ := + ⟨ofProof peirceProof⟩ + +end FiniteContext + +namespace Context + +instance [Entailment.HasAxiomPeirce 𝓢] (Γ : Context F 𝓢) : HasAxiomPeirce Γ := + ⟨ofProof peirceProof⟩ + +end Context + +end + +/-- Data and laws for Has Axiom Elim Contra in `FFL.Entailment`. -/ +class HasAxiomElimContra (𝓢 : S) where + /-- The elim Contra! construction in `FFL.Entailment`. -/ + elimContraProof {φ ψ : F} : 𝓢 ⊢! Axioms.ElimContra φ ψ +export HasAxiomElimContra (elimContraProof) + +@[simp] +lemma elim_contra [HasAxiomElimContra 𝓢] : 𝓢 ⊢ (∼ψ ⇒ₗ ∼φ) ⇒ₗ (φ ⇒ₗ ψ) := + ⟨elimContraProof⟩ + +variable {F : Type*} [LogicalConnective F] [LogicalNeutral F] [DecidableEq F] {S : Type*} + [Entailment S F] {𝓢 : S} {φ φ₁ φ₂ ψ ψ₁ ψ₂ χ ξ : F} {Γ Δ : List F} + +/-- Data and laws for Cl in `FFL.Entailment`. -/ +protected class Cl (𝓢 : S) extends Entailment.Minimal 𝓢, Entailment.HasAxiomDNE 𝓢 + +variable [Entailment.Cl 𝓢] + +namespace FiniteContext +instance (Γ : FiniteContext F 𝓢) : Entailment.Cl Γ where +end FiniteContext + +namespace Context +instance (Γ : Context F 𝓢) : Entailment.Cl Γ where +end Context + +open NegationEquiv +open FiniteContext +open _root_.List List + +/-- The dn! construction in `FFL.Entailment`. -/ +def dnProof : 𝓢 ⊢! φ ⇔ₗ ∼∼φ := + EProofIntro dniProof dneProof +omit [DecidableEq F] in +@[simp] +lemma dn : 𝓢 ⊢ φ ⇔ₗ ∼∼φ := by classical exact ⟨dnProof⟩ +/-- The A! of ANNNN! construction in `FFL.Entailment`. -/ +def AProofOfANNNNProof (d : 𝓢 ⊢! ∼∼φ ⋎ ∼∼ψ) : 𝓢 ⊢! φ ⋎ ψ := + ofCProofOfCProofOfAProof (CProofTrans dneProof or₁Proof) (CProofTrans dneProof or₂Proof) d +omit [DecidableEq F] in +lemma A_of_ANNNN (d : 𝓢 ⊢ ∼∼φ ⋎ ∼∼ψ) : 𝓢 ⊢ φ ⋎ ψ := + ⟨AProofOfANNNNProof d.some⟩ + +/-- The CN! of CN! left construction in `FFL.Entailment`. -/ +def CNProofOfCNProofLeft (b : 𝓢 ⊢! ∼φ ⇒ₗ ψ) : 𝓢 ⊢! ∼ψ ⇒ₗ φ := + CProofTrans (contraProof b) dneProof +omit [DecidableEq F] in +lemma CN_of_CN_left (b : 𝓢 ⊢ ∼φ ⇒ₗ ψ) : 𝓢 ⊢ ∼ψ ⇒ₗ φ := by + classical exact ⟨CNProofOfCNProofLeft b.some⟩ +/-- The CCNCN'! construction in `FFL.Entailment`. -/ +def CCNCN'Proof : 𝓢 ⊢! (∼φ ⇒ₗ ψ) ⇒ₗ (∼ψ ⇒ₗ φ) := + deduct'Proof <| CNProofOfCNProofLeft FiniteContext.idProof +omit [DecidableEq F] in +@[simp] +lemma CCNCN' : 𝓢 ⊢ (∼φ ⇒ₗ ψ) ⇒ₗ (∼ψ ⇒ₗ φ) := by classical exact ⟨CCNCN'Proof⟩ +/-- The C! of CNN! construction in `FFL.Entailment`. -/ +def CProofOfCNNProof (b : 𝓢 ⊢! ∼φ ⇒ₗ ∼ψ) : 𝓢 ⊢! ψ ⇒ₗ φ := + CProofTrans dniProof (CNProofOfCNProofLeft b) +omit [DecidableEq F] in +lemma C_of_CNN (b : 𝓢 ⊢ ∼φ ⇒ₗ ∼ψ) : 𝓢 ⊢ ψ ⇒ₗ φ := by classical exact ⟨CProofOfCNNProof b.some⟩ +/-- The CCNNC! construction in `FFL.Entailment`. -/ +def CCNNCProof : 𝓢 ⊢! (∼φ ⇒ₗ ∼ψ) ⇒ₗ (ψ ⇒ₗ φ) := + deduct'Proof <| CProofOfCNNProof FiniteContext.idProof +omit [DecidableEq F] in +@[simp] +lemma CCNNC : 𝓢 ⊢ (∼φ ⇒ₗ ∼ψ) ⇒ₗ (ψ ⇒ₗ φ) := by classical exact ⟨CCNNCProof⟩ +/-- The EN! of EN! right construction in `FFL.Entailment`. -/ +def ENProofOfENProofRight (h : 𝓢 ⊢! φ ⇔ₗ ∼ψ) : 𝓢 ⊢! ∼φ ⇔ₗ ψ := + by + apply EProofIntro; · apply CNProofOfCNProofLeft <| KProofRight h; + · apply CNProofOfCNProofRight <| KProofLeft h; +omit [DecidableEq F] in +lemma EN_of_EN_right (h : 𝓢 ⊢ φ ⇔ₗ ∼ψ) : 𝓢 ⊢ ∼φ ⇔ₗ ψ := by + classical exact ⟨ENProofOfENProofRight h.some⟩ +/-- The EN! of EN! left construction in `FFL.Entailment`. -/ +def ENProofOfENProofLeft (h : 𝓢 ⊢! ∼φ ⇔ₗ ψ) : 𝓢 ⊢! φ ⇔ₗ ∼ψ := + EProofSymm <| ENProofOfENProofRight <| EProofSymm h +omit [DecidableEq F] in +lemma EN_of_EN_left (h : 𝓢 ⊢ ∼φ ⇔ₗ ψ) : 𝓢 ⊢ φ ⇔ₗ ∼ψ := by + classical exact ⟨ENProofOfENProofLeft h.some⟩ +/-- The ECCOO! construction in `FFL.Entailment`. -/ +def ECCOOProof : 𝓢 ⊢! φ ⇔ₗ ((φ ⇒ₗ ⊥) ⇒ₗ ⊥) := + EProofTrans dnProof ENNCCOOProof +omit [DecidableEq F] in +lemma ECCOO : 𝓢 ⊢ φ ⇔ₗ ((φ ⇒ₗ ⊥) ⇒ₗ ⊥) := by classical exact ⟨ECCOOProof⟩ +/-- The CNKANN! construction in `FFL.Entailment`. -/ +def CNKANNProof : 𝓢 ⊢! ∼(φ ⋏ ψ) ⇒ₗ (∼φ ⋎ ∼ψ) := by + apply CNProofOfCNProofLeft; + apply deduct'Proof; + exact KProofReplace (KNNProofOfNAProof <| FiniteContext.idProof) dneProof dneProof; +omit [DecidableEq F] in +@[simp] +lemma CNKANN : 𝓢 ⊢ ∼(φ ⋏ ψ) ⇒ₗ (∼φ ⋎ ∼ψ) := by classical exact ⟨CNKANNProof⟩ +/-- The ANN! of NK! construction in `FFL.Entailment`. -/ +def ANNProofOfNKProof (b : 𝓢 ⊢! ∼(φ ⋏ ψ)) : 𝓢 ⊢! ∼φ ⋎ ∼ψ := + CNKANNProof⨀b +omit [DecidableEq F] in +lemma ANN_of_NK (b : 𝓢 ⊢ ∼(φ ⋏ ψ)) : 𝓢 ⊢ ∼φ ⋎ ∼ψ := by + classical exact ⟨ANNProofOfNKProof b.some⟩ +/-- The AN! of C! construction in `FFL.Entailment`. -/ +def ANProofOfCProof (d : 𝓢 ⊢! φ ⇒ₗ ψ) : 𝓢 ⊢! ∼φ ⋎ ψ := by + apply ofNNProof; + apply NProofOfCOProof; + apply deduct'Proof; + have d₁ : [∼(∼φ ⋎ ψ)] ⊢[𝓢]! ∼∼φ ⋏ ∼ψ := KNNProofOfNAProof <| FiniteContext.idProof; + have d₂ : [∼(∼φ ⋎ ψ)] ⊢[𝓢]! ∼φ ⇒ₗ ⊥ := COProofOfNProof <| KProofLeft d₁; + have d₃ : [∼(∼φ ⋎ ψ)] ⊢[𝓢]! ∼φ := (ofProof (Γ := [∼(∼φ ⋎ ψ)]) <| contraProof d) ⨀ (KProofRight + d₁); + exact d₂ ⨀ d₃; + +omit [DecidableEq F] in +lemma AN_of_C (d : 𝓢 ⊢ φ ⇒ₗ ψ) : 𝓢 ⊢ ∼φ ⋎ ψ := by classical exact ⟨ANProofOfCProof d.some⟩ +/-- The CCAN! construction in `FFL.Entailment`. -/ +def CCANProof : 𝓢 ⊢! (φ ⇒ₗ ψ) ⇒ₗ (∼φ ⋎ ψ) := by + apply deduct'Proof; + apply ANProofOfCProof; + exact FiniteContext.byAxmProof; +omit [DecidableEq F] in +lemma CCAN : 𝓢 ⊢ (φ ⇒ₗ ψ) ⇒ₗ ∼φ ⋎ ψ := by classical exact ⟨CCANProof⟩ +instance : HasAxiomEFQ 𝓢 where + efqProof {φ} := by + apply CProofOfCNNProof; + exact CProofTrans (KProofLeft negEquivProof) <| CProofTrans (CProofSwap implyKProof) + (KProofRight negEquivProof); + +instance : Entailment.Int 𝓢 where + +instance : HasAxiomElimContra 𝓢 where + elimContraProof {φ ψ} := by + apply deduct'Proof; + have : [∼ψ ⇒ₗ ∼φ] ⊢[𝓢]! ∼ψ ⇒ₗ ∼φ := FiniteContext.byAxmProof; + exact CProofOfCNNProof this; + +instance : HasAxiomLEM 𝓢 := + ⟨AProofOfANNNNProof <| ANProofOfCProof dniProof⟩ + +omit [DecidableEq F] in +lemma CNC_of_C_of_CN (hpq : 𝓢 ⊢ φ ⇒ₗ ψ) (hpnr : 𝓢 ⊢ φ ⇒ₗ ∼ξ) : 𝓢 ⊢ φ ⇒ₗ ∼(ψ ⇒ₗ ξ) := by + classical + exact + deduct' <| + (contra <| + CCAN)⨀(NA_of_KNN <| + K_intro (dni' <| of' hpq⨀FiniteContext.by_axm) (of' hpnr⨀FiniteContext.by_axm)) +/-- The of A! of N! construction in `FFL.Entailment`. -/ +def ofAProofOfNProof (b : 𝓢 ⊢! φ ⋎ ψ) (d : 𝓢 ⊢! ∼φ) : 𝓢 ⊢! ψ := + AProofCases (CProofOfCNNProof (dhypProof d)) (CProofId) b + +omit [DecidableEq F] in +theorem of_A_of_N (b : 𝓢 ⊢ φ ⋎ ψ) (d : 𝓢 ⊢ ∼φ) : 𝓢 ⊢ ψ := by + classical exact ⟨ofAProofOfNProof b.get d.get⟩ +/-- The ECAN! construction in `FFL.Entailment`. -/ +def ECANProof : 𝓢 ⊢! (φ ⇒ₗ ψ) ⇔ₗ (∼φ ⋎ ψ) := + EProofIntro CCANProof (deduct'Proof (AProofCases CNCProof implyKProof byAxm₀Proof)) +omit [DecidableEq F] in +theorem ECAN : 𝓢 ⊢ (φ ⇒ₗ ψ) ⇔ₗ (∼φ ⋎ ψ) := by classical exact ⟨ECANProof⟩ +section + +omit [DecidableEq F] in +@[simp] +lemma CNDisj₂NConj₂ {Γ : List F} : 𝓢 ⊢ ∼⋁(Γ.map (∼·)) ⇒ₗ ⋀Γ := by + classical + induction Γ using List.induction_with_singleton with + | hnil => simp; + | hsingle => simp; + | hcons φ Γ hΓ ih => + simp_all only [ne_eq, not_false_eq_true, List.disj₂_cons_nonempty, List.map_cons, + List.map_eq_nil_iff, List.conj₂_cons_nonempty]; + suffices 𝓢 ⊢ ∼(∼φ ⋎ ∼∼⋁List.map (fun x ↦ ∼x) Γ) ⇒ₗ φ ⋏ ⋀Γ by + apply C_trans ?_ this; + apply contra; + apply CAA_of_C_right; + exact dne; + apply C_trans CNAKNN ?_; + apply CKK_of_C_of_C; + · exact dne; + · exact C_trans dne ih; + +lemma CNFdisj₂NFconj₂ {Γ : Finset F} : + 𝓢 ⊢ + ∼(PointwiseComposition.Finset.disj (Γ.image (∼·))) ⇒ₗ + (PointwiseComposition.Finset.conj Γ) := + by + apply C_replace ?_ ?_ <| CNDisj₂NConj₂ (Γ := Γ.toList); + · apply contra; apply left_Disj₂_intro; intro ψ hψ; apply right_Fdisj_intro; simpa using hψ; + · simp; + +end + +section consistency + +omit [Entailment.Cl 𝓢] + +variable [AdjunctiveSet F S] [Axiomatized S] [Deduction S] [∀ 𝓢 : S, Entailment.Cl 𝓢] + +omit [DecidableEq F] in +lemma provable_iff_inconsistent_adjoin {φ : F} : 𝓢 ⊢ φ ↔ Inconsistent (adjoin (∼φ) 𝓢) := by + classical + constructor + · intro h + apply inconsistent_of_provable_of_unprovable (φ := φ) + · exact Axiomatized.to_adjoin h + · exact Axiomatized.adjoinProof _ _ + · intro h + have : 𝓢 ⊢ ∼φ ⇒ₗ ⊥ := Deduction.of_insertProof (h _) + refine of_NN <| N_iff_CO.mpr this + +omit [DecidableEq F] in +lemma unprovable_iff_consistent_adjoin {φ : F} : 𝓢 ⊬ φ ↔ Consistent (adjoin (∼φ) 𝓢) := by + classical simpa using provable_iff_inconsistent_adjoin.not + +instance deductiveExplosion : Entailment.DeductiveExplosion S := + inferInstance + +end consistency + +section + +instance : HasAxiomPeirce 𝓢 where + peirceProof + {φ + ψ} := by + apply ofCProofOfCProofOfAProof implyKProof ?_ lemProof; apply deduct'Proof; + apply deductProof; refine (FiniteContext.byAxmProof (φ := (φ ⇒ₗ ψ) ⇒ₗ φ))⨀?_; + apply deductProof; apply efqOfMemEitherProof (φ := φ); · simp; + · simp; + +instance : HasAxiomEFQ 𝓢 := + inferInstance + +instance : Entailment.Int 𝓢 where + +end + +section + +variable {G T : Type*} [Entailment T G] [LogicalConnective G] [LogicalNeutral G] {𝓣 : T} + +/-- The of Equiv construction in `FFL.Entailment.Cl`. -/ +abbrev Cl.ofEquiv (𝓢 : S) [Entailment.Cl 𝓢] (𝓣 : T) (f : G →ˡᶜ F) + (e : (φ : G) → 𝓢 ⊢! f φ ≃ 𝓣 ⊢! φ) : Entailment.Cl 𝓣 + where + mdpProof + {φ ψ dpq dp} := + (e ψ) + (let d : 𝓢 ⊢! f φ ⇒ₗ f ψ := by simpa using (e (φ ⇒ₗ ψ)).symm dpq + d⨀((e φ).symm dp)) + negEquivProof := e _ (by simpa using negEquivProof) + verumProof := e _ (by simpa using verumProof) + implyKProof := e _ (by simpa using implyKProof) + implySProof := e _ (by simpa using implySProof) + and₁Proof := e _ (by simpa using and₁Proof) + and₂Proof := e _ (by simpa using and₂Proof) + and₃Proof := e _ (by simpa using and₃Proof) + or₁Proof := e _ (by simpa using or₁Proof) + or₂Proof := e _ (by simpa using or₂Proof) + or₃Proof := e _ (by simpa using or₃Proof) + dneProof := e _ (by simpa using dneProof) + +end + +section + +variable {S F : Type*} [LogicalConnective F] [LogicalNeutral F] [DecidableEq F] [Entailment S F] + {𝓢 : S} [Entailment.Int 𝓢] + +open FiniteContext + +instance [HasAxiomLEM 𝓢] : HasAxiomDNE 𝓢 where + dneProof {φ} := by + apply deduct'Proof; + exact ofCProofOfCProofOfAProof CProofId (by + apply deductProof; + have nnp : [∼φ, ∼∼φ] ⊢[𝓢]! ∼φ ⇒ₗ ⊥ := COProofOfNProof <| FiniteContext.byAxmProof; + have np : [∼φ, ∼∼φ] ⊢[𝓢]! ∼φ := FiniteContext.byAxmProof; + exact ofOProof <| nnp ⨀ np; + ) <| ofProof lemProof; + +instance [HasAxiomLEM 𝓢] : Entailment.Cl 𝓢 where + +end + +end Entailment +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/Propositional/Entailment/Int.lean b/LeanPool/PointwiseComposition/Foundation/Propositional/Entailment/Int.lean new file mode 100644 index 000000000..8a92d917f --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/Propositional/Entailment/Int.lean @@ -0,0 +1,510 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. +public import LeanPool.PointwiseComposition.Foundation.Propositional.Entailment.Minimal + +/-! Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace FFL +namespace Axioms + +variable {F : Type*} [LogicalConnective F] [LogicalNeutral F] +variable (φ ψ χ : F) + +/-- The EFQ construction in `FFL.Axioms`. -/ +protected abbrev EFQ := + ⊥ ⇒ₗ φ + +end Axioms +end FFL + +namespace FFL +namespace Entailment + +variable {S F : Type*} [LogicalConnective F] [LogicalNeutral F] [Entailment S F] +variable {𝓢 : S} {φ ψ χ : F} + +/-- Data and laws for Has Axiom EFQ in `FFL.Entailment`. -/ +class HasAxiomEFQ (𝓢 : S) where + /-- The efq! construction in `FFL.Entailment`. -/ + efqProof {φ : F} : 𝓢 ⊢! Axioms.EFQ φ +export HasAxiomEFQ (efqProof) + +@[simp] +lemma efq [Entailment.HasAxiomEFQ 𝓢] : 𝓢 ⊢ ⊥ ⇒ₗ φ := + ⟨efqProof⟩ + +/-- The of O! construction in `FFL.Entailment`. -/ +def ofOProof [ModusPonens 𝓢] [Entailment.HasAxiomEFQ 𝓢] (b : 𝓢 ⊢! ⊥) : 𝓢 ⊢! φ := + efqProof⨀b +@[grind ⇒] +lemma of_O [ModusPonens 𝓢] [Entailment.HasAxiomEFQ 𝓢] (h : 𝓢 ⊢ ⊥) : 𝓢 ⊢ φ := + ⟨ofOProof h.some⟩ + +instance [(𝓢 : S) → ModusPonens 𝓢] [(𝓢 : S) → HasAxiomEFQ 𝓢] : DeductiveExplosion S := + ⟨fun b _ ↦ efqProof⨀b⟩ + +section + +variable [Entailment.Minimal 𝓢] + +namespace FiniteContext + +instance [Entailment.HasAxiomEFQ 𝓢] (Γ : FiniteContext F 𝓢) : HasAxiomEFQ Γ := + ⟨ofProof efqProof⟩ + +instance [Entailment.HasAxiomEFQ 𝓢] : DeductiveExplosion (FiniteContext F 𝓢) := + inferInstance + +end FiniteContext + +namespace Context + +instance [Entailment.HasAxiomEFQ 𝓢] (Γ : Context F 𝓢) : HasAxiomEFQ Γ := + ⟨ofProof efqProof⟩ + +instance [Entailment.HasAxiomEFQ 𝓢] : DeductiveExplosion (FiniteContext F 𝓢) := + inferInstance + +end Context + +end + +end Entailment +end FFL + +namespace FFL +namespace Entailment + +variable {F : Type*} [LogicalConnective F] [LogicalNeutral F] [DecidableEq F] {S : Type*} + [Entailment S F] {𝓢 : S} {φ φ₁ φ₂ ψ ψ₁ ψ₂ χ ξ : F} {Γ Δ : List F} + +/-- Data and laws for Int in `FFL.Entailment`. -/ +protected class Int (𝓢 : S) extends Entailment.Minimal 𝓢, Entailment.HasAxiomEFQ 𝓢 + +variable [Entailment.Int 𝓢] + +namespace FiniteContext +instance (Γ : FiniteContext F 𝓢) : Entailment.Int Γ where +end FiniteContext + +namespace Context +instance (Γ : Context F 𝓢) : Entailment.Int Γ where +end Context + +open NegationEquiv +open FiniteContext +open _root_.List List + +/-- The efq of mem either! construction in `FFL.Entailment`. -/ +def efqOfMemEitherProof (h₁ : φ ∈ Γ) (h₂ : ∼φ ∈ Γ) : Γ ⊢[𝓢]! ψ := + ofOProof <| botOfMemEitherProof h₁ h₂ +omit [DecidableEq F] in +lemma efq_of_mem_either (h₁ : φ ∈ Γ) (h₂ : ∼φ ∈ Γ) : Γ ⊢[𝓢] ψ := by + classical exact ⟨efqOfMemEitherProof h₁ h₂⟩ +/-- The CNC! construction in `FFL.Entailment`. -/ +def CNCProof : 𝓢 ⊢! ∼φ ⇒ₗ φ ⇒ₗ ψ := by + apply deduct'Proof; + apply deductProof; + apply efqOfMemEitherProof (φ := φ) (by simp) (by simp); +omit [DecidableEq F] in +@[simp] +lemma CNC : 𝓢 ⊢ ∼φ ⇒ₗ φ ⇒ₗ ψ := by classical exact ⟨CNCProof⟩ +/-- The CCN! construction in `FFL.Entailment`. -/ +def CCNProof : 𝓢 ⊢! φ ⇒ₗ ∼φ ⇒ₗ ψ := by + apply deduct'Proof; + apply deductProof; + apply efqOfMemEitherProof (φ := φ) (by simp) (by simp); +omit [DecidableEq F] in +@[simp] +lemma CCN : 𝓢 ⊢ φ ⇒ₗ ∼φ ⇒ₗ ψ := by classical exact ⟨CCNProof⟩ +omit [DecidableEq F] in +lemma C_of_N (h : 𝓢 ⊢ ∼φ) : 𝓢 ⊢ φ ⇒ₗ ψ := by + classical + apply provable_iff_provable.mpr; + apply deduct_iff.mpr; + have dnp : [φ] ⊢[𝓢] φ ⇒ₗ ⊥ := of' <| N_iff_CO.mp h; + exact of_O (dnp ⨀ FiniteContext.id); + +omit [DecidableEq F] in +lemma CN_of_ (h : 𝓢 ⊢ φ) : 𝓢 ⊢ ∼φ ⇒ₗ ψ := by classical exact CCN⨀h +/-- The CANC! construction in `FFL.Entailment`. -/ +def CANCProof : 𝓢 ⊢! (∼φ ⋎ ψ) ⇒ₗ (φ ⇒ₗ ψ) := leftAProofIntro (by + apply emptyPrfProof; + apply deductProof; + apply deductProof; + exact efqOfMemEitherProof (φ := φ) (by simp) (by simp) + ) implyKProof +omit [DecidableEq F] in +@[simp] +lemma CANC : 𝓢 ⊢ (∼φ ⋎ ψ) ⇒ₗ (φ ⇒ₗ ψ) := by classical exact ⟨CANCProof⟩ +/-- The C! of AN! construction in `FFL.Entailment`. -/ +def CProofOfANProof (b : 𝓢 ⊢! ∼φ ⋎ ψ) : 𝓢 ⊢! φ ⇒ₗ ψ := + CANCProof⨀b +omit [DecidableEq F] in +lemma C_of_AN (b : 𝓢 ⊢ ∼φ ⋎ ψ) : 𝓢 ⊢ φ ⇒ₗ ψ := by classical exact ⟨CProofOfANProof b.some⟩ +/-- The CCNNNNNNC! construction in `FFL.Entailment`. -/ +def CCNNNNNNCProof : 𝓢 ⊢! (∼∼φ ⇒ₗ ∼∼ψ) ⇒ₗ ∼∼(φ ⇒ₗ ψ) := by + apply deduct'Proof; + apply NProofOfCOProof; + exact CProofTrans + (by + apply deductInvProof; + apply CCProofOfCKProof; + apply deductProof; + have d₁ : [(∼∼φ ⇒ₗ ∼∼ψ) ⋏ ∼(φ ⇒ₗ ψ)] ⊢[𝓢]! ∼∼φ ⇒ₗ ∼∼ψ := KProofLeft (ψ := ∼(φ ⇒ₗ ψ)) <| + FiniteContext.idProof; + have d₂ : [(∼∼φ ⇒ₗ ∼∼ψ) ⋏ ∼(φ ⇒ₗ ψ)] ⊢[𝓢]! ∼∼φ ⋏ ∼ψ := KNNProofOfNAProof <| (contraProof + CANCProof) ⨀ (KProofRight (φ := (∼∼φ ⇒ₗ ∼∼ψ)) <| FiniteContext.idProof) + exact KProofIntro (KProofRight d₂) (d₁ ⨀ (KProofLeft d₂)) + ) + (CKNOProof (φ := ∼ψ)); + + + +omit [DecidableEq F] in +@[simp] +lemma CCNNNNNNC : 𝓢 ⊢ (∼∼φ ⇒ₗ ∼∼ψ) ⇒ₗ ∼∼(φ ⇒ₗ ψ) := by classical exact ⟨CCNNNNNNCProof⟩ +/-- The NNC! of CNNNN! construction in `FFL.Entailment`. -/ +def NNCProofOfCNNNNProof (b : 𝓢 ⊢! ∼∼φ ⇒ₗ ∼∼ψ) : 𝓢 ⊢! ∼∼(φ ⇒ₗ ψ) := + CCNNNNNNCProof⨀b +omit [DecidableEq F] in +lemma NNC_of_CNNNN (b : 𝓢 ⊢ ∼∼φ ⇒ₗ ∼∼ψ) : 𝓢 ⊢ ∼∼(φ ⇒ₗ ψ) := by + classical exact ⟨NNCProofOfCNNNNProof b.some⟩ +section Conjunction + +end Conjunction + +section disjunction + +/-- The left Disj! intro construction in `FFL.Entailment`. -/ +def leftDisjProofIntro (Γ : List F) (b : (ψ : F) → ψ ∈ Γ → 𝓢 ⊢! ψ ⇒ₗ φ) : + 𝓢 ⊢! (PointwiseComposition.List.disj Γ) ⇒ₗ φ := + match Γ with + | [] => efqProof + | ψ :: Γ => + leftAProofIntro (b ψ (by simp)) <| leftDisjProofIntro Γ fun ψ h ↦ b ψ (by simp [h]) +omit [DecidableEq F] in +theorem left_Disj_intro (Γ : List F) (b : (ψ : F) → ψ ∈ Γ → 𝓢 ⊢ ψ ⇒ₗ φ) : + 𝓢 ⊢ (PointwiseComposition.List.disj Γ) ⇒ₗ φ := + ⟨leftDisjProofIntro Γ fun ψ h ↦ (b ψ h).get⟩ + +/-- The left Disj₂! intro construction in `FFL.Entailment`. -/ +def leftDisj₂ProofIntro (Γ : List F) (b : (ψ : F) → ψ ∈ Γ → 𝓢 ⊢! ψ ⇒ₗ φ) : 𝓢 ⊢! ⋁Γ ⇒ₗ φ := + match Γ with + | [] => efqProof + | [ψ] => b _ (by simp) + | ψ :: χ :: Γ => + leftAProofIntro (b ψ (by simp)) <| leftDisj₂ProofIntro _ fun ψ h ↦ b ψ (by simp [h]) + +omit [DecidableEq F] in +lemma left_Disj₂_intro (Γ : List F) (b : (ψ : F) → ψ ∈ Γ → 𝓢 ⊢ ψ ⇒ₗ φ) : 𝓢 ⊢ ⋁Γ ⇒ₗ φ := + ⟨leftDisj₂ProofIntro Γ fun ψ h ↦ (b ψ h).get⟩ + +/-- The left Disj'! intro construction in `FFL.Entailment`. -/ +def leftDisj'ProofIntro (l : List ι) (ψ : ι → F) (b : ∀ i ∈ l, 𝓢 ⊢! ψ i ⇒ₗ φ) : + 𝓢 ⊢! (PointwiseComposition.List.disj' · l) ψ ⇒ₗ φ := + leftDisj₂ProofIntro _ fun χ h ↦ + let ⟨i, hi, e⟩ := l.chooseX (ψ · = χ) (by simpa using h); + haveI := b i hi; + e ▸ this +omit [DecidableEq F] in +lemma left_Disj'_intro (l : List ι) (ψ : ι → F) (b : ∀ i ∈ l, 𝓢 ⊢ ψ i ⇒ₗ φ) : + 𝓢 ⊢ (PointwiseComposition.List.disj' · l) ψ ⇒ₗ φ := by + classical exact ⟨leftDisj'ProofIntro l ψ fun i hi ↦ (b i hi).get⟩ +lemma left_Fdisj_intro (s : Finset F) (b : (ψ : F) → ψ ∈ s → 𝓢 ⊢ ψ ⇒ₗ φ) : + 𝓢 ⊢ (PointwiseComposition.Finset.disj s) ⇒ₗ φ := + left_Disj₂_intro _ fun ψ h ↦ b ψ (by simpa using h) + +omit [DecidableEq F] in +lemma left_Fdisj'_intro (s : Finset ι) (ψ : ι → F) (b : ∀ i ∈ s, 𝓢 ⊢ ψ i ⇒ₗ φ) : + 𝓢 ⊢ (⋁ i ∈ s, ψ i) ⇒ₗ φ := by classical exact left_Disj'_intro _ _ (by simpa) +omit [DecidableEq F] in +lemma left_Udisj_intro [Fintype ι] (ψ : ι → F) (b : (i : ι) → 𝓢 ⊢ ψ i ⇒ₗ φ) : + 𝓢 ⊢ (⋁ i, ψ i) ⇒ₗ φ := by classical exact left_Fdisj'_intro _ _ (by simpa) +omit [DecidableEq F] in +lemma EDisj₂AppendADisj₂Disj₂ : 𝓢 ⊢ ⋁(Γ ++ Δ) ⇔ₗ ⋁Γ ⋎ ⋁Δ := by + induction Γ using List.induction_with_singleton generalizing Δ <;> induction Δ using + List.induction_with_singleton; + case hnil.hnil => + apply E_intro; + · simp; + · exact left_A_intro efq efq; + case hnil.hsingle => + apply E_intro; + · simp; + · exact left_A_intro efq C_id; + case hsingle.hnil => + apply E_intro; + · simp; + · exact left_A_intro C_id efq; + case hcons.hnil => + simp_all only [append_nil, disj₂_nil]; + apply E_intro; + · simp; + · exact left_A_intro C_id efq; + case hnil.hcons => + apply E_intro; + · simp; + · exact left_A_intro efq C_id; + case hsingle.hsingle => simp_all; + case hsingle.hcons => simp_all; + case hcons.hsingle φ ps hps ihp ψ => + simp_all only [cons_append, ne_eq, append_eq_nil_iff, cons_ne_self, and_false, + not_false_eq_true, + disj₂_cons_nonempty, disj₂_singleton]; + apply E_trans (by + apply EAA_of_E_right; + simpa using @ihp [ψ]; + ) EAAAA; + case hcons.hcons φ ps hps ihp ψ qs hqs ihq => + simp_all only [cons_append, ne_eq, append_eq_nil_iff, reduceCtorEq, and_false, + not_false_eq_true, + disj₂_cons_nonempty]; + exact E_trans (by + apply EAA_of_E_right; + exact E_trans (@ihp (ψ :: qs)) (by + apply EAA_of_E_right; + simp_all; + ) + ) EAAAA; + +omit [DecidableEq F] in +lemma Disj₂Append_iff_ADisj₂Disj₂ : 𝓢 ⊢ ⋁(Γ ++ Δ) ↔ 𝓢 ⊢ ⋁Γ ⋎ ⋁Δ := + by + constructor; · intro h; exact (K_left EDisj₂AppendADisj₂Disj₂)⨀h; + · intro h; exact (K_right EDisj₂AppendADisj₂Disj₂)⨀h; + +omit [DecidableEq F] in +lemma CDisj₂_iff_CADisj₂ : 𝓢 ⊢ φ ⇒ₗ ⋁(ψ :: Γ) ↔ 𝓢 ⊢ φ ⇒ₗ ψ ⋎ ⋁Γ := by + induction Γ with + | nil => + simp only [disj₂_singleton, disj₂_nil]; constructor; · intro h; exact C_trans h or₁; + · intro h; exact C_trans h <| left_A_intro C_id efq; + | cons ψ ih => simp; + +@[simp] +lemma CDisj₂ADisj₂Remove : 𝓢 ⊢ ⋁Γ ⇒ₗ φ ⋎ ⋁((PointwiseComposition.List.remove · Γ) φ) := by + induction Γ using List.induction_with_singleton with + | hnil => simp; + | hsingle ψ => + simp only [disj₂_singleton]; by_cases h : ψ = φ; · subst_vars; simp; + · simp [(List.remove_singleton_of_ne h)]; + | hcons ψ Γ h + ih => + simp_all only [ne_eq, not_false_eq_true, disj₂_cons_nonempty]; by_cases hpq : ψ = φ; + · simp_all only [List.remove_cons_self]; exact left_A_intro or₁ ih; + · simp_all only [(List.remove_cons_of_ne Γ hpq)]; + by_cases hqΓ : (PointwiseComposition.List.remove · Γ) φ = []; + · simp_all only [disj₂_nil, disj₂_singleton]; + exact left_A_intro or₂ (C_trans ih <| CAA_of_C_right efq); + · simp_all only [ne_eq, not_false_eq_true, disj₂_cons_nonempty]; + exact left_A_intro (C_trans or₁ or₂) (C_trans ih (CAA_of_C_right or₂)); + +omit [DecidableEq F] in +lemma left_Disj₂_intro' (hd : ∀ ψ ∈ Γ, ψ = φ) : 𝓢 ⊢ ⋁Γ ⇒ₗ φ := by + classical + induction Γ using List.induction_with_singleton with + | hcons ψ Δ hΔ ih => + simp_all only [ne_eq, mem_cons, true_or, or_true, implies_true, forall_const, + forall_eq_or_imp, not_false_eq_true, disj₂_cons_nonempty]; + have ⟨hd₁, hd₂⟩ := hd; subst hd₁; apply provable_iff_provable.mpr; apply deduct_iff.mpr; + exact + of_C_of_C_of_A (by simp) + (FiniteContext.weakening (by simp) <| provable_iff_provable.mp <| ih) id + | _ => simp_all; + +omit [DecidableEq F] in +lemma of_Disj₂_of_mem_eq (hd : ∀ ψ ∈ Γ, ψ = φ) (h : 𝓢 ⊢ ⋁Γ) : 𝓢 ⊢ φ := by + classical exact (left_Disj₂_intro' hd)⨀h +omit [DecidableEq F] in +@[simp] +lemma CDisj₂FDisj {Γ : Finset F} : 𝓢 ⊢ ⋁Γ.toList ⇒ₗ (PointwiseComposition.Finset.disj Γ) := by + classical apply left_Disj₂_intro; intro ψ hψ; apply right_Fdisj_intro; simpa using hψ; + +omit [DecidableEq F] in +@[simp] +lemma CFDisjDisj₂ {Γ : Finset F} : 𝓢 ⊢ (PointwiseComposition.Finset.disj Γ) ⇒ₗ ⋁Γ.toList := by + classical apply left_Fdisj_intro; intro ψ hψ; apply right_Disj₂_intro; simpa; + +omit [DecidableEq F] in +lemma CDisj₂Disj₂_of_subset {Γ Δ : List F} (h : ∀ φ ∈ Γ, φ ∈ Δ) : 𝓢 ⊢ ⋁Γ ⇒ₗ ⋁Δ := by + classical + match Δ with + | [] => have : Γ = [] := List.iff_nil_forall.mpr h; subst this; simp; + | [φ] => apply left_Disj₂_intro; intro ψ hψ; have := h ψ hψ; simp_all; + | φ :: Δ => apply left_Disj₂_intro; intro ψ hψ; apply right_Disj₂_intro; apply h; exact hψ; + +omit [DecidableEq F] in +lemma CFDisjFDisj_of_subset {Γ Δ : Finset F} (h : Γ ⊆ Δ) : + 𝓢 ⊢ (PointwiseComposition.Finset.disj Γ) ⇒ₗ (PointwiseComposition.Finset.disj Δ) := by + classical + refine + C_trans (C_trans ?_ (CDisj₂Disj₂_of_subset (Γ := Γ.toList) (Δ := Δ.toList) (by simpa))) + ?_ <;> + simp; + +lemma EDisj₂FDisj {Γ : List F} : 𝓢 ⊢ ⋁Γ ⇔ₗ (PointwiseComposition.Finset.disj Γ.toFinset) := by + match Γ with + | [] => simp; + | φ :: Γ => + apply E_intro; + · apply left_Disj₂_intro; simp only [List.mem_cons, List.toFinset_cons, forall_eq_or_imp]; + constructor; · apply right_Fdisj_intro; simp_all; + · intro ψ hψ; apply right_Fdisj_intro; simp_all; + · apply left_Fdisj_intro; + simp only [List.toFinset_cons, Finset.mem_insert, List.mem_toFinset, forall_eq_or_imp]; + constructor; · apply right_Disj₂_intro; tauto; + · intro ψ hψ; apply right_Disj₂_intro; tauto; + +lemma EDisj₂FDisj_doubleton : 𝓢 ⊢ ⋁[φ, ψ] ⇔ₗ Finset.disj { φ, ψ } := by + convert EDisj₂FDisj (𝓢 := 𝓢) (Γ := [φ, ψ]); simp; + +lemma EConj₂FConj_doubleton : 𝓢 ⊢ ⋁[φ, ψ] ↔ 𝓢 ⊢ Finset.disj { φ, ψ } := + by + constructor; · intro h; exact (C_of_E_mp <| EDisj₂FDisj_doubleton)⨀h; + · intro h; exact (C_of_E_mpr <| EDisj₂FDisj_doubleton)⨀h; + +@[simp] +lemma CAFDisjinsertFDisj {Γ : Finset F} : + 𝓢 ⊢ + φ ⋎ (PointwiseComposition.Finset.disj Γ) ⇒ₗ + (PointwiseComposition.Finset.disj (insert φ Γ)) := + by + apply left_A_intro; · apply right_Fdisj_intro; simp; + · apply CFDisjFDisj_of_subset; simp; + +@[simp] +lemma CinsertFDisjAFDisj {Γ : Finset F} : 𝓢 ⊢ (PointwiseComposition.Finset.disj (insert φ Γ)) ⇒ₗ + φ ⋎ (PointwiseComposition.Finset.disj Γ) := by + apply left_Fdisj_intro; + simp only [Finset.mem_insert, forall_eq_or_imp, or₁, true_and]; + intro ψ hψ; + apply right_A_intro_right; + apply right_Fdisj_intro; + assumption; + +@[simp] +lemma CAFdisjFdisjUnion {Γ Δ : Finset F} : + 𝓢 ⊢ + (PointwiseComposition.Finset.disj Γ) ⋎ (PointwiseComposition.Finset.disj Δ) ⇒ₗ + (PointwiseComposition.Finset.disj (Γ ∪ Δ)) := + by apply left_A_intro <;> · apply CFDisjFDisj_of_subset; simp; + +@[simp] +lemma CFdisjUnionAFdisj {Γ Δ : Finset F} : + 𝓢 ⊢ + (PointwiseComposition.Finset.disj (Γ ∪ Δ)) ⇒ₗ + (PointwiseComposition.Finset.disj Γ) ⋎ (PointwiseComposition.Finset.disj Δ) := + by + apply left_Fdisj_intro; simp only [Finset.mem_union]; rintro ψ (hψ | hψ); + · apply C_trans (ψ := (PointwiseComposition.Finset.disj Γ)) ?_ or₁; apply right_Fdisj_intro; + assumption; + · apply C_trans (ψ := (PointwiseComposition.Finset.disj Δ)) ?_ or₂; apply right_Fdisj_intro; + assumption; + +lemma left_Fdisj_intro' {Γ : Finset _} (hd : ∀ ψ ∈ Γ, ψ = φ) : + 𝓢 ⊢ (PointwiseComposition.Finset.disj Γ) ⇒ₗ φ := by + apply C_trans ?_ <| left_Disj₂_intro' (Γ := Γ.toList) (by simpa); simp; + +end disjunction + +section + +variable {Γ Δ : Finset F} + +lemma CFConjFDisj_of_A (hφψ : φ ⋎ ψ ∈ Γ) (hφ : φ ∈ Δ) (hψ : ψ ∈ Δ) : + 𝓢 ⊢ (PointwiseComposition.Finset.conj Γ) ⇒ₗ (PointwiseComposition.Finset.disj Δ) := + by + apply C_trans (ψ := Finset.disj { φ, ψ }); + · apply C_trans (ψ := Finset.conj {φ ⋎ ψ}) ?_; + · apply FConj_DT.mpr; + suffices ↑{φ ⋎ ψ} *⊢[𝓢] (PointwiseComposition.List.disj₂ [φ, ψ]) by + simpa using EConj₂FConj_doubleton.mp this; + apply Context.by_axm; simp; + · apply CFConjFConj_of_subset; simpa; + · apply left_Fdisj_intro; + simp only [Finset.mem_insert, Finset.mem_singleton, forall_eq_or_imp, forall_eq]; + constructor <;> · apply right_Fdisj_intro; assumption; + +end + +section + +omit [DecidableEq F] in +/-- List version of `CNAKNN` -/ +@[simp] +lemma CNDisj₁Conj₂ : 𝓢 ⊢ ∼⋁Γ ⇒ₗ ⋀(Γ.map (∼·)) := by + classical + induction Γ using List.induction_with_singleton with + | hnil => simp; + | hsingle => simp; + | hcons φ Γ hΓ ih => + simp_all only [ne_eq, not_false_eq_true, List.disj₂_cons_nonempty, List.map_cons, + List.map_eq_nil_iff, List.conj₂_cons_nonempty]; + refine C_trans CNAKNN ?_; apply CKK_of_C' ih; + +/-- - Finset version of `CNAKNN` -/ +@[simp] +lemma CNFdisjFconj {Γ : Finset F} : + 𝓢 ⊢ + ∼(PointwiseComposition.Finset.disj Γ) ⇒ₗ + (PointwiseComposition.Finset.conj (Γ.image (∼·))) := + by + apply C_replace ?_ ?_ <| CNDisj₁Conj₂ (Γ := Γ.toList); · apply contra; exact CDisj₂FDisj; + · apply CConj₂Conj₂_of_provable; intro φ hφ; apply FiniteContext.by_axm + simpa using hφ; + +omit [DecidableEq F] in +/-- - Finset version of `CKNNNA` -/ +@[simp] +lemma CConj₂NNDisj₂ : 𝓢 ⊢ ⋀Γ.map (∼·) ⇒ₗ ∼⋁Γ := by + classical + induction Γ using List.induction_with_singleton with + | hnil => simp; + | hsingle => simp; + | hcons φ Γ hΓ ih => + simp_all only [ne_eq, not_false_eq_true, List.disj₂_cons_nonempty, List.map_cons, + List.map_eq_nil_iff, List.conj₂_cons_nonempty]; + apply C_trans ?_ CKNNNA; apply CKK_of_C' ih; + +/-- - Finset version of `CKNNNA` -/ +@[simp] +lemma CFconjNNFconj {Γ : Finset F} : + 𝓢 ⊢ + (PointwiseComposition.Finset.conj (Γ.image (∼·))) ⇒ₗ + ∼(PointwiseComposition.Finset.disj Γ) := + by + apply C_replace ?_ ?_ <| CConj₂NNDisj₂ (Γ := Γ.toList); + · apply CConj₂Conj₂_of_provable; intro φ hφ; apply FiniteContext.by_axm + simpa using hφ; + · apply contra; simp; + +end + +section consistency + +omit [DecidableEq F] in +lemma inconsistent_of_provable_of_unprovable {φ : F} (hp : 𝓢 ⊢ φ) (hn : 𝓢 ⊢ ∼φ) : + Inconsistent 𝓢 := by + have : 𝓢 ⊢ φ ⇒ₗ ⊥ := N_iff_CO.mp hn + intro ψ; exact efq⨀(this⨀hp) + +end consistency + +end Entailment +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/Propositional/Entailment/Minimal.lean b/LeanPool/PointwiseComposition/Foundation/Propositional/Entailment/Minimal.lean new file mode 100644 index 000000000..8ed48063d --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/Propositional/Entailment/Minimal.lean @@ -0,0 +1,2012 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.Logic.Entailment +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Finset.Basic + +/-! Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace FFL +namespace Axioms + +variable {F : Type*} [LogicalConnective F] +variable (φ ψ χ : F) + +/-- The Neg Equiv construction in `FFL.Axioms`. -/ +protected abbrev NegEquiv [LogicalNeutral F] := + ∼φ ⇔ₗ (φ ⇒ₗ ⊥) + +/-- The Verum construction in `FFL.Axioms`. -/ +protected abbrev Verum [LogicalNeutral F] : F := + ⊤ + +/-- The Imply K construction in `FFL.Axioms`. -/ +protected abbrev ImplyK := + φ ⇒ₗ ψ ⇒ₗ φ + +/-- The Imply S construction in `FFL.Axioms`. -/ +protected abbrev ImplyS := + (φ ⇒ₗ ψ ⇒ₗ χ) ⇒ₗ (φ ⇒ₗ ψ) ⇒ₗ φ ⇒ₗ χ + +/-- The And Elim₁ construction in `FFL.Axioms`. -/ +protected abbrev AndElim₁ := + φ ⋏ ψ ⇒ₗ φ + +/-- The And Elim₂ construction in `FFL.Axioms`. -/ +protected abbrev AndElim₂ := + φ ⋏ ψ ⇒ₗ ψ + +/-- The And Inst construction in `FFL.Axioms`. -/ +protected abbrev AndInst := + φ ⇒ₗ ψ ⇒ₗ φ ⋏ ψ + +/-- The Or Inst₁ construction in `FFL.Axioms`. -/ +protected abbrev OrInst₁ := + φ ⇒ₗ φ ⋎ ψ + +/-- The Or Inst₂ construction in `FFL.Axioms`. -/ +protected abbrev OrInst₂ := + ψ ⇒ₗ φ ⋎ ψ + +/-- The Or Elim construction in `FFL.Axioms`. -/ +protected abbrev OrElim := + (φ ⇒ₗ χ) ⇒ₗ (ψ ⇒ₗ χ) ⇒ₗ (φ ⋎ ψ ⇒ₗ χ) + +end Axioms +end FFL + +namespace FFL +namespace Entailment + +-- def cast (e : φ = ψ) (b : 𝓢 ⊢! φ) : 𝓢 ⊢! ψ := e ▸ b +-- lemma cast! (e : φ = ψ) (b : 𝓢 ⊢ φ) : 𝓢 ⊢ ψ := ⟨cast e b.some⟩ + +section + +variable {S F : Type*} [LogicalConnective F] [Entailment S F] +variable {𝓢 : S} {φ ψ χ : F} + +/-- A proof system closed under modus ponens. -/ +class ModusPonens (𝓢 : S) where + /-- The mdp! construction in `FFL.Entailment.ModusPonens`. -/ + mdpProof {φ ψ : F} : 𝓢 ⊢! φ ⇒ₗ ψ → 𝓢 ⊢! φ → 𝓢 ⊢! ψ + +alias mdpProof := ModusPonens.mdpProof +/-- The «term ⨀ » construction in `FFL.Entailment`. -/ +infixl:90 "⨀" => mdpProof + +lemma mdp [ModusPonens 𝓢] : 𝓢 ⊢ φ ⇒ₗ ψ → 𝓢 ⊢ φ → 𝓢 ⊢ ψ := by rintro ⟨hpq⟩ ⟨hp⟩; exact ⟨hpq⨀hp⟩ +/-- The «term ⨀ 1» construction in `FFL.Entailment`. -/ +infixl:90 "⨀" => mdp +/-- The «term ⨀! » construction in `FFL.Entailment`. -/ +infixl:90 "⨀!" => mdpProof + +/-- Negation `∼φ` is equivalent to `φ ⇒ₗ ⊥` on **system**. + + This is weaker asssumption than _"introducing `∼φ` as an abbreviation of `φ ⇒ₗ ⊥`" (`NegAbbrev`)_. +-/ +class NegationEquiv [LogicalNeutral F] (𝓢 : S) where + /-- The neg Equiv! construction in `FFL.Entailment`. -/ + negEquivProof {φ : F} : 𝓢 ⊢! Axioms.NegEquiv φ +export NegationEquiv (negEquivProof) + +@[simp] +lemma neg_equiv [LogicalNeutral F] [NegationEquiv 𝓢] : 𝓢 ⊢ ∼φ ⇔ₗ (φ ⇒ₗ ⊥) := + ⟨negEquivProof⟩ + +/-- Proofs of the truth constant in the given proof system. -/ +class HasAxiomVerum [LogicalNeutral F] (𝓢 : S) where + /-- The verum! construction in `FFL.Entailment.HasAxiomVerum`. -/ + verumProof : 𝓢 ⊢! Axioms.Verum + +/-- The verum! construction in `FFL.Entailment`. -/ +def verumProof [LogicalNeutral F] [HasAxiomVerum 𝓢] : 𝓢 ⊢! ⊤ := + HasAxiomVerum.verumProof + +omit [LogicalConnective F] in +@[simp] +lemma verum [LogicalNeutral F] [HasAxiomVerum 𝓢] : 𝓢 ⊢ ⊤ := + ⟨verumProof⟩ + +/-- Proofs of the implication-K axiom in the given proof system. -/ +class HasAxiomImplyK (𝓢 : S) where + /-- The imply K! construction in `FFL.Entailment`. -/ + implyKProof {φ ψ : F} : 𝓢 ⊢! Axioms.ImplyK φ ψ +export HasAxiomImplyK (implyKProof) + +@[simp] +lemma implyK [HasAxiomImplyK 𝓢] : 𝓢 ⊢ φ ⇒ₗ ψ ⇒ₗ φ := + ⟨implyKProof⟩ + +/-- The C! of conseq! construction in `FFL.Entailment`. -/ +def CProofOfConseqProof [ModusPonens 𝓢] [HasAxiomImplyK 𝓢] (h : 𝓢 ⊢! φ) : 𝓢 ⊢! ψ ⇒ₗ φ := + implyKProof⨀h +alias dhypProof := CProofOfConseqProof + +lemma C_of_conseq [ModusPonens 𝓢] [HasAxiomImplyK 𝓢] (d : 𝓢 ⊢ φ) : 𝓢 ⊢ ψ ⇒ₗ φ := + ⟨CProofOfConseqProof d.some⟩ +alias dhyp := C_of_conseq + +/-- Proofs of the implication-S axiom in the given proof system. -/ +class HasAxiomImplyS (𝓢 : S) where + /-- The imply S! construction in `FFL.Entailment`. -/ + implySProof {φ ψ χ : F} : 𝓢 ⊢! Axioms.ImplyS φ ψ χ +export HasAxiomImplyS (implySProof) + +@[simp] +lemma implyS [HasAxiomImplyS 𝓢] : 𝓢 ⊢ (φ ⇒ₗ ψ ⇒ₗ χ) ⇒ₗ (φ ⇒ₗ ψ) ⇒ₗ φ ⇒ₗ χ := + ⟨implySProof⟩ + +/-- Proofs of the two conjunction-elimination axioms. -/ +class HasAxiomAndElim (𝓢 : S) where + /-- The and₁! construction in `FFL.Entailment`. -/ + and₁Proof {φ ψ : F} : 𝓢 ⊢! Axioms.AndElim₁ φ ψ + /-- The and₂! construction in `FFL.Entailment`. -/ + and₂Proof {φ ψ : F} : 𝓢 ⊢! Axioms.AndElim₂ φ ψ +export HasAxiomAndElim (and₁Proof and₂Proof) + +@[simp] +lemma and₁ [HasAxiomAndElim 𝓢] : 𝓢 ⊢ φ ⋏ ψ ⇒ₗ φ := + ⟨and₁Proof⟩ + +/-- The K! left construction in `FFL.Entailment`. -/ +def KProofLeft [ModusPonens 𝓢] [HasAxiomAndElim 𝓢] (d : 𝓢 ⊢! φ ⋏ ψ) : 𝓢 ⊢! φ := + and₁Proof⨀d +@[grind ->] +lemma K_left [ModusPonens 𝓢] [HasAxiomAndElim 𝓢] (d : 𝓢 ⊢ φ ⋏ ψ) : 𝓢 ⊢ φ := + ⟨KProofLeft d.some⟩ + +@[simp] +lemma and₂ [HasAxiomAndElim 𝓢] : 𝓢 ⊢ φ ⋏ ψ ⇒ₗ ψ := + ⟨and₂Proof⟩ + +/-- The K! right construction in `FFL.Entailment`. -/ +def KProofRight [ModusPonens 𝓢] [HasAxiomAndElim 𝓢] (d : 𝓢 ⊢! φ ⋏ ψ) : 𝓢 ⊢! ψ := + and₂Proof⨀d +@[grind ->] +lemma K_right [ModusPonens 𝓢] [HasAxiomAndElim 𝓢] (d : 𝓢 ⊢ φ ⋏ ψ) : 𝓢 ⊢ ψ := + ⟨KProofRight d.some⟩ + +/-- Proofs of the conjunction-introduction axiom. -/ +class HasAxiomAndInst (𝓢 : S) where + /-- The and₃! construction in `FFL.Entailment`. -/ + and₃Proof {φ ψ : F} : 𝓢 ⊢! Axioms.AndInst φ ψ +export HasAxiomAndInst (and₃Proof) + +@[simp] +lemma and₃ [HasAxiomAndInst 𝓢] : 𝓢 ⊢ φ ⇒ₗ ψ ⇒ₗ φ ⋏ ψ := + ⟨and₃Proof⟩ + +/-- The K! intro construction in `FFL.Entailment`. -/ +def KProofIntro [ModusPonens 𝓢] [HasAxiomAndInst 𝓢] (d₁ : 𝓢 ⊢! φ) (d₂ : 𝓢 ⊢! ψ) : 𝓢 ⊢! φ ⋏ ψ := + and₃Proof⨀d₁⨀d₂ +@[grind <-] +lemma K_intro [ModusPonens 𝓢] [HasAxiomAndInst 𝓢] (d₁ : 𝓢 ⊢ φ) (d₂ : 𝓢 ⊢ ψ) : 𝓢 ⊢ φ ⋏ ψ := + ⟨KProofIntro d₁.some d₂.some⟩ + +/-- Data and laws for Has Axiom Or Inst in `FFL.Entailment`. -/ +class HasAxiomOrInst (𝓢 : S) where + /-- The or₁! construction in `FFL.Entailment`. -/ + or₁Proof {φ ψ : F} : 𝓢 ⊢! Axioms.OrInst₁ φ ψ + /-- The or₂! construction in `FFL.Entailment`. -/ + or₂Proof {φ ψ : F} : 𝓢 ⊢! Axioms.OrInst₂ φ ψ +export HasAxiomOrInst (or₁Proof or₂Proof) + +@[simp] +lemma or₁ [HasAxiomOrInst 𝓢] : 𝓢 ⊢ φ ⇒ₗ φ ⋎ ψ := + ⟨or₁Proof⟩ + +/-- The A! intro left construction in `FFL.Entailment`. -/ +def AProofIntroLeft [HasAxiomOrInst 𝓢] [ModusPonens 𝓢] (d : 𝓢 ⊢! φ) : 𝓢 ⊢! φ ⋎ ψ := + or₁Proof⨀d +@[grind .] +lemma A_intro_left [HasAxiomOrInst 𝓢] [ModusPonens 𝓢] (d : 𝓢 ⊢ φ) : 𝓢 ⊢ φ ⋎ ψ := + ⟨AProofIntroLeft d.some⟩ + +@[simp] +lemma or₂ [HasAxiomOrInst 𝓢] : 𝓢 ⊢ ψ ⇒ₗ φ ⋎ ψ := + ⟨or₂Proof⟩ + +/-- The A! intro right construction in `FFL.Entailment`. -/ +def AProofIntroRight [HasAxiomOrInst 𝓢] [ModusPonens 𝓢] (d : 𝓢 ⊢! ψ) : 𝓢 ⊢! φ ⋎ ψ := + or₂Proof⨀d +@[grind .] +lemma A_intro_right [HasAxiomOrInst 𝓢] [ModusPonens 𝓢] (d : 𝓢 ⊢ ψ) : 𝓢 ⊢ φ ⋎ ψ := + ⟨AProofIntroRight d.some⟩ + +/-- Data and laws for Has Axiom Or Elim in `FFL.Entailment`. -/ +class HasAxiomOrElim (𝓢 : S) where + /-- The or₃! construction in `FFL.Entailment`. -/ + or₃Proof {φ ψ χ : F} : 𝓢 ⊢! Axioms.OrElim φ ψ χ +export HasAxiomOrElim (or₃Proof) + +@[simp] +lemma or₃ [HasAxiomOrElim 𝓢] : 𝓢 ⊢ (φ ⇒ₗ χ) ⇒ₗ (ψ ⇒ₗ χ) ⇒ₗ (φ ⋎ ψ) ⇒ₗ χ := + ⟨or₃Proof⟩ + +/-- The left A! intro construction in `FFL.Entailment`. -/ +def leftAProofIntro [HasAxiomOrElim 𝓢] [ModusPonens 𝓢] (d₁ : 𝓢 ⊢! φ ⇒ₗ χ) (d₂ : 𝓢 ⊢! ψ ⇒ₗ χ) : + 𝓢 ⊢! φ ⋎ ψ ⇒ₗ χ := + or₃Proof⨀d₁⨀d₂ +alias CAProofOfCProofOfCProof := leftAProofIntro + +lemma left_A_intro [HasAxiomOrElim 𝓢] [ModusPonens 𝓢] (d₁ : 𝓢 ⊢ φ ⇒ₗ χ) (d₂ : 𝓢 ⊢ ψ ⇒ₗ χ) : + 𝓢 ⊢ φ ⋎ ψ ⇒ₗ χ := + ⟨leftAProofIntro d₁.some d₂.some⟩ +alias CA_of_C_of_C := left_A_intro + +/-- The of C! of C! of A! construction in `FFL.Entailment`. -/ +def ofCProofOfCProofOfAProof [HasAxiomOrElim 𝓢] [ModusPonens 𝓢] (d₁ : 𝓢 ⊢! φ ⇒ₗ χ) + (d₂ : 𝓢 ⊢! ψ ⇒ₗ χ) (d₃ : 𝓢 ⊢! φ ⋎ ψ) : 𝓢 ⊢! χ := + or₃Proof⨀d₁⨀d₂⨀d₃ +alias AProofCases := ofCProofOfCProofOfAProof + +lemma of_C_of_C_of_A [HasAxiomOrElim 𝓢] [ModusPonens 𝓢] (d₁ : 𝓢 ⊢ φ ⇒ₗ χ) (d₂ : 𝓢 ⊢ ψ ⇒ₗ χ) + (d₃ : 𝓢 ⊢ φ ⋎ ψ) : 𝓢 ⊢ χ := + ⟨ofCProofOfCProofOfAProof d₁.some d₂.some d₃.some⟩ +alias A_cases := of_C_of_C_of_A + +/-- Data and laws for Minimal in `FFL.Entailment`. -/ +protected class Minimal [LogicalNeutral F] (𝓢 : S) extends ModusPonens 𝓢, NegationEquiv 𝓢, + HasAxiomVerum 𝓢, HasAxiomImplyK 𝓢, HasAxiomImplyS 𝓢, HasAxiomAndElim 𝓢, HasAxiomAndInst 𝓢, + HasAxiomOrInst 𝓢, HasAxiomOrElim 𝓢 + +end + +section + +variable {S F : Type*} [LogicalConnective F] [Entailment S F] +variable {𝓢 : S} [ModusPonens 𝓢] {φ ψ χ : F} + +/-- The CO! of N! construction in `FFL.Entailment`. -/ +def COProofOfNProof [LogicalNeutral F] [HasAxiomAndElim 𝓢] [NegationEquiv 𝓢] : + 𝓢 ⊢! ∼φ → 𝓢 ⊢! φ ⇒ₗ ⊥ := fun h => (KProofLeft negEquivProof)⨀h +/-- The N! of CO! construction in `FFL.Entailment`. -/ +def NProofOfCOProof [LogicalNeutral F] [HasAxiomAndElim 𝓢] [NegationEquiv 𝓢] : + 𝓢 ⊢! φ ⇒ₗ ⊥ → 𝓢 ⊢! ∼φ := fun h => (KProofRight negEquivProof)⨀h +@[grind =] +lemma N_iff_CO [LogicalNeutral F] [HasAxiomAndElim 𝓢] [NegationEquiv 𝓢] : 𝓢 ⊢ ∼φ ↔ 𝓢 ⊢ φ ⇒ₗ ⊥ := + ⟨fun ⟨h⟩ => ⟨COProofOfNProof h⟩, fun ⟨h⟩ => ⟨NProofOfCOProof h⟩⟩ + +/-- The E! intro construction in `FFL.Entailment`. -/ +def EProofIntro [HasAxiomAndInst 𝓢] (b₁ : 𝓢 ⊢! φ ⇒ₗ ψ) (b₂ : 𝓢 ⊢! ψ ⇒ₗ φ) : 𝓢 ⊢! φ ⇔ₗ ψ := + KProofIntro b₁ b₂ +@[grind ←] +lemma E_intro [HasAxiomAndInst 𝓢] (h₁ : 𝓢 ⊢ φ ⇒ₗ ψ) (h₂ : 𝓢 ⊢ ψ ⇒ₗ φ) : 𝓢 ⊢ φ ⇔ₗ ψ := + ⟨KProofIntro h₁.some h₂.some⟩ + +@[grind =] +lemma K_intro_iff [HasAxiomAndInst 𝓢] [HasAxiomAndElim 𝓢] : 𝓢 ⊢ φ ⋏ ψ ↔ 𝓢 ⊢ φ ∧ 𝓢 ⊢ ψ := by + grind +@[grind =] +lemma E_intro_iff [HasAxiomAndInst 𝓢] [HasAxiomAndElim 𝓢] : + 𝓢 ⊢ φ ⇔ₗ ψ ↔ 𝓢 ⊢ φ ⇒ₗ ψ ∧ 𝓢 ⊢ ψ ⇒ₗ φ := + ⟨fun h ↦ ⟨K_left h, K_right h⟩, by grind⟩ + +/-- The C! of E! mp construction in `FFL.Entailment`. -/ +def CProofOfEProofMp [HasAxiomAndElim 𝓢] (h : 𝓢 ⊢! φ ⇔ₗ ψ) : 𝓢 ⊢! φ ⇒ₗ ψ := + KProofLeft h +@[grind →] +lemma C_of_E_mp [HasAxiomAndElim 𝓢] : 𝓢 ⊢ φ ⇔ₗ ψ → 𝓢 ⊢ φ ⇒ₗ ψ := fun ⟨d⟩ => ⟨CProofOfEProofMp d⟩ + +/-- The C! of E! mpr construction in `FFL.Entailment`. -/ +def CProofOfEProofMpr [HasAxiomAndElim 𝓢] (h : 𝓢 ⊢! φ ⇔ₗ ψ) : 𝓢 ⊢! ψ ⇒ₗ φ := + KProofRight h +@[grind →] +lemma C_of_E_mpr [HasAxiomAndElim 𝓢] : 𝓢 ⊢ φ ⇔ₗ ψ → 𝓢 ⊢ ψ ⇒ₗ φ := fun ⟨d⟩ => + ⟨CProofOfEProofMpr d⟩ + +@[grind →] +lemma iff_of_E [HasAxiomAndElim 𝓢] (h : 𝓢 ⊢ φ ⇔ₗ ψ) : 𝓢 ⊢ φ ↔ 𝓢 ⊢ ψ := + ⟨fun hp ↦ K_left h⨀hp, fun hq ↦ K_right h⨀hq⟩ + +/-- The C! id construction in `FFL.Entailment`. -/ +def CProofId [HasAxiomImplyK 𝓢] [HasAxiomImplyS 𝓢] {φ : F} : 𝓢 ⊢! φ ⇒ₗ φ := + implySProof (φ := φ) (ψ := (φ ⇒ₗ φ)) (χ := φ)⨀implyKProof⨀implyKProof +@[simp] +theorem C_id [HasAxiomImplyK 𝓢] [HasAxiomImplyS 𝓢] : 𝓢 ⊢ φ ⇒ₗ φ := + ⟨CProofId⟩ + +/-- The E! id construction in `FFL.Entailment`. -/ +def EProofId [HasAxiomAndInst 𝓢] [HasAxiomImplyK 𝓢] [HasAxiomImplyS 𝓢] {φ : F} : 𝓢 ⊢! φ ⇔ₗ φ := + KProofIntro CProofId CProofId +@[simp] +theorem E_id [HasAxiomAndInst 𝓢] [HasAxiomImplyK 𝓢] [HasAxiomImplyS 𝓢] : 𝓢 ⊢ φ ⇔ₗ φ := + ⟨EProofId⟩ + +instance [LogicalNeutral F] [NegAbbrev F] [HasAxiomImplyK 𝓢] [HasAxiomImplyS 𝓢] + [HasAxiomAndInst 𝓢] : Entailment.NegationEquiv 𝓢 where + negEquivProof + {φ} := + by + suffices 𝓢 ⊢! (φ ⇒ₗ ⊥) ⇔ₗ (φ ⇒ₗ ⊥) by simpa [Axioms.NegEquiv, NegAbbrev.neg]; + apply EProofId; + +/-- The NO! construction in `FFL.Entailment`. -/ +def NOProof [LogicalNeutral F] [HasAxiomImplyK 𝓢] [HasAxiomImplyS 𝓢] [NegationEquiv 𝓢] + [HasAxiomAndElim 𝓢] : 𝓢 ⊢! ∼⊥ := + NProofOfCOProof CProofId +@[simp] +lemma NO [LogicalNeutral F] [HasAxiomImplyK 𝓢] [HasAxiomImplyS 𝓢] [NegationEquiv 𝓢] + [HasAxiomAndElim 𝓢] : 𝓢 ⊢ ∼⊥ := + ⟨NOProof⟩ + +/-- The mdp₁! construction in `FFL.Entailment`. -/ +def mdp₁Proof [HasAxiomImplyS 𝓢] (bqr : 𝓢 ⊢! φ ⇒ₗ ψ ⇒ₗ χ) (bq : 𝓢 ⊢! φ ⇒ₗ ψ) : 𝓢 ⊢! φ ⇒ₗ χ := + implySProof⨀bqr⨀bq +@[grind →] +lemma mdp₁ [HasAxiomImplyS 𝓢] (hqr : 𝓢 ⊢ φ ⇒ₗ ψ ⇒ₗ χ) (hq : 𝓢 ⊢ φ ⇒ₗ ψ) : 𝓢 ⊢ φ ⇒ₗ χ := + ⟨mdp₁Proof hqr.some hq.some⟩ + +/-- The «term ⨀₁ » construction in `FFL.Entailment`. -/ +infixl:90 "⨀₁" => mdp₁Proof +/-- The «term ⨀₁ 1» construction in `FFL.Entailment`. -/ +infixl:90 "⨀₁" => mdp₁ + +/-- The mdp₂! construction in `FFL.Entailment`. -/ +def mdp₂Proof [HasAxiomImplyK 𝓢] [HasAxiomImplyS 𝓢] (bqr : 𝓢 ⊢! φ ⇒ₗ ψ ⇒ₗ χ ⇒ₗ s) + (bq : 𝓢 ⊢! φ ⇒ₗ ψ ⇒ₗ χ) : 𝓢 ⊢! φ ⇒ₗ ψ ⇒ₗ s := + CProofOfConseqProof (implySProof)⨀₁bqr⨀₁bq +@[grind →] +lemma mdp₂ [HasAxiomImplyK 𝓢] [HasAxiomImplyS 𝓢] (hqr : 𝓢 ⊢ φ ⇒ₗ ψ ⇒ₗ χ ⇒ₗ s) + (hq : 𝓢 ⊢ φ ⇒ₗ ψ ⇒ₗ χ) : 𝓢 ⊢ φ ⇒ₗ ψ ⇒ₗ s := + ⟨mdp₂Proof hqr.some hq.some⟩ + +/-- The «term ⨀₂ » construction in `FFL.Entailment`. -/ +infixl:90 "⨀₂" => mdp₂Proof +/-- The «term ⨀₂ 1» construction in `FFL.Entailment`. -/ +infixl:90 "⨀₂" => mdp₂ + +/-- The mdp₃! construction in `FFL.Entailment`. -/ +def mdp₃Proof [HasAxiomImplyK 𝓢] [HasAxiomImplyS 𝓢] (bqr : 𝓢 ⊢! φ ⇒ₗ ψ ⇒ₗ χ ⇒ₗ s ⇒ₗ t) + (bq : 𝓢 ⊢! φ ⇒ₗ ψ ⇒ₗ χ ⇒ₗ s) : 𝓢 ⊢! φ ⇒ₗ ψ ⇒ₗ χ ⇒ₗ t := + (CProofOfConseqProof <| CProofOfConseqProof <| implySProof)⨀₂bqr⨀₂bq +@[grind →] +lemma mdp₃ [HasAxiomImplyK 𝓢] [HasAxiomImplyS 𝓢] (hqr : 𝓢 ⊢ φ ⇒ₗ ψ ⇒ₗ χ ⇒ₗ s ⇒ₗ t) + (hq : 𝓢 ⊢ φ ⇒ₗ ψ ⇒ₗ χ ⇒ₗ s) : 𝓢 ⊢ φ ⇒ₗ ψ ⇒ₗ χ ⇒ₗ t := + ⟨mdp₃Proof hqr.some hq.some⟩ + +/-- The «term ⨀₃ » construction in `FFL.Entailment`. -/ +infixl:90 "⨀₃" => mdp₃Proof +/-- The «term ⨀₃ 1» construction in `FFL.Entailment`. -/ +infixl:90 "⨀₃" => mdp₃ + +/-- The mdp₄! construction in `FFL.Entailment`. -/ +def mdp₄Proof [HasAxiomImplyK 𝓢] [HasAxiomImplyS 𝓢] (bqr : 𝓢 ⊢! φ ⇒ₗ ψ ⇒ₗ χ ⇒ₗ s ⇒ₗ t ⇒ₗ u) + (bq : 𝓢 ⊢! φ ⇒ₗ ψ ⇒ₗ χ ⇒ₗ s ⇒ₗ t) : 𝓢 ⊢! φ ⇒ₗ ψ ⇒ₗ χ ⇒ₗ s ⇒ₗ u := + (CProofOfConseqProof <| CProofOfConseqProof <| CProofOfConseqProof <| implySProof)⨀₃bqr⨀₃bq +@[grind →] +lemma mdp₄ [HasAxiomImplyK 𝓢] [HasAxiomImplyS 𝓢] (hqr : 𝓢 ⊢ φ ⇒ₗ ψ ⇒ₗ χ ⇒ₗ s ⇒ₗ t ⇒ₗ u) + (hq : 𝓢 ⊢ φ ⇒ₗ ψ ⇒ₗ χ ⇒ₗ s ⇒ₗ t) : 𝓢 ⊢ φ ⇒ₗ ψ ⇒ₗ χ ⇒ₗ s ⇒ₗ u := + ⟨mdp₄Proof hqr.some hq.some⟩ +/-- The «term ⨀₄ » construction in `FFL.Entailment`. -/ +infixl:90 "⨀₄" => mdp₄Proof +/-- The «term ⨀₄ 1» construction in `FFL.Entailment`. -/ +infixl:90 "⨀₄" => mdp₄ + +/-- The C! trans construction in `FFL.Entailment`. -/ +def CProofTrans [HasAxiomImplyK 𝓢] [HasAxiomImplyS 𝓢] (bpq : 𝓢 ⊢! φ ⇒ₗ ψ) (bqr : 𝓢 ⊢! ψ ⇒ₗ χ) : + 𝓢 ⊢! φ ⇒ₗ χ := + implySProof⨀CProofOfConseqProof bqr⨀bpq +@[grind <=] +lemma C_trans [HasAxiomImplyK 𝓢] [HasAxiomImplyS 𝓢] (hpq : 𝓢 ⊢ φ ⇒ₗ ψ) (hqr : 𝓢 ⊢ ψ ⇒ₗ χ) : + 𝓢 ⊢ φ ⇒ₗ χ := + ⟨CProofTrans hpq.some hqr.some⟩ + +/-- The C! replace construction in `FFL.Entailment`. -/ +def CProofReplace [HasAxiomImplyK 𝓢] [HasAxiomImplyS 𝓢] (h₁ : 𝓢 ⊢! ψ₁ ⇒ₗ φ₁) + (h₂ : 𝓢 ⊢! φ₂ ⇒ₗ ψ₂) : 𝓢 ⊢! φ₁ ⇒ₗ φ₂ → 𝓢 ⊢! ψ₁ ⇒ₗ ψ₂ := fun h => + CProofTrans h₁ <| CProofTrans h h₂ +lemma C_replace [HasAxiomImplyK 𝓢] [HasAxiomImplyS 𝓢] (h₁ : 𝓢 ⊢ ψ₁ ⇒ₗ φ₁) (h₂ : 𝓢 ⊢ φ₂ ⇒ₗ ψ₂) : + 𝓢 ⊢ φ₁ ⇒ₗ φ₂ → 𝓢 ⊢ ψ₁ ⇒ₗ ψ₂ := fun h => ⟨CProofReplace h₁.some h₂.some h.some⟩ + +/-- The E! replace construction in `FFL.Entailment`. -/ +def EProofReplace [HasAxiomAndInst 𝓢] [HasAxiomAndElim 𝓢] [HasAxiomImplyK 𝓢] [HasAxiomImplyS 𝓢] + (h₁ : 𝓢 ⊢! φ₁ ⇔ₗ ψ₁) (h₂ : 𝓢 ⊢! φ₂ ⇔ₗ ψ₂) (h₃ : 𝓢 ⊢! φ₁ ⇔ₗ φ₂) : 𝓢 ⊢! ψ₁ ⇔ₗ ψ₂ := + by + apply EProofIntro; + · exact CProofReplace (CProofOfEProofMpr h₁) (CProofOfEProofMp h₂) (CProofOfEProofMp h₃); + · exact CProofReplace (CProofOfEProofMpr h₂) (CProofOfEProofMp h₁) (CProofOfEProofMpr h₃); +lemma E_replace [HasAxiomAndInst 𝓢] [HasAxiomAndElim 𝓢] [HasAxiomImplyK 𝓢] [HasAxiomImplyS 𝓢] : + 𝓢 ⊢ φ₁ ⇔ₗ ψ₁ → 𝓢 ⊢ φ₂ ⇔ₗ ψ₂ → 𝓢 ⊢ φ₁ ⇔ₗ φ₂ → 𝓢 ⊢ ψ₁ ⇔ₗ ψ₂ := fun ⟨d₁⟩ ⟨d₂⟩ ⟨d₃⟩ => + ⟨EProofReplace d₁ d₂ d₃⟩ + +/-- The E! trans construction in `FFL.Entailment`. -/ +def EProofTrans [HasAxiomAndInst 𝓢] [HasAxiomAndElim 𝓢] [HasAxiomImplyK 𝓢] [HasAxiomImplyS 𝓢] + (h₁ : 𝓢 ⊢! φ ⇔ₗ ψ) (h₂ : 𝓢 ⊢! ψ ⇔ₗ χ) : 𝓢 ⊢! φ ⇔ₗ χ := + by + apply EProofIntro; · exact CProofTrans (KProofLeft h₁) (KProofLeft h₂); + · exact CProofTrans (KProofRight h₂) (KProofRight h₁); +@[grind <=] +lemma E_trans [HasAxiomAndInst 𝓢] [HasAxiomAndElim 𝓢] [HasAxiomImplyK 𝓢] [HasAxiomImplyS 𝓢] + (h₁ : 𝓢 ⊢ φ ⇔ₗ ψ) (h₂ : 𝓢 ⊢ ψ ⇔ₗ χ) : 𝓢 ⊢ φ ⇔ₗ χ := + ⟨EProofTrans h₁.some h₂.some⟩ + +/-- The CCCC! construction in `FFL.Entailment`. -/ +def CCCCProof [HasAxiomImplyK 𝓢] [HasAxiomImplyS 𝓢] : 𝓢 ⊢! φ ⇒ₗ ψ ⇒ₗ χ ⇒ₗ φ := + CProofTrans implyKProof implyKProof +@[grind .] +lemma CCCC [HasAxiomImplyK 𝓢] [HasAxiomImplyS 𝓢] : 𝓢 ⊢ φ ⇒ₗ ψ ⇒ₗ χ ⇒ₗ φ := + ⟨CCCCProof⟩ + +/-- The CK! of C! of C! construction in `FFL.Entailment`. -/ +def CKProofOfCProofOfCProof [HasAxiomAndInst 𝓢] [HasAxiomImplyK 𝓢] [HasAxiomImplyS 𝓢] + (bq : 𝓢 ⊢! φ ⇒ₗ ψ) (br : 𝓢 ⊢! φ ⇒ₗ χ) : 𝓢 ⊢! φ ⇒ₗ ψ ⋏ χ := + CProofOfConseqProof and₃Proof⨀₁bq⨀₁br +@[grind <=] +lemma CK_of_C_of_C [HasAxiomAndInst 𝓢] [HasAxiomImplyK 𝓢] [HasAxiomImplyS 𝓢] (hq : 𝓢 ⊢ φ ⇒ₗ ψ) + (hr : 𝓢 ⊢ φ ⇒ₗ χ) : 𝓢 ⊢ φ ⇒ₗ ψ ⋏ χ := + ⟨CKProofOfCProofOfCProof hq.some hr.some⟩ + +/-- The CKK! construction in `FFL.Entailment`. -/ +def CKKProof [HasAxiomAndInst 𝓢] [HasAxiomAndElim 𝓢] [HasAxiomImplyK 𝓢] [HasAxiomImplyS 𝓢] : + 𝓢 ⊢! φ ⋏ ψ ⇒ₗ ψ ⋏ φ := + CKProofOfCProofOfCProof and₂Proof and₁Proof +@[simp, grind .] +lemma CKK [HasAxiomAndInst 𝓢] [HasAxiomAndElim 𝓢] [HasAxiomImplyK 𝓢] [HasAxiomImplyS 𝓢] : + 𝓢 ⊢ φ ⋏ ψ ⇒ₗ ψ ⋏ φ := + ⟨CKKProof⟩ + +/-- The K! symm construction in `FFL.Entailment`. -/ +def KProofSymm [HasAxiomAndInst 𝓢] [HasAxiomAndElim 𝓢] [HasAxiomImplyK 𝓢] [HasAxiomImplyS 𝓢] + (h : 𝓢 ⊢! φ ⋏ ψ) : 𝓢 ⊢! ψ ⋏ φ := + CKKProof⨀h +@[grind <-] +lemma K_symm [HasAxiomAndInst 𝓢] [HasAxiomAndElim 𝓢] [HasAxiomImplyK 𝓢] [HasAxiomImplyS 𝓢] + (h : 𝓢 ⊢ φ ⋏ ψ) : 𝓢 ⊢ ψ ⋏ φ := + ⟨KProofSymm h.some⟩ + +/-- The CEE! construction in `FFL.Entailment`. -/ +def CEEProof [HasAxiomAndInst 𝓢] [HasAxiomAndElim 𝓢] [HasAxiomImplyK 𝓢] [HasAxiomImplyS 𝓢] : + 𝓢 ⊢! (φ ⇔ₗ ψ) ⇒ₗ (ψ ⇔ₗ φ) := + CKKProof +@[simp] +lemma CEE [HasAxiomAndInst 𝓢] [HasAxiomAndElim 𝓢] [HasAxiomImplyK 𝓢] [HasAxiomImplyS 𝓢] : + 𝓢 ⊢ (φ ⇔ₗ ψ) ⇒ₗ (ψ ⇔ₗ φ) := + ⟨CEEProof⟩ + +/-- The E! symm construction in `FFL.Entailment`. -/ +def EProofSymm [HasAxiomAndInst 𝓢] [HasAxiomAndElim 𝓢] [HasAxiomImplyK 𝓢] [HasAxiomImplyS 𝓢] + (h : 𝓢 ⊢! φ ⇔ₗ ψ) : 𝓢 ⊢! ψ ⇔ₗ φ := + CEEProof⨀h +@[grind <-] +lemma E_symm [HasAxiomAndInst 𝓢] [HasAxiomAndElim 𝓢] [HasAxiomImplyK 𝓢] [HasAxiomImplyS 𝓢] + (h : 𝓢 ⊢ φ ⇔ₗ ψ) : 𝓢 ⊢ ψ ⇔ₗ φ := + ⟨EProofSymm h.some⟩ + +/-- The ECKCC! construction in `FFL.Entailment`. -/ +def ECKCCProof [HasAxiomAndInst 𝓢] [HasAxiomAndElim 𝓢] [HasAxiomImplyK 𝓢] [HasAxiomImplyS 𝓢] : + 𝓢 ⊢! (φ ⋏ ψ ⇒ₗ χ) ⇔ₗ (φ ⇒ₗ ψ ⇒ₗ χ) := + by + let b₁ : 𝓢 ⊢! (φ ⋏ ψ ⇒ₗ χ) ⇒ₗ φ ⇒ₗ ψ ⇒ₗ χ := + CCCCProof⨀₃CProofOfConseqProof (ψ := φ ⋏ ψ ⇒ₗ χ) and₃Proof + let b₂ : 𝓢 ⊢! (φ ⇒ₗ ψ ⇒ₗ χ) ⇒ₗ φ ⋏ ψ ⇒ₗ χ := + implyKProof⨀₂(CProofOfConseqProof (ψ := φ ⇒ₗ ψ ⇒ₗ χ) + and₁Proof)⨀₂(CProofOfConseqProof (ψ := φ ⇒ₗ ψ ⇒ₗ χ) and₂Proof); + exact EProofIntro b₁ b₂ +@[simp, grind .] +lemma ECKCC [HasAxiomAndInst 𝓢] [HasAxiomAndElim 𝓢] [HasAxiomImplyK 𝓢] [HasAxiomImplyS 𝓢] : + 𝓢 ⊢ (φ ⋏ ψ ⇒ₗ χ) ⇔ₗ (φ ⇒ₗ ψ ⇒ₗ χ) := + ⟨ECKCCProof⟩ + +/-- The CC! of CK! construction in `FFL.Entailment`. -/ +def CCProofOfCKProof [HasAxiomAndInst 𝓢] [HasAxiomAndElim 𝓢] [HasAxiomImplyK 𝓢] + [HasAxiomImplyS 𝓢] (d : 𝓢 ⊢! φ ⋏ ψ ⇒ₗ χ) : 𝓢 ⊢! φ ⇒ₗ ψ ⇒ₗ χ := + (KProofLeft <| ECKCCProof)⨀d +/-- The CK! of CC! construction in `FFL.Entailment`. -/ +def CKProofOfCCProof [HasAxiomAndInst 𝓢] [HasAxiomAndElim 𝓢] [HasAxiomImplyK 𝓢] + [HasAxiomImplyS 𝓢] (d : 𝓢 ⊢! φ ⇒ₗ ψ ⇒ₗ χ) : 𝓢 ⊢! φ ⋏ ψ ⇒ₗ χ := + (KProofRight <| ECKCCProof)⨀d + +@[grind =] +lemma CK_iff_CC [HasAxiomAndInst 𝓢] [HasAxiomAndElim 𝓢] [HasAxiomImplyK 𝓢] [HasAxiomImplyS 𝓢] : + (𝓢 ⊢ φ ⋏ ψ ⇒ₗ χ) ↔ (𝓢 ⊢ φ ⇒ₗ ψ ⇒ₗ χ) := + iff_of_E ECKCC + +/-- The CV! construction in `FFL.Entailment`. -/ +def CVProof [LogicalNeutral F] [HasAxiomVerum 𝓢] [HasAxiomImplyK 𝓢] : 𝓢 ⊢! φ ⇒ₗ ⊤ := + CProofOfConseqProof verumProof +@[simp] +lemma CV [LogicalNeutral F] [HasAxiomImplyK 𝓢] [HasAxiomVerum 𝓢] : 𝓢 ⊢ φ ⇒ₗ ⊤ := + ⟨CVProof⟩ + +@[grind →] +lemma unprovable_C_trans [HasAxiomImplyK 𝓢] [HasAxiomImplyS 𝓢] (hpq : 𝓢 ⊢ φ ⇒ₗ ψ) : + 𝓢 ⊬ φ ⇒ₗ χ → 𝓢 ⊬ ψ ⇒ₗ χ := by contrapose!; exact C_trans hpq; + +@[grind →] +lemma uniff_of_E [HasAxiomAndElim 𝓢] (H : 𝓢 ⊢ φ ⇔ₗ ψ) : 𝓢 ⊬ φ ↔ 𝓢 ⊬ ψ := + by + constructor; · intro hp hq; have := K_right H⨀hq; contradiction; + · intro hq hp; have := K_left H⨀hp; contradiction; + +end + +section + +variable {S F : Type*} [LogicalConnective F] [LogicalNeutral F] [Entailment S F] +variable {𝓢 : S} [Entailment.Minimal 𝓢] {φ ψ χ : F} + +variable {Γ Δ : List F} + +/-- The conj₂Nth! construction in `FFL.Entailment`. -/ +def conj₂NthProof : (Γ : List F) → (n : ℕ) → (hn : n < Γ.length) → 𝓢 ⊢! ⋀Γ ⇒ₗ Γ[n] + | [], _, hn => by simp at hn + | [ψ], 0, _ => CProofId + | φ :: ψ :: Γ, 0, _ => and₁Proof + | φ :: ψ :: Γ, n + 1, hn => + CProofTrans (and₂Proof (φ := φ)) (conj₂NthProof (ψ :: Γ) n (Nat.succ_lt_succ_iff.mp hn)) + +theorem conj₂_nth (Γ : List F) (n : ℕ) (hn : n < Γ.length) : 𝓢 ⊢ ⋀Γ ⇒ₗ Γ[n] := + ⟨conj₂NthProof Γ n hn⟩ + +/-- The left Conj! intro construction in `FFL.Entailment`. -/ +def leftConjProofIntro [DecidableEq F] {Γ : List F} {φ : F} (h : φ ∈ Γ) : + 𝓢 ⊢! (PointwiseComposition.List.conj Γ) ⇒ₗ φ := + match Γ with + | [] => by simp at h + | ψ :: Γ => + if e : φ = ψ then e ▸ and₁Proof + else + have : φ ∈ Γ := by simpa [e] using h + CProofTrans and₂Proof (leftConjProofIntro this) +lemma left_Conj_intro (h : φ ∈ Γ) : 𝓢 ⊢ (PointwiseComposition.List.conj Γ) ⇒ₗ φ := by + classical exact ⟨leftConjProofIntro h⟩ +/-- The Conj! intro construction in `FFL.Entailment`. -/ +def ConjProofIntro (Γ : List F) (b : (φ : F) → φ ∈ Γ → 𝓢 ⊢! φ) : + 𝓢 ⊢! (PointwiseComposition.List.conj Γ) := + match Γ with + | [] => verumProof + | ψ :: Γ => KProofIntro (b ψ (by simp)) (ConjProofIntro Γ (fun ψ hq ↦ b ψ (by simp [hq]))) +lemma Conj_intro {Γ : List F} (b : (φ : F) → φ ∈ Γ → 𝓢 ⊢ φ) : + 𝓢 ⊢ (PointwiseComposition.List.conj Γ) := + ⟨ConjProofIntro Γ fun φ hφ => (b φ hφ).some⟩ + +/-- The right Conj! intro construction in `FFL.Entailment`. -/ +def rightConjProofIntro (φ : F) (Γ : List F) (b : (ψ : F) → ψ ∈ Γ → 𝓢 ⊢! φ ⇒ₗ ψ) : + 𝓢 ⊢! φ ⇒ₗ (PointwiseComposition.List.conj Γ) := + match Γ with + | [] => CProofOfConseqProof verumProof + | ψ :: Γ => + CKProofOfCProofOfCProof (b ψ (by simp)) + (rightConjProofIntro φ Γ (fun ψ hq ↦ b ψ (by simp [hq]))) +theorem right_Conj_intro (φ : F) (Γ : List F) (b : (ψ : F) → ψ ∈ Γ → 𝓢 ⊢ φ ⇒ₗ ψ) : + 𝓢 ⊢ φ ⇒ₗ (PointwiseComposition.List.conj Γ) := + ⟨rightConjProofIntro φ Γ fun ψ h ↦ (b ψ h).get⟩ + +/-- The CConj Conj! construction in `FFL.Entailment`. -/ +def CConjConjProof [DecidableEq F] (h : Δ ⊆ Γ) : + 𝓢 ⊢! (PointwiseComposition.List.conj Γ) ⇒ₗ (PointwiseComposition.List.conj Δ) := + rightConjProofIntro _ _ (fun _ hq ↦ leftConjProofIntro (h hq)) + +/-- The left Conj₂! intro construction in `FFL.Entailment`. -/ +def leftConj₂ProofIntro [DecidableEq F] {Γ : List F} {φ : F} (h : φ ∈ Γ) : 𝓢 ⊢! ⋀Γ ⇒ₗ φ := + have : Γ.idxOf φ < Γ.length := List.idxOf_lt_length_of_mem h + cast <| conj₂NthProof Γ (Γ.idxOf φ) (by assumption) +lemma left_Conj₂_intro (h : φ ∈ Γ) : 𝓢 ⊢ ⋀Γ ⇒ₗ φ := by classical exact ⟨leftConj₂ProofIntro h⟩ +/-- The Conj₂! intro construction in `FFL.Entailment`. -/ +def Conj₂ProofIntro (Γ : List F) (b : (φ : F) → φ ∈ Γ → 𝓢 ⊢! φ) : 𝓢 ⊢! ⋀Γ := + match Γ with + | [] => verumProof + | [ψ] => by apply b; simp; + | ψ :: χ :: Γ => by exact KProofIntro (b ψ (by simp)) (Conj₂ProofIntro _ (by aesop)) +lemma Conj₂_intro (b : (φ : F) → φ ∈ Γ → 𝓢 ⊢ φ) : 𝓢 ⊢ ⋀Γ := + ⟨Conj₂ProofIntro Γ (fun φ hp => (b φ hp).some)⟩ + +/-- The right Conj₂! intro construction in `FFL.Entailment`. -/ +def rightConj₂ProofIntro (φ : F) (Γ : List F) (b : (ψ : F) → ψ ∈ Γ → 𝓢 ⊢! φ ⇒ₗ ψ) : + 𝓢 ⊢! φ ⇒ₗ ⋀Γ := + match Γ with + | [] => CProofOfConseqProof verumProof + | [ψ] => by apply b; simp; + | ψ :: χ :: Γ => by + apply + CKProofOfCProofOfCProof (b ψ (by simp)) + (rightConj₂ProofIntro φ _ (fun ψ hq ↦ b ψ (by simp [hq]))); +lemma right_Conj₂_intro (φ : F) (Γ : List F) (b : (ψ : F) → ψ ∈ Γ → 𝓢 ⊢ φ ⇒ₗ ψ) : 𝓢 ⊢ φ ⇒ₗ ⋀Γ := + ⟨rightConj₂ProofIntro φ Γ (fun ψ hq => (b ψ hq).some)⟩ + +/-- The CConj₂Conj₂! construction in `FFL.Entailment`. -/ +def CConj₂Conj₂Proof [DecidableEq F] {Γ Δ : List F} (h : Δ ⊆ Γ) : 𝓢 ⊢! ⋀Γ ⇒ₗ ⋀Δ := + rightConj₂ProofIntro _ _ (fun _ hq ↦ leftConj₂ProofIntro (h hq)) +lemma CConj₂Conj₂ {Γ Δ : List F} (h : Δ ⊆ Γ) : 𝓢 ⊢ ⋀Γ ⇒ₗ ⋀Δ := by + classical exact ⟨CConj₂Conj₂Proof h⟩ +section + +variable {G T : Type*} [Entailment T G] [LogicalConnective G] [LogicalNeutral G] {𝓣 : T} + +/-- The of Equiv construction in `FFL.Entailment.Minimal`. -/ +abbrev Minimal.ofEquiv (𝓢 : S) [Entailment.Minimal 𝓢] (𝓣 : T) (f : G →ˡᶜ F) + (e : (φ : G) → 𝓢 ⊢! f φ ≃ 𝓣 ⊢! φ) : Entailment.Minimal 𝓣 + where + mdpProof + {φ ψ dpq dp} := + (e ψ) + (let d : 𝓢 ⊢! f φ ⇒ₗ f ψ := by simpa using (e (φ ⇒ₗ ψ)).symm dpq + d⨀((e φ).symm dp)) + negEquivProof := e _ (by simpa using negEquivProof) + verumProof := e _ (by simpa using verumProof) + implyKProof := e _ (by simpa using implyKProof) + implySProof := e _ (by simpa using implySProof) + and₁Proof := e _ (by simpa using and₁Proof) + and₂Proof := e _ (by simpa using and₂Proof) + and₃Proof := e _ (by simpa using and₃Proof) + or₁Proof := e _ (by simpa using or₁Proof) + or₂Proof := e _ (by simpa using or₂Proof) + or₃Proof := e _ (by simpa using or₃Proof) + +end + +end + +section + +/-- Data and laws for Finite Context in `FFL.Entailment`. -/ +structure FiniteContext (F) (𝓢 : S) where + /-- The ctx construction in `FFL.Entailment.FiniteContext`. -/ + ctx : List F + +namespace FiniteContext + +variable {F} {S} {𝓢 : S} + +instance : Coe (List F) (FiniteContext F 𝓢) := + ⟨mk⟩ + +/-- The conj construction in `FFL.Entailment.FiniteContext`. -/ +abbrev conj [LogicalConnective F] [LogicalNeutral F] (Γ : FiniteContext F 𝓢) : F := + ⋀Γ.ctx + +/-- The disj construction in `FFL.Entailment.FiniteContext`. -/ +abbrev disj [LogicalConnective F] [LogicalNeutral F] (Γ : FiniteContext F 𝓢) : F := + ⋁Γ.ctx + +instance : EmptyCollection (FiniteContext F 𝓢) := + ⟨⟨[]⟩⟩ + +instance : Membership F (FiniteContext F 𝓢) := + ⟨fun Γ x => (x ∈ Γ.ctx)⟩ + +instance : HasSubset (FiniteContext F 𝓢) := + ⟨(·.ctx ⊆ ·.ctx)⟩ + +instance : Adjoin F (FiniteContext F 𝓢) := + ⟨(· :: ·.ctx)⟩ + +lemma mem_def {φ : F} {Γ : FiniteContext F 𝓢} : φ ∈ Γ ↔ φ ∈ Γ.ctx := + iff_of_eq rfl + +@[simp] +lemma coe_subset_coe_iff {Γ Δ : List F} : (Γ : FiniteContext F 𝓢) ⊆ Δ ↔ Γ ⊆ Δ := + iff_of_eq rfl + +@[simp] +lemma mem_coe_iff {φ : F} {Γ : List F} : φ ∈ (Γ : FiniteContext F 𝓢) ↔ φ ∈ Γ := + iff_of_eq rfl + +lemma not_mem_empty (φ : F) : ¬φ ∈ (∅ : FiniteContext F 𝓢) := by + simp [EmptyCollection.emptyCollection] + +instance : AdjunctiveSet F (FiniteContext F 𝓢) + where + subset_iff := List.subset_def + not_mem_empty := not_mem_empty + mem_cons_iff := by simp [Adjoin.adjoin, mem_def] + +variable [Entailment S F] [LogicalConnective F] [LogicalNeutral F] + +instance (𝓢 : S) : Entailment (FiniteContext F 𝓢) F := + ⟨(𝓢 ⊢! ·.conj ⇒ₗ ·)⟩ + +/-- The Prf construction in `FFL.Entailment.FiniteContext`. -/ +abbrev Prf (𝓢 : S) (Γ : List F) (φ : F) : Type _ := + (Γ : FiniteContext F 𝓢) ⊢! φ + +/-- The Provable construction in `FFL.Entailment.FiniteContext`. -/ +abbrev Provable (𝓢 : S) (Γ : List F) (φ : F) : Prop := + (Γ : FiniteContext F 𝓢) ⊢ φ + +/-- The Unprovable construction in `FFL.Entailment.FiniteContext`. -/ +abbrev Unprovable (𝓢 : S) (Γ : List F) (φ : F) : Prop := + (Γ : FiniteContext F 𝓢) ⊬ φ + +/-- The Prf Set construction in `FFL.Entailment.FiniteContext`. -/ +abbrev PrfSet (𝓢 : S) (Γ : List F) (s : Set F) : Type _ := + (Γ : FiniteContext F 𝓢) ⊢!* s + +/-- The Provable Set construction in `FFL.Entailment.FiniteContext`. -/ +abbrev ProvableSet (𝓢 : S) (Γ : List F) (s : Set F) : Prop := + (Γ : FiniteContext F 𝓢) ⊢* s + +/-- The «term ⊢[ ]! » construction in `FFL.Entailment.FiniteContext`. -/ +notation Γ:45 " ⊢[" 𝓢 "]! " φ:46 => Prf 𝓢 Γ φ + +/-- The «term ⊢[ ] » construction in `FFL.Entailment.FiniteContext`. -/ +notation Γ:45 " ⊢[" 𝓢 "] " φ:46 => Provable 𝓢 Γ φ + +/-- The «term ⊬[ ] » construction in `FFL.Entailment.FiniteContext`. -/ +notation Γ:45 " ⊬[" 𝓢 "] " φ:46 => Unprovable 𝓢 Γ φ + +/-- The «term ⊢[ ]!* » construction in `FFL.Entailment.FiniteContext`. -/ +notation Γ:45 " ⊢[" 𝓢 "]!* " s:46 => PrfSet 𝓢 Γ s + +/-- The «term ⊢[ ]* » construction in `FFL.Entailment.FiniteContext`. -/ +notation Γ:45 " ⊢[" 𝓢 "]* " s:46 => ProvableSet 𝓢 Γ s + +lemma entailment_def (Γ : FiniteContext F 𝓢) (φ : F) : (Γ ⊢! φ) = (𝓢 ⊢! Γ.conj ⇒ₗ φ) := + rfl + +/-- The of Def! construction in `FFL.Entailment.FiniteContext`. -/ +def ofDefProof {Γ : List F} {φ : F} (b : 𝓢 ⊢! ⋀Γ ⇒ₗ φ) : Γ ⊢[𝓢]! φ := + b + +/-- The to Def! construction in `FFL.Entailment.FiniteContext`. -/ +def toDefProof {Γ : List F} {φ : F} (b : Γ ⊢[𝓢]! φ) : 𝓢 ⊢! ⋀Γ ⇒ₗ φ := + b + +lemma toₛ (b : Γ ⊢[𝓢] φ) : 𝓢 ⊢ ⋀Γ ⇒ₗ φ := + b + +lemma provable_iff {φ : F} : Γ ⊢[𝓢] φ ↔ 𝓢 ⊢ ⋀Γ ⇒ₗ φ := + iff_of_eq rfl + +/-- The cast! construction in `FFL.Entailment.FiniteContext`. -/ +def castProof {Γ φ} (d : Γ ⊢[𝓢]! φ) (eΓ : Γ = Γ') (eφ : φ = φ') : Γ' ⊢[𝓢]! φ' := + eΓ ▸ eφ ▸ d + +section + +variable {Γ Δ E : List F} +variable [Entailment.Minimal 𝓢] + +instance [DecidableEq F] : Axiomatized (FiniteContext F 𝓢) + where + prfAxm := fun hp ↦ leftConj₂ProofIntro hp + weakening := fun H b ↦ CProofTrans (CConj₂Conj₂Proof H) b + +instance : Compact (FiniteContext F 𝓢) + where + core := fun {Γ} _ _ ↦ Γ + corePrf := id + core_subset := by simp + core_finite := by rintro ⟨Γ⟩; simp [AdjunctiveSet.Finite, AdjunctiveSet.set] + +/-- The nth Axm! construction in `FFL.Entailment.FiniteContext`. -/ +def nthAxmProof {Γ} (n : ℕ) (h : n < Γ.length := by simp) : Γ ⊢[𝓢]! Γ[n] := + conj₂NthProof Γ n h +lemma nth_axm {Γ} (n : ℕ) (h : n < Γ.length := by simp) : Γ ⊢[𝓢] Γ[n] := + ⟨nthAxmProof n h⟩ + +/-- The by Axm! construction in `FFL.Entailment.FiniteContext`. -/ +def byAxmProof [DecidableEq F] {φ} (h : φ ∈ Γ := by simp) : Γ ⊢[𝓢]! φ := + Axiomatized.prfAxm (by simpa) + +lemma by_axm {φ} (h : φ ∈ Γ := by classical simp) : Γ ⊢[𝓢] φ := by + classical exact Axiomatized.provable_refl _ (by simpa) + +/-- The weakening! construction in `FFL.Entailment.FiniteContext`. -/ +def weakeningProof [DecidableEq F] (h : Γ ⊆ Δ) {φ} : Γ ⊢[𝓢]! φ → Δ ⊢[𝓢]! φ := + Axiomatized.weakening (by simpa) + +lemma weakening (h : Γ ⊆ Δ) {φ} : Γ ⊢[𝓢] φ → Δ ⊢[𝓢] φ := by + classical exact fun h ↦ (Axiomatized.le_of_subset (by simpa)).subset h +/-- The of! construction in `FFL.Entailment.FiniteContext`. -/ +def ofProof {φ : F} (b : 𝓢 ⊢! φ) : Γ ⊢[𝓢]! φ := + CProofOfConseqProof (ψ := ⋀Γ) b + +/-- The empty Prf! construction in `FFL.Entailment.FiniteContext`. -/ +def emptyPrfProof {φ : F} : [] ⊢[𝓢]! φ → 𝓢 ⊢! φ := fun b ↦ b⨀verumProof + +theorem provable_iff_provable {φ : F} : 𝓢 ⊢ φ ↔ [] ⊢[𝓢] φ := + ⟨fun b ↦ ⟨ofProof b.some⟩, fun b ↦ ⟨emptyPrfProof b.some⟩⟩ + +lemma of' (h : 𝓢 ⊢ φ) : Γ ⊢[𝓢] φ := by + classical exact weakening (by simp) <| provable_iff_provable.mp h +/-- The id! construction in `FFL.Entailment.FiniteContext`. -/ +def idProof : [φ] ⊢[𝓢]! φ := + nthAxmProof 0 +@[simp] +lemma id : [φ] ⊢[𝓢] φ := + nth_axm 0 + +/-- The by Axm₀! construction in `FFL.Entailment.FiniteContext`. -/ +def byAxm₀Proof : (φ :: Γ) ⊢[𝓢]! φ := + nthAxmProof 0 +lemma by_axm₀ : (φ :: Γ) ⊢[𝓢] φ := + nth_axm 0 + +/-- The by Axm₁! construction in `FFL.Entailment.FiniteContext`. -/ +def byAxm₁Proof : (φ :: ψ :: Γ) ⊢[𝓢]! ψ := + nthAxmProof 1 +lemma by_axm₁ : (φ :: ψ :: Γ) ⊢[𝓢] ψ := + nth_axm 1 + +/-- The by Axm₂! construction in `FFL.Entailment.FiniteContext`. -/ +def byAxm₂Proof : (φ :: ψ :: χ :: Γ) ⊢[𝓢]! χ := + nthAxmProof 2 +lemma by_axm₂ : (φ :: ψ :: χ :: Γ) ⊢[𝓢] χ := + nth_axm 2 + +instance (Γ : FiniteContext F 𝓢) : Entailment.ModusPonens Γ := + ⟨mdp₁Proof⟩ + +instance (Γ : FiniteContext F 𝓢) : Entailment.HasAxiomVerum Γ := + ⟨ofProof verumProof⟩ + +instance (Γ : FiniteContext F 𝓢) : Entailment.HasAxiomImplyK Γ := + ⟨ofProof implyKProof⟩ + +instance (Γ : FiniteContext F 𝓢) : Entailment.HasAxiomImplyS Γ := + ⟨ofProof implySProof⟩ + +instance (Γ : FiniteContext F 𝓢) : Entailment.HasAxiomAndElim Γ := + ⟨ofProof and₁Proof, ofProof and₂Proof⟩ + +instance (Γ : FiniteContext F 𝓢) : Entailment.HasAxiomAndInst Γ := + ⟨ofProof and₃Proof⟩ + +instance (Γ : FiniteContext F 𝓢) : Entailment.HasAxiomOrInst Γ := + ⟨ofProof or₁Proof, ofProof or₂Proof⟩ + +instance (Γ : FiniteContext F 𝓢) : Entailment.HasAxiomOrElim Γ := + ⟨ofProof or₃Proof⟩ + +instance (Γ : FiniteContext F 𝓢) : Entailment.NegationEquiv Γ := + ⟨ofProof negEquivProof⟩ + +instance (Γ : FiniteContext F 𝓢) : Entailment.Minimal Γ where + +/-- The mdp'! construction in `FFL.Entailment.FiniteContext`. -/ +def mdp'Proof [DecidableEq F] (bΓ : Γ ⊢[𝓢]! φ ⇒ₗ ψ) (bΔ : Δ ⊢[𝓢]! φ) : (Γ ++ Δ) ⊢[𝓢]! ψ := + wk (by simp) bΓ⨀wk (by simp) bΔ + +/-- The deduct! construction in `FFL.Entailment.FiniteContext`. -/ +def deductProof {φ ψ : F} : {Γ : List F} → (φ :: Γ) ⊢[𝓢]! ψ → Γ ⊢[𝓢]! φ ⇒ₗ ψ + | .nil => fun b ↦ ofDefProof <| CProofOfConseqProof (toDefProof b) + | .cons _ _ => fun b ↦ ofDefProof <| CCProofOfCKProof (CProofTrans CKKProof (toDefProof b)) + +lemma deduct (h : (φ :: Γ) ⊢[𝓢] ψ) : Γ ⊢[𝓢] φ ⇒ₗ ψ := + ⟨FiniteContext.deductProof h.some⟩ + +/-- The deduct Inv! construction in `FFL.Entailment.FiniteContext`. -/ +def deductInvProof {φ ψ : F} : {Γ : List F} → Γ ⊢[𝓢]! φ ⇒ₗ ψ → (φ :: Γ) ⊢[𝓢]! ψ + | .nil => fun b => ofDefProof <| (toDefProof b)⨀verumProof + | .cons _ _ => fun b => ofDefProof <| (CProofTrans CKKProof (CKProofOfCCProof (toDefProof b))) + +lemma deductInv (h : Γ ⊢[𝓢] φ ⇒ₗ ψ) : (φ :: Γ) ⊢[𝓢] ψ := + ⟨FiniteContext.deductInvProof h.some⟩ + +lemma deduct_iff {φ ψ : F} {Γ : List F} : Γ ⊢[𝓢] φ ⇒ₗ ψ ↔ (φ :: Γ) ⊢[𝓢] ψ := + ⟨fun h ↦ ⟨deductInvProof h.some⟩, fun h ↦ ⟨deductProof h.some⟩⟩ + +/-- The deduct'! construction in `FFL.Entailment.FiniteContext`. -/ +def deduct'Proof : [φ] ⊢[𝓢]! ψ → 𝓢 ⊢! φ ⇒ₗ ψ := fun b ↦ emptyPrfProof <| deductProof b + +lemma deduct' (h : [φ] ⊢[𝓢] ψ) : 𝓢 ⊢ φ ⇒ₗ ψ := + ⟨FiniteContext.deduct'Proof h.some⟩ + +/-- The deduct Inv'! construction in `FFL.Entailment.FiniteContext`. -/ +def deductInv'Proof : 𝓢 ⊢! φ ⇒ₗ ψ → [φ] ⊢[𝓢]! ψ := fun b ↦ deductInvProof <| ofProof b + +lemma deductInv' (h : 𝓢 ⊢ φ ⇒ₗ ψ) : [φ] ⊢[𝓢] ψ := + ⟨FiniteContext.deductInv'Proof h.some⟩ + +instance deduction : Deduction (FiniteContext F 𝓢) + where + ofInsert := deductProof + inv := deductInvProof + +instance : StrongCut (FiniteContext F 𝓢) (FiniteContext F 𝓢) := + ⟨fun {Γ Δ _} bΓ bΔ ↦ + have : Γ ⊢! Δ.conj := Conj₂ProofIntro _ (fun _ hp ↦ bΓ hp) + ofDefProof <| CProofTrans (toDefProof this) (toDefProof bΔ)⟩ + +end + +end FiniteContext + +variable (F) + +/-- Data and laws for Context in `FFL.Entailment`. -/ +structure Context (𝓢 : S) where + /-- The ctx construction in `FFL.Entailment.Context`. -/ + ctx : Set F + +variable {F} + +namespace Context + +variable {𝓢 : S} + +instance : Coe (Set F) (Context F 𝓢) := + ⟨mk⟩ + +instance : EmptyCollection (Context F 𝓢) := + ⟨⟨∅⟩⟩ + +instance : Membership F (Context F 𝓢) := + ⟨fun Γ x => (x ∈ Γ.ctx)⟩ + +instance : HasSubset (Context F 𝓢) := + ⟨(·.ctx ⊆ ·.ctx)⟩ + +instance : Adjoin F (Context F 𝓢) := + ⟨(⟨insert · ·.ctx⟩)⟩ + +lemma mem_def {φ : F} {Γ : Context F 𝓢} : φ ∈ Γ ↔ φ ∈ Γ.ctx := + iff_of_eq rfl + +@[simp] +lemma coe_subset_coe_iff {Γ Δ : Set F} : (Γ : Context F 𝓢) ⊆ Δ ↔ Γ ⊆ Δ := + iff_of_eq rfl + +@[simp] +lemma mem_coe_iff {φ : F} {Γ : Set F} : φ ∈ (Γ : Context F 𝓢) ↔ φ ∈ Γ := + iff_of_eq rfl + +lemma not_mem_empty (φ : F) : ¬φ ∈ (∅ : Context F 𝓢) := by exact fun a ↦ a + +instance : AdjunctiveSet F (Context F 𝓢) + where + subset_iff := by rintro ⟨s⟩ ⟨u⟩; simp [Set.subset_def] + not_mem_empty := not_mem_empty + mem_cons_iff := by simp [Adjoin.adjoin, mem_def] + +variable [LogicalConnective F] [LogicalNeutral F] [Entailment S F] + +/-- Data and laws for Proof in `FFL.Entailment.Context`. -/ +structure Proof (Γ : Context F 𝓢) (φ : F) where + /-- The ctx construction in `FFL.Entailment.Context.Proof`. -/ + ctx : List F + subset : ∀ ψ ∈ ctx, ψ ∈ Γ + /-- The prf construction in `FFL.Entailment.Context.Proof`. -/ + prf : ctx ⊢[𝓢]! φ + +instance (𝓢 : S) : Entailment (Context F 𝓢) F := + ⟨Proof⟩ + +variable (𝓢) + +/-- The Prf construction in `FFL.Entailment.Context`. -/ +abbrev Prf (Γ : Set F) (φ : F) : Type _ := + (Γ : Context F 𝓢) ⊢! φ + +/-- The Provable construction in `FFL.Entailment.Context`. -/ +abbrev Provable (Γ : Set F) (φ : F) : Prop := + (Γ : Context F 𝓢) ⊢ φ + +/-- The Unprovable construction in `FFL.Entailment.Context`. -/ +abbrev Unprovable (Γ : Set F) (φ : F) : Prop := + (Γ : Context F 𝓢) ⊬ φ + +/-- The Prf Set construction in `FFL.Entailment.Context`. -/ +abbrev PrfSet (Γ : Set F) (s : Set F) : Type _ := + (Γ : Context F 𝓢) ⊢!* s + +/-- The Provable Set construction in `FFL.Entailment.Context`. -/ +abbrev ProvableSet (Γ : Set F) (s : Set F) : Prop := + (Γ : Context F 𝓢) ⊢* s + +/-- The «term *⊢[ ]! » construction in `FFL.Entailment.Context`. -/ +notation Γ:45 " *⊢[" 𝓢 "]! " φ:46 => Prf 𝓢 Γ φ + +/-- The «term *⊢[ ] » construction in `FFL.Entailment.Context`. -/ +notation Γ:45 " *⊢[" 𝓢 "] " φ:46 => Provable 𝓢 Γ φ + +/-- The «term *⊬[ ] » construction in `FFL.Entailment.Context`. -/ +notation Γ:45 " *⊬[" 𝓢 "] " φ:46 => Unprovable 𝓢 Γ φ + +/-- The «term *⊢[ ]!* » construction in `FFL.Entailment.Context`. -/ +notation Γ:45 " *⊢[" 𝓢 "]!* " s:46 => PrfSet 𝓢 Γ s + +/-- The «term *⊢[ ]* » construction in `FFL.Entailment.Context`. -/ +notation Γ:45 " *⊢[" 𝓢 "]* " s:46 => ProvableSet 𝓢 Γ s + +section + +variable {𝓢} + +lemma provable_iff {φ : F} : Γ *⊢[𝓢] φ ↔ ∃ Δ : List F, (∀ ψ ∈ Δ, ψ ∈ Γ) ∧ Δ ⊢[𝓢] φ := + ⟨by rintro ⟨⟨Δ, h, b⟩⟩; exact ⟨Δ, h, ⟨b⟩⟩, by rintro ⟨Δ, h, ⟨d⟩⟩; exact ⟨⟨Δ, h, d⟩⟩⟩ + +section minimal + +variable [Entailment.Minimal 𝓢] + +instance [DecidableEq F] : Axiomatized (Context F 𝓢) + where + prfAxm := fun {Γ φ} hp ↦ ⟨[φ], by simpa using hp, byAxm (by simp)⟩ + weakening := fun h b ↦ + ⟨b.ctx, fun φ hp ↦ AdjunctiveSet.subset_iff.mp h φ (b.subset φ hp), b.prf⟩ + +/-- The by Axm! construction in `FFL.Entailment.Context`. -/ +def byAxmProof [DecidableEq F] {Γ : Set F} {φ : F} (h : φ ∈ Γ) : Γ *⊢[𝓢]! φ := + Axiomatized.prfAxm (by simpa) + +instance : Compact (Context F 𝓢) where + core := fun b ↦ AdjunctiveSet.set b.ctx + corePrf := fun b ↦ ⟨b.ctx, by simp [AdjunctiveSet.set], b.prf⟩ + core_subset := by rintro ⟨Γ⟩ φ b; exact b.subset + core_finite := by rintro ⟨Γ⟩; simp [AdjunctiveSet.Finite, AdjunctiveSet.set] + +-- lemma provable_iff' [DecidableEq F] {φ : F} : Γ *⊢[𝓢] φ ↔ ∃ Δ : Finset F, (↑Δ ⊆ Γ) ∧ Δ *⊢[𝓢] φ + +/-- The deduct! construction in `FFL.Entailment.Context`. -/ +def deductProof [DecidableEq F] {φ ψ : F} {Γ : Set F} : (insert φ Γ) *⊢[𝓢]! ψ → Γ *⊢[𝓢]! φ ⇒ₗ ψ + | ⟨Δ, h, b⟩ => + have h : ∀ ψ ∈ Δ, ψ = φ ∨ ψ ∈ Γ := by simpa using h + let b' : (φ :: Δ.filter (· ≠ φ)) ⊢[𝓢]! ψ := + FiniteContext.weakeningProof (by simp [List.subset_def, List.mem_filter]; grind) b + ⟨Δ.filter (· ≠ φ), by + intro ψ + suffices ψ ∈ Δ → ψ ≠ φ → ψ ∈ Γ by simpa [List.mem_filter] + intro hq ne + rcases h ψ hq + · contradiction + · assumption, FiniteContext.deductProof b'⟩ +lemma deduct (h : (insert φ Γ) *⊢[𝓢] ψ) : Γ *⊢[𝓢] φ ⇒ₗ ψ := by + classical exact ⟨Context.deductProof h.some⟩ +/-- The deduct Inv! construction in `FFL.Entailment.Context`. -/ +def deductInvProof {φ ψ : F} {Γ : Set F} : Γ *⊢[𝓢]! φ ⇒ₗ ψ → (insert φ Γ) *⊢[𝓢]! ψ + | ⟨Δ, h, b⟩ => + ⟨φ :: Δ, by simpa using fun χ hr ↦ Or.inr (h χ hr), FiniteContext.deductInvProof b⟩ +lemma deductInv (h : Γ *⊢[𝓢] φ ⇒ₗ ψ) : (insert φ Γ) *⊢[𝓢] ψ := by + classical exact ⟨Context.deductInvProof h.some⟩ +instance deduction [DecidableEq F] : Deduction (Context F 𝓢) + where + ofInsert := deductProof + inv := deductInvProof + +/-- The weakening! construction in `FFL.Entailment.Context`. -/ +def weakeningProof [DecidableEq F] (h : Γ ⊆ Δ) {φ : F} : Γ *⊢[𝓢]! φ → Δ *⊢[𝓢]! φ := + Axiomatized.weakening (by simpa) +lemma weakening (h : Γ ⊆ Δ) {φ : F} : Γ *⊢[𝓢] φ → Δ *⊢[𝓢] φ := by + classical exact fun h ↦ (Axiomatized.le_of_subset (by simpa)).subset h +/-- The of! construction in `FFL.Entailment.Context`. -/ +def ofProof {φ : F} (b : 𝓢 ⊢! φ) : Γ *⊢[𝓢]! φ := + ⟨[], by simp, FiniteContext.ofProof b⟩ + +lemma of (b : 𝓢 ⊢ φ) : Γ *⊢[𝓢] φ := + ⟨Context.ofProof b.some⟩ + +/-- The mdp! construction in `FFL.Entailment.Context`. -/ +def mdpProof [DecidableEq F] {Γ : Set F} (bpq : Γ *⊢[𝓢]! φ ⇒ₗ ψ) (bp : Γ *⊢[𝓢]! φ) : + Γ *⊢[𝓢]! ψ := + ⟨bpq.ctx ++ bp.ctx, by + simp only [List.mem_append, mem_coe_iff] + rintro χ (hr | hr) + · exact bpq.subset χ hr + · exact bp.subset χ hr, FiniteContext.mdp'Proof bpq.prf bp.prf⟩ + +lemma by_axm (h : φ ∈ Γ) : Γ *⊢[𝓢] φ := by classical exact Entailment.by_axm (by simpa) +/-- The empty Prf! construction in `FFL.Entailment.Context`. -/ +def emptyPrfProof {φ : F} : ∅ *⊢[𝓢]! φ → 𝓢 ⊢! φ := by + rintro ⟨Γ, hΓ, h⟩; + have := List.eq_nil_iff_forall_not_mem.mpr hΓ; + subst this; + exact FiniteContext.emptyPrfProof h; + +lemma emptyPrf {φ : F} : ∅ *⊢[𝓢] φ → 𝓢 ⊢ φ := fun h ↦ ⟨emptyPrfProof h.some⟩ + +lemma provable_iff_provable {φ : F} : 𝓢 ⊢ φ ↔ ∅ *⊢[𝓢] φ := + ⟨of, emptyPrf⟩ + +lemma iff_provable_context_provable_finiteContext_toList {Δ : Finset F} : + ↑Δ *⊢[𝓢] φ ↔ Δ.toList ⊢[𝓢] φ := by + classical + constructor; + · intro h; obtain ⟨Γ, hΓ₁, hΓ₂⟩ := Context.provable_iff.mp h; + apply FiniteContext.weakening ?_ hΓ₂; intro ψ hψ; simpa using hΓ₁ ψ hψ; + · intro h; apply Context.provable_iff.mpr; use Δ.toList; constructor; + · simp only [Finset.mem_toList, SetLike.mem_coe]; tauto; + · assumption; + +instance minimal [DecidableEq F] (Γ : Context F 𝓢) : Entailment.Minimal Γ + where + mdpProof := mdpProof + verumProof := ofProof verumProof + implyKProof := ofProof implyKProof + implySProof := ofProof implySProof + and₁Proof := ofProof and₁Proof + and₂Proof := ofProof and₂Proof + and₃Proof := ofProof and₃Proof + or₁Proof := ofProof or₁Proof + or₂Proof := ofProof or₂Proof + or₃Proof := ofProof or₃Proof + negEquivProof := ofProof negEquivProof + +end minimal + +end + +end Context + +end + +section + +variable {F : Type*} [LogicalConnective F] [LogicalNeutral F] {S : Type*} [Entailment S F] + {𝓢 : S} [Entailment.Minimal 𝓢] {φ φ₁ φ₂ ψ ψ₁ ψ₂ χ ξ : F} {Γ Δ : List F} + +open NegationEquiv +open FiniteContext +open _root_.List List + +@[simp] +lemma CVNO : 𝓢 ⊢ ⊤ ⇒ₗ ∼⊥ := + deduct' NO + +/-- The inner MDP! construction in `FFL.Entailment`. -/ +def innerMDPProof [DecidableEq F] : 𝓢 ⊢! φ ⋏ (φ ⇒ₗ ψ) ⇒ₗ ψ := by + apply deduct'Proof; + have hp : [φ, φ ⇒ₗ ψ] ⊢[𝓢]! φ := FiniteContext.byAxmProof; + have hpq : [φ, φ ⇒ₗ ψ] ⊢[𝓢]! φ ⇒ₗ ψ := FiniteContext.byAxmProof; + exact hpq ⨀ hp; +lemma inner_mdp : 𝓢 ⊢ φ ⋏ (φ ⇒ₗ ψ) ⇒ₗ ψ := by classical exact ⟨innerMDPProof⟩ +/-- The bot of mem either! construction in `FFL.Entailment`. -/ +def botOfMemEitherProof [DecidableEq F] (h₁ : φ ∈ Γ) (h₂ : ∼φ ∈ Γ) : Γ ⊢[𝓢]! ⊥ := by + have hp : Γ ⊢[𝓢]! φ := FiniteContext.byAxmProof h₁; + have hnp : Γ ⊢[𝓢]! φ ⇒ₗ ⊥ := COProofOfNProof <| FiniteContext.byAxmProof h₂; exact hnp⨀hp +lemma bot_of_mem_either (h₁ : φ ∈ Γ) (h₂ : ∼φ ∈ Γ) : Γ ⊢[𝓢] ⊥ := by + classical exact ⟨botOfMemEitherProof h₁ h₂⟩ +/-- The neg MDP! construction in `FFL.Entailment`. -/ +def negMDPProof (hnp : 𝓢 ⊢! ∼φ) (hn : 𝓢 ⊢! φ) : 𝓢 ⊢! ⊥ := + (COProofOfNProof hnp)⨀hn +lemma neg_mdp (hnp : 𝓢 ⊢ ∼φ) (hn : 𝓢 ⊢ φ) : 𝓢 ⊢ ⊥ := + ⟨negMDPProof hnp.some hn.some⟩ + +/-- The right A! intro left construction in `FFL.Entailment`. -/ +def rightAProofIntroLeft (h : 𝓢 ⊢! φ ⇒ₗ χ) : 𝓢 ⊢! φ ⇒ₗ (χ ⋎ ψ) := by + apply deduct'Proof; + apply AProofIntroLeft; + apply deductInvProof; + exact ofProof h; +lemma right_A_intro_left (h : 𝓢 ⊢ φ ⇒ₗ χ) : 𝓢 ⊢ φ ⇒ₗ (χ ⋎ ψ) := + ⟨rightAProofIntroLeft h.some⟩ + +/-- The right A! intro right construction in `FFL.Entailment`. -/ +def rightAProofIntroRight (h : 𝓢 ⊢! ψ ⇒ₗ χ) : 𝓢 ⊢! ψ ⇒ₗ (φ ⋎ χ) := by + apply deduct'Proof; + apply AProofIntroRight; + apply deductInvProof; + exact ofProof h; +lemma right_A_intro_right (h : 𝓢 ⊢ ψ ⇒ₗ χ) : 𝓢 ⊢ ψ ⇒ₗ (φ ⋎ χ) := + ⟨rightAProofIntroRight h.some⟩ + +/-- The right K! intro construction in `FFL.Entailment`. -/ +def rightKProofIntro [DecidableEq F] (hq : 𝓢 ⊢! φ ⇒ₗ ψ) (hr : 𝓢 ⊢! φ ⇒ₗ χ) : 𝓢 ⊢! φ ⇒ₗ ψ ⋏ χ := by + apply deduct'Proof; + replace hq : [] ⊢[𝓢]! φ ⇒ₗ ψ := ofProof hq; + replace hr : [] ⊢[𝓢]! φ ⇒ₗ χ := ofProof hr; + exact KProofIntro (mdp'Proof hq FiniteContext.idProof) (mdp'Proof hr FiniteContext.idProof) +lemma right_K_intro (hq : 𝓢 ⊢ φ ⇒ₗ ψ) (hr : 𝓢 ⊢ φ ⇒ₗ χ) : 𝓢 ⊢ φ ⇒ₗ ψ ⋏ χ := by + classical exact ⟨rightKProofIntro hq.some hr.some⟩ +lemma left_K_symm (d : 𝓢 ⊢ φ ⋏ ψ ⇒ₗ χ) : 𝓢 ⊢ ψ ⋏ φ ⇒ₗ χ := + C_trans CKK d + +lemma left_K_intro_right (h : 𝓢 ⊢ φ ⇒ₗ χ) : 𝓢 ⊢ (ψ ⋏ φ) ⇒ₗ χ := by + classical apply CK_iff_CC.mpr; apply deduct'; exact FiniteContext.of' (Γ := [ψ]) h; + +lemma left_K_intro_left (h : 𝓢 ⊢ φ ⇒ₗ χ) : 𝓢 ⊢ (φ ⋏ ψ) ⇒ₗ χ := by + classical exact C_trans CKK (left_K_intro_right h) +lemma cut (d₁ : 𝓢 ⊢ φ₁ ⋏ c ⇒ₗ ψ₁) (d₂ : 𝓢 ⊢ φ₂ ⇒ₗ c ⋎ ψ₂) : 𝓢 ⊢ φ₁ ⋏ φ₂ ⇒ₗ ψ₁ ⋎ ψ₂ := by + classical + apply deduct'; + exact of_C_of_C_of_A (right_A_intro_left <| of' (CK_iff_CC.mp d₁) ⨀ (K_left id)) or₂ (of' d₂ ⨀ + K_right id); + + + +/-- The CAA! construction in `FFL.Entailment`. -/ +def CAAProof : 𝓢 ⊢! φ ⋎ ψ ⇒ₗ ψ ⋎ φ := by + apply deduct'Proof; + exact ofCProofOfCProofOfAProof or₂Proof or₁Proof <| FiniteContext.idProof +lemma CAA : 𝓢 ⊢ φ ⋎ ψ ⇒ₗ ψ ⋎ φ := + ⟨CAAProof⟩ + +/-- The A! symm construction in `FFL.Entailment`. -/ +def AProofSymm (h : 𝓢 ⊢! φ ⋎ ψ) : 𝓢 ⊢! ψ ⋎ φ := + CAAProof⨀h +lemma A_symm (h : 𝓢 ⊢ φ ⋎ ψ) : 𝓢 ⊢ ψ ⋎ φ := + ⟨AProofSymm h.some⟩ + +lemma A_assoc : 𝓢 ⊢ φ ⋎ (ψ ⋎ χ) ↔ 𝓢 ⊢ (φ ⋎ ψ) ⋎ χ := by + constructor; + · intro h; + exact of_C_of_C_of_A + (right_A_intro_left <| right_A_intro_left C_id) + (by + apply provable_iff_provable.mpr; + apply deduct_iff.mpr; + exact of_C_of_C_of_A (right_A_intro_left <| right_A_intro_right C_id) + (right_A_intro_right C_id) id; + ) + h; + · intro h; + exact of_C_of_C_of_A + (by + apply provable_iff_provable.mpr; + apply deduct_iff.mpr; + exact of_C_of_C_of_A (right_A_intro_left C_id) (right_A_intro_right <| + right_A_intro_left C_id) id; + ) + (right_A_intro_right <| right_A_intro_right C_id) + h; + + + +lemma K_assoc : 𝓢 ⊢ (φ ⋏ ψ) ⋏ χ ⇔ₗ φ ⋏ (ψ ⋏ χ) := + by + apply E_intro; + · apply FiniteContext.deduct'; have hp : [(φ ⋏ ψ) ⋏ χ] ⊢[𝓢] φ := K_left <| K_left id; + have hq : [(φ ⋏ ψ) ⋏ χ] ⊢[𝓢] ψ := K_right <| K_left id; + have hr : [(φ ⋏ ψ) ⋏ χ] ⊢[𝓢] χ := K_right id; exact K_intro hp (K_intro hq hr); + · apply FiniteContext.deduct'; have hp : [φ ⋏ (ψ ⋏ χ)] ⊢[𝓢] φ := K_left id; + have hq : [φ ⋏ (ψ ⋏ χ)] ⊢[𝓢] ψ := K_left <| K_right id; + have hr : [φ ⋏ (ψ ⋏ χ)] ⊢[𝓢] χ := K_right <| K_right id; apply K_intro; + · exact K_intro hp hq; + · exact hr; + +lemma K_assoc_mp (h : 𝓢 ⊢ (φ ⋏ ψ) ⋏ χ) : 𝓢 ⊢ φ ⋏ (ψ ⋏ χ) := + C_of_E_mp K_assoc⨀h +lemma K_assoc_mpr (h : 𝓢 ⊢ φ ⋏ (ψ ⋏ χ)) : 𝓢 ⊢ (φ ⋏ ψ) ⋏ χ := + C_of_E_mpr K_assoc⨀h + +/-- The K! replace left construction in `FFL.Entailment`. -/ +def KProofReplaceLeft (hc : 𝓢 ⊢! φ ⋏ ψ) (h : 𝓢 ⊢! φ ⇒ₗ χ) : 𝓢 ⊢! χ ⋏ ψ := + KProofIntro (h⨀KProofLeft hc) (KProofRight hc) +lemma K_replace_left (hc : 𝓢 ⊢ φ ⋏ ψ) (h : 𝓢 ⊢ φ ⇒ₗ χ) : 𝓢 ⊢ χ ⋏ ψ := + ⟨KProofReplaceLeft hc.some h.some⟩ + +/-- The CKK! of C! construction in `FFL.Entailment`. -/ +def CKKProofOfCProof (h : 𝓢 ⊢! φ ⇒ₗ χ) : 𝓢 ⊢! φ ⋏ ψ ⇒ₗ χ ⋏ ψ := by + apply deduct'Proof; + exact KProofReplaceLeft FiniteContext.idProof (ofProof h) +lemma CKK_of_C (h : 𝓢 ⊢ φ ⇒ₗ χ) : 𝓢 ⊢ φ ⋏ ψ ⇒ₗ χ ⋏ ψ := + ⟨CKKProofOfCProof h.some⟩ + +/-- The K! replace right construction in `FFL.Entailment`. -/ +def KProofReplaceRight (hc : 𝓢 ⊢! φ ⋏ ψ) (h : 𝓢 ⊢! ψ ⇒ₗ χ) : 𝓢 ⊢! φ ⋏ χ := + KProofIntro (KProofLeft hc) (h⨀KProofRight hc) +lemma K_replace_right (hc : 𝓢 ⊢ φ ⋏ ψ) (h : 𝓢 ⊢ ψ ⇒ₗ χ) : 𝓢 ⊢ φ ⋏ χ := + ⟨KProofReplaceRight hc.some h.some⟩ + +/-- The CKK! of C!' construction in `FFL.Entailment`. -/ +def CKKProofOfCProof' (h : 𝓢 ⊢! ψ ⇒ₗ χ) : 𝓢 ⊢! φ ⋏ ψ ⇒ₗ φ ⋏ χ := by + apply deduct'Proof; + exact KProofReplaceRight (FiniteContext.idProof) (ofProof h) +lemma CKK_of_C' (h : 𝓢 ⊢ ψ ⇒ₗ χ) : 𝓢 ⊢ φ ⋏ ψ ⇒ₗ φ ⋏ χ := + ⟨CKKProofOfCProof' h.some⟩ + +/-- The K! replace construction in `FFL.Entailment`. -/ +def KProofReplace (hc : 𝓢 ⊢! φ ⋏ ψ) (h₁ : 𝓢 ⊢! φ ⇒ₗ χ) (h₂ : 𝓢 ⊢! ψ ⇒ₗ ξ) : 𝓢 ⊢! χ ⋏ ξ := + KProofReplaceRight (KProofReplaceLeft hc h₁) h₂ +lemma K_replace (hc : 𝓢 ⊢ φ ⋏ ψ) (h₁ : 𝓢 ⊢ φ ⇒ₗ χ) (h₂ : 𝓢 ⊢ ψ ⇒ₗ ξ) : 𝓢 ⊢ χ ⋏ ξ := + ⟨KProofReplace hc.some h₁.some h₂.some⟩ + +/-- The CKK! of C! of C! construction in `FFL.Entailment`. -/ +def CKKProofOfCProofOfCProof (h₁ : 𝓢 ⊢! φ ⇒ₗ χ) (h₂ : 𝓢 ⊢! ψ ⇒ₗ ξ) : 𝓢 ⊢! φ ⋏ ψ ⇒ₗ χ ⋏ ξ := by + apply deduct'Proof; exact KProofReplace FiniteContext.idProof (ofProof h₁) (ofProof h₂) +lemma CKK_of_C_of_C (h₁ : 𝓢 ⊢ φ ⇒ₗ χ) (h₂ : 𝓢 ⊢ ψ ⇒ₗ ξ) : 𝓢 ⊢ φ ⋏ ψ ⇒ₗ χ ⋏ ξ := + ⟨CKKProofOfCProofOfCProof h₁.some h₂.some⟩ + +/-- The A! replace left construction in `FFL.Entailment`. -/ +def AProofReplaceLeft (hc : 𝓢 ⊢! φ ⋎ ψ) (hp : 𝓢 ⊢! φ ⇒ₗ χ) : 𝓢 ⊢! χ ⋎ ψ := + ofCProofOfCProofOfAProof (CProofTrans hp or₁Proof) (or₂Proof) hc +lemma A_replace_left (hc : 𝓢 ⊢ φ ⋎ ψ) (hp : 𝓢 ⊢ φ ⇒ₗ χ) : 𝓢 ⊢ χ ⋎ ψ := + ⟨AProofReplaceLeft hc.some hp.some⟩ + +/-- The CAA! of C! left construction in `FFL.Entailment`. -/ +def CAAProofOfCProofLeft (hp : 𝓢 ⊢! φ ⇒ₗ χ) : 𝓢 ⊢! φ ⋎ ψ ⇒ₗ χ ⋎ ψ := by + apply deduct'Proof; + exact AProofReplaceLeft FiniteContext.idProof (ofProof hp) +lemma CAA_of_C_left (hp : 𝓢 ⊢ φ ⇒ₗ χ) : 𝓢 ⊢ φ ⋎ ψ ⇒ₗ χ ⋎ ψ := + ⟨CAAProofOfCProofLeft hp.some⟩ + +/-- The A! replace right construction in `FFL.Entailment`. -/ +def AProofReplaceRight (hc : 𝓢 ⊢! φ ⋎ ψ) (hq : 𝓢 ⊢! ψ ⇒ₗ χ) : 𝓢 ⊢! φ ⋎ χ := + ofCProofOfCProofOfAProof (or₁Proof) (CProofTrans hq or₂Proof) hc +lemma A_replace_right (hc : 𝓢 ⊢ φ ⋎ ψ) (hq : 𝓢 ⊢ ψ ⇒ₗ χ) : 𝓢 ⊢ φ ⋎ χ := + ⟨AProofReplaceRight hc.some hq.some⟩ + +/-- The CAA! of C! right construction in `FFL.Entailment`. -/ +def CAAProofOfCProofRight (hq : 𝓢 ⊢! ψ ⇒ₗ χ) : 𝓢 ⊢! φ ⋎ ψ ⇒ₗ φ ⋎ χ := by + apply deduct'Proof; + exact AProofReplaceRight FiniteContext.idProof (ofProof hq) +lemma CAA_of_C_right (hq : 𝓢 ⊢ ψ ⇒ₗ χ) : 𝓢 ⊢ φ ⋎ ψ ⇒ₗ φ ⋎ χ := + ⟨CAAProofOfCProofRight hq.some⟩ + +/-- The A! replace construction in `FFL.Entailment`. -/ +def AProofReplace (h : 𝓢 ⊢! φ₁ ⋎ ψ₁) (hp : 𝓢 ⊢! φ₁ ⇒ₗ φ₂) (hq : 𝓢 ⊢! ψ₁ ⇒ₗ ψ₂) : 𝓢 ⊢! φ₂ ⋎ ψ₂ := + AProofReplaceRight (AProofReplaceLeft h hp) hq +lemma A_replace (h : 𝓢 ⊢ φ₁ ⋎ ψ₁) (hp : 𝓢 ⊢ φ₁ ⇒ₗ φ₂) (hq : 𝓢 ⊢ ψ₁ ⇒ₗ ψ₂) : 𝓢 ⊢ φ₂ ⋎ ψ₂ := + ⟨AProofReplace h.some hp.some hq.some⟩ + +/-- The CAA! of C! of C! construction in `FFL.Entailment`. -/ +def CAAProofOfCProofOfCProof (hp : 𝓢 ⊢! φ₁ ⇒ₗ φ₂) (hq : 𝓢 ⊢! ψ₁ ⇒ₗ ψ₂) : 𝓢 ⊢! φ₁ ⋎ ψ₁ ⇒ₗ φ₂ ⋎ ψ₂ + := by + apply deduct'Proof; + exact AProofReplace FiniteContext.idProof (ofProof hp) (ofProof hq); + +lemma CAA_of_C_of_C (hp : 𝓢 ⊢ φ₁ ⇒ₗ φ₂) (hq : 𝓢 ⊢ ψ₁ ⇒ₗ ψ₂) : 𝓢 ⊢ φ₁ ⋎ ψ₁ ⇒ₗ φ₂ ⋎ ψ₂ := + ⟨CAAProofOfCProofOfCProof hp.some hq.some⟩ + +/-- The EAA! of E! of E! construction in `FFL.Entailment`. -/ +def EAAProofOfEProofOfEProof (hp : 𝓢 ⊢! φ₁ ⇔ₗ φ₂) (hq : 𝓢 ⊢! ψ₁ ⇔ₗ ψ₂) : + 𝓢 ⊢! φ₁ ⋎ ψ₁ ⇔ₗ φ₂ ⋎ ψ₂ := by + apply EProofIntro; · exact CAAProofOfCProofOfCProof (KProofLeft hp) (KProofLeft hq); + · exact CAAProofOfCProofOfCProof (KProofRight hp) (KProofRight hq); +lemma EAA_of_E_of_E (hp : 𝓢 ⊢ φ₁ ⇔ₗ φ₂) (hq : 𝓢 ⊢ ψ₁ ⇔ₗ ψ₂) : 𝓢 ⊢ φ₁ ⋎ ψ₁ ⇔ₗ φ₂ ⋎ ψ₂ := + ⟨EAAProofOfEProofOfEProof hp.some hq.some⟩ + +lemma EAAAA : 𝓢 ⊢ φ ⋎ (ψ ⋎ χ) ⇔ₗ (φ ⋎ ψ) ⋎ χ := + by + apply E_intro; · exact deduct' <| A_assoc.mp id; + · exact deduct' <| A_assoc.mpr id; + +lemma EAA_of_E_right (d : 𝓢 ⊢ ψ ⇔ₗ χ) : 𝓢 ⊢ φ ⋎ ψ ⇔ₗ φ ⋎ χ := + by + apply E_intro; · apply CAA_of_C_right; exact K_left d; + · apply CAA_of_C_right; exact K_right d; + +lemma EAA_of_E_left (d : 𝓢 ⊢ φ ⇔ₗ χ) : 𝓢 ⊢ φ ⋎ ψ ⇔ₗ χ ⋎ ψ := + by + apply E_intro; · apply CAA_of_C_left; exact K_left d; + · apply CAA_of_C_left; exact K_right d; + +/-- The EKK! of E! of E! construction in `FFL.Entailment`. -/ +def EKKProofOfEProofOfEProof (hp : 𝓢 ⊢! φ₁ ⇔ₗ φ₂) (hq : 𝓢 ⊢! ψ₁ ⇔ₗ ψ₂) : + 𝓢 ⊢! φ₁ ⋏ ψ₁ ⇔ₗ φ₂ ⋏ ψ₂ := by + apply EProofIntro; · exact CKKProofOfCProofOfCProof (KProofLeft hp) (KProofLeft hq); + · exact CKKProofOfCProofOfCProof (KProofRight hp) (KProofRight hq); +lemma EKK_of_E_of_E (hp : 𝓢 ⊢ φ₁ ⇔ₗ φ₂) (hq : 𝓢 ⊢ ψ₁ ⇔ₗ ψ₂) : 𝓢 ⊢ φ₁ ⋏ ψ₁ ⇔ₗ φ₂ ⋏ ψ₂ := + ⟨EKKProofOfEProofOfEProof hp.some hq.some⟩ + +/-- The ECC! of E! of E! construction in `FFL.Entailment`. -/ +def ECCProofOfEProofOfEProof (hp : 𝓢 ⊢! φ₁ ⇔ₗ φ₂) (hq : 𝓢 ⊢! ψ₁ ⇔ₗ ψ₂) : + 𝓢 ⊢! (φ₁ ⇒ₗ ψ₁) ⇔ₗ (φ₂ ⇒ₗ ψ₂) := by + apply EProofIntro; + · apply deduct'Proof; + exact + CProofTrans (ofProof <| KProofRight hp) <| + CProofTrans (FiniteContext.idProof) (ofProof <| KProofLeft hq); + · apply deduct'Proof; + exact + CProofTrans (ofProof <| KProofLeft hp) <| + CProofTrans (FiniteContext.idProof) (ofProof <| KProofRight hq); +lemma ECC_of_E_of_E (hp : 𝓢 ⊢ φ₁ ⇔ₗ φ₂) (hq : 𝓢 ⊢ ψ₁ ⇔ₗ ψ₂) : 𝓢 ⊢ (φ₁ ⇒ₗ ψ₁) ⇔ₗ (φ₂ ⇒ₗ ψ₂) := + ⟨ECCProofOfEProofOfEProof hp.some hq.some⟩ + +lemma C_iff_C_of_E_of_E (hp : 𝓢 ⊢ φ₁ ⇔ₗ φ₂) (hq : 𝓢 ⊢ ψ₁ ⇔ₗ ψ₂) : 𝓢 ⊢ φ₁ ⇒ₗ ψ₁ ↔ 𝓢 ⊢ φ₂ ⇒ₗ ψ₂ := + by classical exact iff_of_E (ECC_of_E_of_E hp hq) +/-- The dni! construction in `FFL.Entailment`. -/ +def dniProof [DecidableEq F] : 𝓢 ⊢! φ ⇒ₗ ∼∼φ := by + apply deduct'Proof; + apply NProofOfCOProof; + apply deductProof; + exact botOfMemEitherProof (φ := φ) (by simp) (by simp); +@[simp] +lemma dni : 𝓢 ⊢ φ ⇒ₗ ∼∼φ := by classical exact ⟨dniProof⟩ +/-- The dni'! construction in `FFL.Entailment`. -/ +def dni'Proof [DecidableEq F] (b : 𝓢 ⊢! φ) : 𝓢 ⊢! ∼∼φ := + dniProof⨀b +lemma dni' (b : 𝓢 ⊢ φ) : 𝓢 ⊢ ∼∼φ := by classical exact ⟨dni'Proof b.some⟩ +/-- The ANNNN! of A! construction in `FFL.Entailment`. -/ +def ANNNNProofOfAProof [DecidableEq F] (d : 𝓢 ⊢! φ ⋎ ψ) : 𝓢 ⊢! ∼∼φ ⋎ ∼∼ψ := + ofCProofOfCProofOfAProof (CProofTrans dniProof or₁Proof) (CProofTrans dniProof or₂Proof) d +lemma ANNNN_of_A (d : 𝓢 ⊢ φ ⋎ ψ) : 𝓢 ⊢ ∼∼φ ⋎ ∼∼ψ := by + classical exact ⟨ANNNNProofOfAProof d.some⟩ +/-- The KNNNN! of K! construction in `FFL.Entailment`. -/ +def KNNNNProofOfKProof [DecidableEq F] (d : 𝓢 ⊢! φ ⋏ ψ) : 𝓢 ⊢! ∼∼φ ⋏ ∼∼ψ := + KProofIntro (dni'Proof <| KProofLeft d) (dni'Proof <| KProofRight d) +lemma KNNNN_of_K (d : 𝓢 ⊢ φ ⋏ ψ) : 𝓢 ⊢ ∼∼φ ⋏ ∼∼ψ := by + classical exact ⟨KNNNNProofOfKProof d.some⟩ +/-- The CNNOO! construction in `FFL.Entailment`. -/ +def CNNOOProof : 𝓢 ⊢! ∼∼⊥ ⇒ₗ ⊥ := by + apply deduct'Proof + have d₁ : [∼∼⊥] ⊢[𝓢]! ∼⊥ ⇒ₗ ⊥ := COProofOfNProof byAxm₀Proof + have d₂ : [∼∼⊥] ⊢[𝓢]! ∼⊥ := NProofOfCOProof CProofId + exact d₁⨀d₂ + +/-- The ENNOO! construction in `FFL.Entailment`. -/ +def ENNOOProof [DecidableEq F] : 𝓢 ⊢! ∼∼⊥ ⇔ₗ ⊥ := + KProofIntro CNNOOProof dniProof + +/-- The CCCNN! construction in `FFL.Entailment`. -/ +def CCCNNProof [DecidableEq F] : 𝓢 ⊢! (φ ⇒ₗ ψ) ⇒ₗ (∼ψ ⇒ₗ ∼φ) := by + apply deduct'Proof; + apply deductProof; + apply NProofOfCOProof; + apply deductProof; + have dp : [φ, ∼ψ, φ ⇒ₗ ψ] ⊢[𝓢]! φ := FiniteContext.byAxmProof; + have dpq : [φ, ∼ψ, φ ⇒ₗ ψ] ⊢[𝓢]! φ ⇒ₗ ψ := FiniteContext.byAxmProof; + have dq : [φ, ∼ψ, φ ⇒ₗ ψ] ⊢[𝓢]! ψ := dpq ⨀ dp; + have dnq : [φ, ∼ψ, φ ⇒ₗ ψ] ⊢[𝓢]! ψ ⇒ₗ ⊥ := COProofOfNProof <| FiniteContext.byAxmProof; + exact dnq ⨀ dq; +@[simp] +theorem CCCNN : 𝓢 ⊢ (φ ⇒ₗ ψ) ⇒ₗ (∼ψ ⇒ₗ ∼φ) := by classical exact ⟨CCCNNProof⟩ +@[deprecated "use `CCCNN!`" (since := "2026-07-20")] +alias contra₀Proof := CCCNNProof +@[deprecated "use `CCCNN`" (since := "2026-07-20")] +alias contra₀ := CCCNN + +/-- The contra! construction in `FFL.Entailment`. -/ +def contraProof [DecidableEq F] (b : 𝓢 ⊢! φ ⇒ₗ ψ) : 𝓢 ⊢! ∼ψ ⇒ₗ ∼φ := + CCCNNProof⨀b +lemma contra (b : 𝓢 ⊢ φ ⇒ₗ ψ) : 𝓢 ⊢ ∼ψ ⇒ₗ ∼φ := by classical exact ⟨contraProof b.some⟩ +@[deprecated "use `contra!`" (since := "2026-07-20")] +alias contra₀'Proof := contraProof +@[deprecated "use `contra`" (since := "2026-07-20")] +alias contra₀' := contra + +/-- The CNNNN! of C! construction in `FFL.Entailment`. -/ +def CNNNNProofOfCProof [DecidableEq F] (b : 𝓢 ⊢! φ ⇒ₗ ψ) : 𝓢 ⊢! ∼∼φ ⇒ₗ ∼∼ψ := + contraProof <| contraProof b +@[grind <=] +lemma CNNNN_of_C (b : 𝓢 ⊢ φ ⇒ₗ ψ) : 𝓢 ⊢ ∼∼φ ⇒ₗ ∼∼ψ := by + classical exact ⟨CNNNNProofOfCProof b.some⟩ +/-- The CCCNNNN! construction in `FFL.Entailment`. -/ +def CCCNNNNProof [DecidableEq F] : 𝓢 ⊢! (φ ⇒ₗ ψ) ⇒ₗ (∼∼φ ⇒ₗ ∼∼ψ) := + deduct'Proof <| CNNNNProofOfCProof FiniteContext.idProof +@[simp] +lemma CCCNNNN : 𝓢 ⊢ (φ ⇒ₗ ψ) ⇒ₗ (∼∼φ ⇒ₗ ∼∼ψ) := by classical exact ⟨CCCNNNNProof⟩ +/-- The CN! of CN! right construction in `FFL.Entailment`. -/ +def CNProofOfCNProofRight [DecidableEq F] (b : 𝓢 ⊢! φ ⇒ₗ ∼ψ) : 𝓢 ⊢! ψ ⇒ₗ ∼φ := + CProofTrans dniProof (contraProof b) +lemma CN_of_CN_right (b : 𝓢 ⊢ φ ⇒ₗ ∼ψ) : 𝓢 ⊢ ψ ⇒ₗ ∼φ := by + classical exact ⟨CNProofOfCNProofRight b.some⟩ +/-- The CCNCN! construction in `FFL.Entailment`. -/ +def CCNCNProof [DecidableEq F] : 𝓢 ⊢! (φ ⇒ₗ ∼ψ) ⇒ₗ (ψ ⇒ₗ ∼φ) := + deduct'Proof <| CNProofOfCNProofRight FiniteContext.idProof +lemma CCNCN : 𝓢 ⊢ (φ ⇒ₗ ∼ψ) ⇒ₗ (ψ ⇒ₗ ∼φ) := by classical exact ⟨CCNCNProof⟩ +/-- The ENN! of E! construction in `FFL.Entailment`. -/ +def ENNProofOfEProof [DecidableEq F] (b : 𝓢 ⊢! φ ⇔ₗ ψ) : 𝓢 ⊢! ∼φ ⇔ₗ ∼ψ := + EProofIntro (contraProof <| KProofRight b) (contraProof <| KProofLeft b) +lemma ENN_of_E (b : 𝓢 ⊢ φ ⇔ₗ ψ) : 𝓢 ⊢ ∼φ ⇔ₗ ∼ψ := by classical exact ⟨ENNProofOfEProof b.some⟩ +section NegationEquiv + +/-- The ENNCCOO! construction in `FFL.Entailment`. -/ +def ENNCCOOProof [DecidableEq F] : 𝓢 ⊢! ∼∼φ ⇔ₗ ((φ ⇒ₗ ⊥) ⇒ₗ ⊥) := + by + apply EProofIntro; + · exact + CProofTrans (by apply contraProof; exact KProofRight negEquivProof) + (KProofLeft negEquivProof) + · exact + CProofTrans (KProofRight negEquivProof) + (by apply contraProof; exact KProofLeft negEquivProof) +@[simp] +lemma ENNCCOO : 𝓢 ⊢ ∼∼φ ⇔ₗ ((φ ⇒ₗ ⊥) ⇒ₗ ⊥) := by classical exact ⟨ENNCCOOProof⟩ +end NegationEquiv + +/-- The tne! construction in `FFL.Entailment`. -/ +def tneProof [DecidableEq F] : 𝓢 ⊢! ∼(∼∼φ) ⇒ₗ ∼φ := + contraProof dniProof +@[simp] +lemma tne : 𝓢 ⊢ ∼(∼∼φ) ⇒ₗ ∼φ := by classical exact ⟨tneProof⟩ +/-- The tne'! construction in `FFL.Entailment`. -/ +def tne'Proof [DecidableEq F] (b : 𝓢 ⊢! ∼(∼∼φ)) : 𝓢 ⊢! ∼φ := + tneProof⨀b +lemma tne' (b : 𝓢 ⊢ ∼(∼∼φ)) : 𝓢 ⊢ ∼φ := by classical exact ⟨tne'Proof b.some⟩ +/-- The tne Iff! construction in `FFL.Entailment`. -/ +def tneIffProof [DecidableEq F] : 𝓢 ⊢! ∼∼∼φ ⇔ₗ ∼φ := + KProofIntro tneProof dniProof + +/-- The CCC! of C! left construction in `FFL.Entailment`. -/ +def CCCProofOfCProofLeft (h : 𝓢 ⊢! ψ ⇒ₗ φ) : 𝓢 ⊢! (φ ⇒ₗ χ) ⇒ₗ (ψ ⇒ₗ χ) := by + apply deduct'Proof; + exact CProofTrans (ofProof h) idProof; +lemma CCC_of_C_left (h : 𝓢 ⊢ ψ ⇒ₗ φ) : 𝓢 ⊢ (φ ⇒ₗ χ) ⇒ₗ (ψ ⇒ₗ χ) := + ⟨CCCProofOfCProofLeft h.some⟩ + +@[deprecated "use `CCC!OfC!Left`" (since := "2026-07-20")] +alias revDhypImp'Proof := CCCProofOfCProofLeft +@[deprecated "use `CCC_of_C_left`" (since := "2026-07-20")] +alias rev_dhyp_imp' := CCC_of_C_left + +lemma C_iff_C_of_iff_left (h : 𝓢 ⊢ φ ⇔ₗ ψ) : 𝓢 ⊢ φ ⇒ₗ χ ↔ 𝓢 ⊢ ψ ⇒ₗ χ := + by + constructor; · exact C_trans <| K_right h; + · exact C_trans <| K_left h; + +lemma C_iff_C_of_iff_right (h : 𝓢 ⊢ φ ⇔ₗ ψ) : 𝓢 ⊢ χ ⇒ₗ φ ↔ 𝓢 ⊢ χ ⇒ₗ ψ := + by + constructor; · intro hrp; exact C_trans hrp <| K_left h; + · intro hrq; exact C_trans hrq <| K_right h; + +/-- The C! swap construction in `FFL.Entailment`. -/ +def CProofSwap [DecidableEq F] (h : 𝓢 ⊢! φ ⇒ₗ ψ ⇒ₗ χ) : 𝓢 ⊢! ψ ⇒ₗ φ ⇒ₗ χ := by + apply deduct'Proof; apply deductProof; + exact (ofProof (Γ := [φ, ψ]) h)⨀FiniteContext.byAxmProof⨀FiniteContext.byAxmProof; +lemma C_swap (h : 𝓢 ⊢ (φ ⇒ₗ ψ ⇒ₗ χ)) : 𝓢 ⊢ (ψ ⇒ₗ φ ⇒ₗ χ) := by + classical exact ⟨CProofSwap h.some⟩ +/-- The CCCCC! construction in `FFL.Entailment`. -/ +def CCCCCProof [DecidableEq F] : 𝓢 ⊢! (φ ⇒ₗ ψ ⇒ₗ χ) ⇒ₗ (ψ ⇒ₗ φ ⇒ₗ χ) := + deduct'Proof <| CProofSwap FiniteContext.idProof +@[simp] +lemma CCCCC : 𝓢 ⊢ (φ ⇒ₗ ψ ⇒ₗ χ) ⇒ₗ (ψ ⇒ₗ φ ⇒ₗ χ) := by classical exact ⟨CCCCCProof⟩ +/-- The C! of CC! construction in `FFL.Entailment`. -/ +def CProofOfCCProof [DecidableEq F] (h : 𝓢 ⊢! φ ⇒ₗ φ ⇒ₗ ψ) : 𝓢 ⊢! φ ⇒ₗ ψ := by + apply deduct'Proof; have := ofProof (Γ := [φ]) h; + exact this⨀(FiniteContext.byAxmProof)⨀(FiniteContext.byAxmProof); +lemma C_of_CC (h : 𝓢 ⊢ φ ⇒ₗ φ ⇒ₗ ψ) : 𝓢 ⊢ φ ⇒ₗ ψ := by classical exact ⟨CProofOfCCProof h.some⟩ +/-- The CCC! construction in `FFL.Entailment`. -/ +def CCCProof [DecidableEq F] : 𝓢 ⊢! φ ⇒ₗ (φ ⇒ₗ ψ) ⇒ₗ ψ := + CProofSwap <| CProofId +lemma CCC : 𝓢 ⊢ φ ⇒ₗ (φ ⇒ₗ ψ) ⇒ₗ ψ := by classical exact ⟨CCCProof⟩ +/-- The CCC! of C! right construction in `FFL.Entailment`. -/ +def CCCProofOfCProofRight (h : 𝓢 ⊢! φ ⇒ₗ ψ) : 𝓢 ⊢! (χ ⇒ₗ φ) ⇒ₗ (χ ⇒ₗ ψ) := + implySProof⨀(CProofOfConseqProof h) +lemma CCC_of_C_right (h : 𝓢 ⊢ φ ⇒ₗ ψ) : 𝓢 ⊢ (χ ⇒ₗ φ) ⇒ₗ (χ ⇒ₗ ψ) := + ⟨CCCProofOfCProofRight h.some⟩ + +/-- The CNNCCNNNN! construction in `FFL.Entailment`. -/ +def CNNCCNNNNProof [DecidableEq F] : 𝓢 ⊢! ∼∼(φ ⇒ₗ ψ) ⇒ₗ (∼∼φ ⇒ₗ ∼∼ψ) := by + apply CProofSwap; + apply deduct'Proof; + exact CProofTrans (CNNNNProofOfCProof <| deductInvProof <| ofProof <| CProofSwap <| + CCCNNNNProof) tneProof; + +@[simp] +lemma CNNCCNNNN : 𝓢 ⊢ ∼∼(φ ⇒ₗ ψ) ⇒ₗ (∼∼φ ⇒ₗ ∼∼ψ) := by classical exact ⟨CNNCCNNNNProof⟩ +/-- The CNNNN! of NNC! construction in `FFL.Entailment`. -/ +def CNNNNProofOfNNCProof [DecidableEq F] (b : 𝓢 ⊢! ∼∼(φ ⇒ₗ ψ)) : 𝓢 ⊢! ∼∼φ ⇒ₗ ∼∼ψ := + CNNCCNNNNProof⨀b +lemma CNNNN_of_NNC (b : 𝓢 ⊢ ∼∼(φ ⇒ₗ ψ)) : 𝓢 ⊢ ∼∼φ ⇒ₗ ∼∼ψ := by + classical exact ⟨CNNNNProofOfNNCProof b.some⟩ +/-- The O! intro of KN! construction in `FFL.Entailment`. -/ +def OProofIntroOfKNProof (h : 𝓢 ⊢! φ ⋏ ∼φ) : 𝓢 ⊢! ⊥ := + (COProofOfNProof <| KProofRight h)⨀(KProofLeft h) +lemma O_intro_of_KN (h : 𝓢 ⊢ φ ⋏ ∼φ) : 𝓢 ⊢ ⊥ := + ⟨OProofIntroOfKNProof h.some⟩ +/-- Law of contradiction -/ +alias lac' := O_intro_of_KN + +/-- The CKNO! construction in `FFL.Entailment`. -/ +def CKNOProof : 𝓢 ⊢! φ ⋏ ∼φ ⇒ₗ ⊥ := by + apply deduct'Proof; + exact OProofIntroOfKNProof (φ := φ) <| FiniteContext.idProof +@[simp] +lemma CKNO : 𝓢 ⊢ φ ⋏ ∼φ ⇒ₗ ⊥ := + ⟨CKNOProof⟩ +/-- Law of contradiction -/ +alias lac := CKNO + +/-- The CANNNK! construction in `FFL.Entailment`. -/ +def CANNNKProof [DecidableEq F] : 𝓢 ⊢! (∼φ ⋎ ∼ψ) ⇒ₗ ∼(φ ⋏ ψ) := + leftAProofIntro (contraProof and₁Proof) (contraProof and₂Proof) +@[simp] +lemma CANNNK : 𝓢 ⊢ (∼φ ⋎ ∼ψ) ⇒ₗ ∼(φ ⋏ ψ) := by classical exact ⟨CANNNKProof⟩ +/-- The NK! of ANN! construction in `FFL.Entailment`. -/ +def NKProofOfANNProof [DecidableEq F] (d : 𝓢 ⊢! ∼φ ⋎ ∼ψ) : 𝓢 ⊢! ∼(φ ⋏ ψ) := + CANNNKProof⨀d +lemma NK_of_ANN (d : 𝓢 ⊢ ∼φ ⋎ ∼ψ) : 𝓢 ⊢ ∼(φ ⋏ ψ) := by + classical exact ⟨NKProofOfANNProof d.some⟩ +/-- The CKNNNA! construction in `FFL.Entailment`. -/ +def CKNNNAProof [DecidableEq F] : 𝓢 ⊢! (∼φ ⋏ ∼ψ) ⇒ₗ ∼(φ ⋎ ψ) := by + apply CKProofOfCCProof; + apply deduct'Proof; + apply deductProof; + apply NProofOfCOProof; + apply deductProof; + exact ofCProofOfCProofOfAProof (COProofOfNProof FiniteContext.byAxmProof) (COProofOfNProof + FiniteContext.byAxmProof) (FiniteContext.byAxmProof (φ := φ ⋎ ψ)); + +@[simp] +lemma CKNNNA : 𝓢 ⊢ ∼φ ⋏ ∼ψ ⇒ₗ ∼(φ ⋎ ψ) := by classical exact ⟨CKNNNAProof⟩ +/-- The NA! of KNN! construction in `FFL.Entailment`. -/ +def NAProofOfKNNProof [DecidableEq F] (d : 𝓢 ⊢! ∼φ ⋏ ∼ψ) : 𝓢 ⊢! ∼(φ ⋎ ψ) := + CKNNNAProof⨀d +lemma NA_of_KNN (d : 𝓢 ⊢ ∼φ ⋏ ∼ψ) : 𝓢 ⊢ ∼(φ ⋎ ψ) := by + classical exact ⟨NAProofOfKNNProof d.some⟩ +/-- The CNAKNN! construction in `FFL.Entailment`. -/ +def CNAKNNProof [DecidableEq F] : 𝓢 ⊢! ∼(φ ⋎ ψ) ⇒ₗ (∼φ ⋏ ∼ψ) := by + apply deduct'Proof; + exact KProofIntro (deductInvProof <| contraProof <| or₁Proof) (deductInvProof <| contraProof + <| or₂Proof) + +@[simp] +lemma CNAKNN : 𝓢 ⊢ ∼(φ ⋎ ψ) ⇒ₗ (∼φ ⋏ ∼ψ) := by classical exact ⟨CNAKNNProof⟩ +/-- The KNN! of NA! construction in `FFL.Entailment`. -/ +def KNNProofOfNAProof [DecidableEq F] (b : 𝓢 ⊢! ∼(φ ⋎ ψ)) : 𝓢 ⊢! ∼φ ⋏ ∼ψ := + CNAKNNProof⨀b +lemma KNN_of_NA (b : 𝓢 ⊢ ∼(φ ⋎ ψ)) : 𝓢 ⊢ ∼φ ⋏ ∼ψ := by + classical exact ⟨KNNProofOfNAProof b.some⟩ +section Conjunction + +/-- The EConj₂Conj! construction in `FFL.Entailment`. -/ +def EConj₂ConjProof : (Γ : List F) → 𝓢 ⊢! ⋀Γ ⇔ₗ (PointwiseComposition.List.conj Γ) + | [] => EProofId + | [_] => EProofIntro (deduct'Proof <| KProofIntro FiniteContext.idProof verumProof) and₁Proof + | _ :: ψ :: Γ => EKKProofOfEProofOfEProof (EProofId) (EConj₂ConjProof (ψ :: Γ)) +@[simp] +lemma EConj₂Conj : 𝓢 ⊢ ⋀Γ ⇔ₗ (PointwiseComposition.List.conj Γ) := + ⟨EConj₂ConjProof Γ⟩ + +lemma CConj_iff_CConj₂ : 𝓢 ⊢ (PointwiseComposition.List.conj Γ) ⇒ₗ φ ↔ 𝓢 ⊢ ⋀Γ ⇒ₗ φ := + C_iff_C_of_iff_left <| E_symm EConj₂Conj + +/-- ! note: It may be easier to handle define `List.conj` based on `List.conj' (?)` -/ +def rightConj'ProofIntro [DecidableEq F] (φ : F) (l : List ι) (ψ : ι → F) + (b : ∀ i ∈ l, 𝓢 ⊢! φ ⇒ₗ ψ i) : 𝓢 ⊢! φ ⇒ₗ (PointwiseComposition.List.conj' · l) ψ := + rightConj₂ProofIntro φ (l.map ψ) fun χ h ↦ + let ⟨i, hi, e⟩ := l.chooseX (fun i ↦ ψ i = χ) (by simpa using h) + e ▸ (b i hi) +lemma right_Conj'_intro (φ : F) (l : List ι) (ψ : ι → F) (b : ∀ i ∈ l, 𝓢 ⊢ φ ⇒ₗ ψ i) : + 𝓢 ⊢ φ ⇒ₗ (PointwiseComposition.List.conj' · l) ψ := by + classical exact ⟨rightConj'ProofIntro φ l ψ fun i hi ↦ (b i hi).get⟩ +/-- The left Conj'! intro construction in `FFL.Entailment`. -/ +def leftConj'ProofIntro [DecidableEq F] {l : List ι} (h : i ∈ l) (φ : ι → F) : + 𝓢 ⊢! (PointwiseComposition.List.conj' · l) φ ⇒ₗ φ i := + leftConj₂ProofIntro (by simp only [mem_map]; use i) +lemma left_Conj'_intro {l : List ι} (h : i ∈ l) (φ : ι → F) : + 𝓢 ⊢ (PointwiseComposition.List.conj' · l) φ ⇒ₗ φ i := by + classical exact ⟨leftConj'ProofIntro h φ⟩ +lemma right_Fconj_intro (φ : F) (s : Finset F) (b : (ψ : F) → ψ ∈ s → 𝓢 ⊢ φ ⇒ₗ ψ) : + 𝓢 ⊢ φ ⇒ₗ (PointwiseComposition.Finset.conj s) := + right_Conj₂_intro φ s.toList fun ψ hψ ↦ b ψ (by simpa using hψ) + +lemma left_Fconj_intro [DecidableEq F] {s : Finset F} (h : φ ∈ s) : + 𝓢 ⊢ (PointwiseComposition.Finset.conj s) ⇒ₗ φ := + left_Conj₂_intro <| by simp [h] + +lemma right_Fconj'_intro (φ : F) (s : Finset ι) (ψ : ι → F) (b : ∀ i ∈ s, 𝓢 ⊢ φ ⇒ₗ ψ i) : + 𝓢 ⊢ φ ⇒ₗ ⋀ i ∈ s, ψ i := by classical exact right_Conj'_intro φ s.toList ψ (by simpa) +lemma left_Fconj'_intro {s : Finset ι} (φ : ι → F) {i} (hi : i ∈ s) : + 𝓢 ⊢ (⋀ i ∈ s, φ i) ⇒ₗ φ i := by classical exact left_Conj'_intro (by simpa) φ +lemma right_Uconj_intro [Fintype ι] (φ : F) (ψ : ι → F) (b : (i : ι) → 𝓢 ⊢ φ ⇒ₗ ψ i) : + 𝓢 ⊢ φ ⇒ₗ ⋀ i, ψ i := by + classical exact right_Fconj'_intro φ Finset.univ ψ (by simpa using b) +lemma left_Uconj_intro [Fintype ι] (φ : ι → F) (i) : 𝓢 ⊢ (⋀ i, φ i) ⇒ₗ φ i := by + classical exact left_Fconj'_intro _ <| by simp +lemma Conj₂_iff_forall_provable {Γ : List F} : (𝓢 ⊢ ⋀Γ) ↔ (∀ φ ∈ Γ, 𝓢 ⊢ φ) := by + classical + induction Γ using List.induction_with_singleton with + | hnil => simp; + | hsingle => simp; + | hcons φ Γ hΓ + ih => + simp_all only [ne_eq, not_false_eq_true, conj₂_cons_nonempty, mem_cons, forall_eq_or_imp]; + constructor; + · intro h; constructor; · exact K_left h; + · exact ih.mp (K_right h); + · rintro ⟨h₁, h₂⟩; exact K_intro h₁ (ih.mpr h₂); + +lemma CConj₂Conj₂_of_subset (h : ∀ φ, φ ∈ Γ → φ ∈ Δ) : 𝓢 ⊢ ⋀Δ ⇒ₗ ⋀Γ := by + classical + induction Γ using List.induction_with_singleton with + | hnil => simp; + | hsingle => + simp_all only [mem_cons, not_mem_nil, or_false, forall_eq, conj₂_singleton] + exact left_Conj₂_intro h + | hcons φ Γ hne ih => + simp_all only [ne_eq, mem_cons, or_true, implies_true, forall_const, forall_eq_or_imp, + not_false_eq_true, + conj₂_cons_nonempty]; + exact right_K_intro (left_Conj₂_intro h.1) ih; + +lemma CConj₂Conj₂_of_provable (h : ∀ φ, φ ∈ Γ → Δ ⊢[𝓢] φ) : 𝓢 ⊢ ⋀Δ ⇒ₗ ⋀Γ := by + classical + induction Γ using List.induction_with_singleton with + | hnil => exact C_of_conseq verum; + | hsingle => + simp_all only [mem_cons, not_mem_nil, or_false, forall_eq, conj₂_singleton] + exact provable_iff.mp h + | hcons φ Γ hne ih => + simp_all only [ne_eq, mem_cons, or_true, implies_true, forall_const, forall_eq_or_imp, + not_false_eq_true, + conj₂_cons_nonempty]; + exact right_K_intro (provable_iff.mp h.1) ih; + +lemma CConj₂_of_forall_provable (h : ∀ φ, φ ∈ Γ → Δ ⊢[𝓢] φ) : Δ ⊢[𝓢] ⋀Γ := by + classical exact provable_iff.mpr <| CConj₂Conj₂_of_provable h +lemma CConj₂_of_unique (he : ∀ g ∈ Γ, g = φ) : 𝓢 ⊢ φ ⇒ₗ ⋀Γ := by + classical + induction Γ using List.induction_with_singleton with + | hcons χ Γ h ih => + simp_all only [ne_eq, mem_cons, true_or, or_true, implies_true, forall_const, + forall_eq_or_imp, not_false_eq_true, conj₂_cons_nonempty]; + have ⟨he₁, he₂⟩ := he; subst he₁; exact right_K_intro C_id ih; + | _ => simp_all; + +lemma C_of_CConj₂_of_unique (he : ∀ g ∈ Γ, g = φ) (hd : 𝓢 ⊢ ⋀Γ ⇒ₗ ψ) : 𝓢 ⊢ φ ⇒ₗ ψ := by + classical exact C_trans (CConj₂_of_unique he) hd +lemma CConj₂_iff_CKConj₂ : 𝓢 ⊢ ⋀(φ :: Γ) ⇒ₗ ψ ↔ 𝓢 ⊢ φ ⋏ ⋀Γ ⇒ₗ ψ := by + classical + induction Γ with + | nil => + simp only [conj₂_singleton, conj₂_nil, CK_iff_CC]; constructor; + · intro h; apply C_swap; exact C_of_conseq h; + · intro h; exact C_swap h⨀verum; + | cons ψ ih => simp; + +@[simp] +lemma CConj₂AppendKConj₂Conj₂ : 𝓢 ⊢ ⋀(Γ ++ Δ) ⇒ₗ ⋀Γ ⋏ ⋀Δ := by + classical + apply FiniteContext.deduct'; have : [⋀(Γ ++ Δ)] ⊢[𝓢] ⋀(Γ ++ Δ) := id; + have d := Conj₂_iff_forall_provable.mp this; apply K_intro; + · apply Conj₂_iff_forall_provable.mpr; intro φ hp; + exact d φ (by simp only [mem_append]; left; exact hp); + · apply Conj₂_iff_forall_provable.mpr; intro φ hp; + exact d φ (by simp only [mem_append]; right; exact hp); + +@[simp] +lemma CKConj₂RemoveConj₂ [DecidableEq F] : + 𝓢 ⊢ ⋀((PointwiseComposition.List.remove · Γ) φ) ⋏ φ ⇒ₗ ⋀Γ := + by + apply deduct'; apply Conj₂_iff_forall_provable.mpr; intro ψ hq; by_cases e : ψ = φ; + · subst e; exact K_right id; + · exact + Conj₂_iff_forall_provable.mp (K_left id) ψ (by apply List.mem_remove_iff.mpr; simp_all); + +lemma CKConj₂Remove_of_CConj₂ [DecidableEq F] (b : 𝓢 ⊢ ⋀Γ ⇒ₗ ψ) : + 𝓢 ⊢ ⋀((PointwiseComposition.List.remove · Γ) φ) ⋏ φ ⇒ₗ ψ := + C_trans CKConj₂RemoveConj₂ b + +lemma Conj₂Append_iff_KConj₂Conj₂ : 𝓢 ⊢ ⋀(Γ ++ Δ) ↔ 𝓢 ⊢ ⋀Γ ⋏ ⋀Δ := by + classical + constructor; + · intro h; replace h := Conj₂_iff_forall_provable.mp h; apply K_intro; + · apply Conj₂_iff_forall_provable.mpr; intro φ hp; + exact h φ (by simp only [List.mem_append]; left; simpa); + · apply Conj₂_iff_forall_provable.mpr; intro φ hp; + exact h φ (by simp only [List.mem_append]; right; simpa); + · intro h; apply Conj₂_iff_forall_provable.mpr; simp only [List.mem_append]; + rintro φ (hp₁ | hp₂); · exact (Conj₂_iff_forall_provable.mp <| K_left h) φ hp₁; + · exact (Conj₂_iff_forall_provable.mp <| K_right h) φ hp₂; + +@[simp] +lemma EConj₂AppendKConj₂Conj₂ : 𝓢 ⊢ ⋀(Γ ++ Δ) ⇔ₗ ⋀Γ ⋏ ⋀Δ := by + classical + apply E_intro; · apply deduct'; apply Conj₂Append_iff_KConj₂Conj₂.mp; exact id; + · apply deduct'; apply Conj₂Append_iff_KConj₂Conj₂.mpr; exact id; + +lemma CConj₂Append_iff_CKConj₂Conj₂ : 𝓢 ⊢ ⋀(Γ ++ Δ) ⇒ₗ φ ↔ 𝓢 ⊢ (⋀Γ ⋏ ⋀Δ) ⇒ₗ φ := by + classical + constructor; · intro h; exact C_trans (K_right EConj₂AppendKConj₂Conj₂) h; + · intro h; exact C_trans (K_left EConj₂AppendKConj₂Conj₂) h; + +@[simp] +lemma CConj₂FConj {Γ : Finset F} : 𝓢 ⊢ ⋀Γ.toList ⇒ₗ (PointwiseComposition.Finset.conj Γ) := by + classical apply CConj₂Conj₂_of_provable; apply FiniteContext.by_axm; + +@[simp] lemma CConj₂FConj_list [DecidableEq F] {Γ : List F} : 𝓢 ⊢ ⋀Γ ⇒ₗ + (PointwiseComposition.Finset.conj Γ.toFinset) := by + apply C_trans ?_ CConj₂FConj; + apply CConj₂Conj₂_of_subset; + simp; + +@[simp] +lemma CFConjConj₂ {Γ : Finset F} : 𝓢 ⊢ (PointwiseComposition.Finset.conj Γ) ⇒ₗ ⋀Γ.toList := by + classical apply right_Conj₂_intro; intro φ hφ; apply left_Fconj_intro; simpa using hφ; + +@[simp] lemma CFConjConj₂_list [DecidableEq F] {Γ : List F} : 𝓢 ⊢ + (PointwiseComposition.Finset.conj Γ.toFinset) ⇒ₗ ⋀Γ := by + apply C_trans <| CFConjConj₂; + apply CConj₂Conj₂_of_subset; + simp; + +lemma FConj_DT {Γ : Finset F} : 𝓢 ⊢ (PointwiseComposition.Finset.conj Γ) ⇒ₗ φ ↔ Γ *⊢[𝓢] φ := by + classical + constructor; + · intro h; apply Context.provable_iff.mpr; use Γ.toList; constructor; · simp; + · apply FiniteContext.provable_iff.mpr; exact C_trans (by simp) h; + · intro h; obtain ⟨Δ, hΔ₁, hΔ₂⟩ := Context.provable_iff.mp h; + replace hΔ₂ : 𝓢 ⊢ ⋀Γ.toList ⇒ₗ φ := + C_trans (CConj₂Conj₂_of_subset (by simpa)) <| FiniteContext.provable_iff.mp hΔ₂ + exact C_trans (by simp) hΔ₂; + +lemma FConj_iff_forall_provable [DecidableEq F] {Γ : Finset F} : + (𝓢 ⊢ (PointwiseComposition.Finset.conj Γ)) ↔ (∀ φ ∈ Γ, 𝓢 ⊢ φ) := by + apply Iff.trans Conj₂_iff_forall_provable; constructor <;> simp_all; + +lemma FConj_of_FConj_of_subset {Γ Δ : Finset F} (h : Δ ⊆ Γ) + (hΓ : 𝓢 ⊢ (PointwiseComposition.Finset.conj Γ)) : + 𝓢 ⊢ (PointwiseComposition.Finset.conj Δ) := by + classical rw [FConj_iff_forall_provable] at hΓ ⊢; intro φ hφ; apply hΓ; apply h hφ; + +lemma CFConjFConj_of_subset {Γ Δ : Finset F} (h : Δ ⊆ Γ) : + 𝓢 ⊢ (PointwiseComposition.Finset.conj Γ) ⇒ₗ (PointwiseComposition.Finset.conj Δ) := by + classical apply FConj_DT.mpr; apply FConj_of_FConj_of_subset h; apply FConj_DT.mp; simp; + +@[simp] lemma CFconjUnionKFconj [DecidableEq F] {Γ Δ : Finset F} : 𝓢 ⊢ + (PointwiseComposition.Finset.conj (Γ ∪ Δ)) ⇒ₗ (PointwiseComposition.Finset.conj Γ) ⋏ + (PointwiseComposition.Finset.conj Δ) := by + apply FConj_DT.mpr; + apply K_intro <;> + · apply FConj_DT.mp; + apply CFConjFConj_of_subset; + simp; + +@[simp] +lemma CinsertFConjKFConj [DecidableEq F] {Γ : Finset F} : + 𝓢 ⊢ + (PointwiseComposition.Finset.conj (insert φ Γ)) ⇒ₗ + φ ⋏ (PointwiseComposition.Finset.conj Γ) := + by + suffices + 𝓢 ⊢ + (PointwiseComposition.Finset.conj ({ φ } ∪ Γ)) ⇒ₗ + (Finset.conj { φ }) ⋏ (PointwiseComposition.Finset.conj Γ) + by simpa using this; + apply CFconjUnionKFconj; + +@[simp] +lemma CKFconjFconjUnion [DecidableEq F] {Γ Δ : Finset F} : + 𝓢 ⊢ + (PointwiseComposition.Finset.conj Γ) ⋏ (PointwiseComposition.Finset.conj Δ) ⇒ₗ + (PointwiseComposition.Finset.conj (Γ ∪ Δ)) := + by + apply right_Fconj_intro; simp only [Finset.mem_union]; rintro φ (hφ | hφ); + · apply left_K_intro_left + apply left_Fconj_intro hφ; + · apply left_K_intro_right; apply left_Fconj_intro hφ; + +@[simp] +lemma CKFConjinsertFConj [DecidableEq F] {Γ : Finset F} : + 𝓢 ⊢ + φ ⋏ (PointwiseComposition.Finset.conj Γ) ⇒ₗ + (PointwiseComposition.Finset.conj (insert φ Γ)) := + by + suffices + 𝓢 ⊢ + (Finset.conj { φ }) ⋏ (PointwiseComposition.Finset.conj Γ) ⇒ₗ + (PointwiseComposition.Finset.conj ({ φ } ∪ Γ)) + by simpa using this; + apply CKFconjFconjUnion; + +lemma FConj_DT' [DecidableEq F] {Γ Δ : Finset F} : + Γ *⊢[𝓢] (PointwiseComposition.Finset.conj Δ) ⇒ₗ φ ↔ ↑(Γ ∪ Δ) *⊢[𝓢] φ := + by + constructor; + · intro h; exact FConj_DT.mp <| C_trans CFconjUnionKFconj <| CK_iff_CC.mpr <| FConj_DT.mpr h; + · intro h; exact FConj_DT.mp <| CK_iff_CC.mp <| C_trans CKFconjFconjUnion <| FConj_DT.mpr h; + +lemma CFconjFconj_of_provable [DecidableEq F] {Γ Δ : Finset _} (h : ∀ φ, φ ∈ Γ → Δ *⊢[𝓢] φ) : + 𝓢 ⊢ (PointwiseComposition.Finset.conj Δ) ⇒ₗ (PointwiseComposition.Finset.conj Γ) := + by + have : 𝓢 ⊢ ⋀(Δ.toList) ⇒ₗ ⋀(Γ.toList) := + CConj₂Conj₂_of_provable <| by + intro φ hφ; apply Context.iff_provable_context_provable_finiteContext_toList.mp + apply h φ; simpa using hφ; + refine C_replace ?_ ?_ this; · simp; + · simp; + +end Conjunction + +section disjunction + +/-- The right Disj! intro construction in `FFL.Entailment`. -/ +def rightDisjProofIntro [DecidableEq F] (Γ : List F) (h : φ ∈ Γ) : + 𝓢 ⊢! φ ⇒ₗ (PointwiseComposition.List.disj Γ) := + match Γ with + | [] => by simp at h + | ψ :: Γ => + if e : φ = ψ then + cast (or₁Proof : 𝓢 ⊢! φ ⇒ₗ φ ⋎ (PointwiseComposition.List.disj Γ)) (by simp [e]) + else + have : φ ∈ Γ := by simpa [e] using h + CProofTrans (rightDisjProofIntro Γ this) or₂Proof +theorem right_Disj_intro (Γ : List F) (h : φ ∈ Γ) : + 𝓢 ⊢ φ ⇒ₗ (PointwiseComposition.List.disj Γ) := by classical exact ⟨rightDisjProofIntro Γ h⟩ +/-- The right Disj! intro' construction in `FFL.Entailment`. -/ +def rightDisjProofIntro' [DecidableEq F] (Γ : List F) (h : φ ∈ Γ) (hψ : 𝓢 ⊢! ψ ⇒ₗ φ) : + 𝓢 ⊢! ψ ⇒ₗ (PointwiseComposition.List.disj Γ) := + CProofTrans hψ (rightDisjProofIntro Γ h) +theorem right_Disj_intro' (Γ : List F) (h : φ ∈ Γ) (hψ : 𝓢 ⊢ ψ ⇒ₗ φ) : + 𝓢 ⊢ ψ ⇒ₗ (PointwiseComposition.List.disj Γ) := by + classical exact ⟨rightDisjProofIntro' Γ h hψ.get⟩ +/-- The right Disj₂! intro construction in `FFL.Entailment`. -/ +def rightDisj₂ProofIntro [DecidableEq F] (Γ : List F) (h : φ ∈ Γ) : 𝓢 ⊢! φ ⇒ₗ ⋁Γ := + match Γ with + | [] => by simp at h + | [ψ] => (show ⋁[ψ] = φ by simp_all) ▸ CProofId + | ψ :: χ :: Γ => + if e : φ = ψ then cast (or₁Proof : 𝓢 ⊢! φ ⇒ₗ φ ⋎ ⋁(χ :: Γ)) (by simp [e]) + else + have : φ ∈ χ :: Γ := by simpa [e] using h + CProofTrans (rightDisj₂ProofIntro _ this) or₂Proof +theorem right_Disj₂_intro (Γ : List F) (h : φ ∈ Γ) : 𝓢 ⊢ φ ⇒ₗ ⋁Γ := by + classical exact ⟨rightDisj₂ProofIntro Γ h⟩ +/-- The right Disj'! intro construction in `FFL.Entailment`. -/ +def rightDisj'ProofIntro [DecidableEq F] (φ : ι → F) (l : List ι) (h : i ∈ l) : + 𝓢 ⊢! φ i ⇒ₗ (PointwiseComposition.List.disj' · l) φ := + rightDisj₂ProofIntro (l.map φ) (by simpa using ⟨i, h, rfl⟩) +lemma right_Disj'_intro (φ : ι → F) (l : List ι) (h : i ∈ l) : + 𝓢 ⊢ φ i ⇒ₗ (PointwiseComposition.List.disj' · l) φ := by + classical exact ⟨rightDisj'ProofIntro φ l h⟩ +lemma right_Fdisj_intro [DecidableEq F] (s : Finset F) (h : φ ∈ s) : + 𝓢 ⊢ φ ⇒ₗ (PointwiseComposition.Finset.disj s) := + right_Disj₂_intro _ (by simp [h]) + +lemma right_Fdisj'_intro (s : Finset ι) (φ : ι → F) {i} (hi : i ∈ s) : + 𝓢 ⊢ φ i ⇒ₗ ⋁ j ∈ s, φ j := by classical exact right_Disj'_intro _ _ (by simp [hi]) +lemma right_Udisj_intro [Fintype ι] (φ : ι → F) : 𝓢 ⊢ φ i ⇒ₗ ⋁ j, φ j := by + classical exact right_Fdisj'_intro _ _ (by simp) +end disjunction + +section + +variable {Γ Δ : Finset F} + +lemma CFConjFDisj_of_K_intro [DecidableEq F] (hp : φ ∈ Γ) (hpq : ψ ∈ Γ) (hψ : φ ⋏ ψ ∈ Δ) : + 𝓢 ⊢ (PointwiseComposition.Finset.conj Γ) ⇒ₗ (PointwiseComposition.Finset.disj Δ) := + by + apply C_trans (ψ := Finset.disj {φ ⋏ ψ}); + · apply C_trans (ψ := Finset.conj { φ, ψ }) ?_; + · apply FConj_DT.mpr; + simp only [Finset.coe_insert, Finset.coe_singleton, Finset.disj_singleton]; + apply K_intro <;> exact Context.by_axm <| by simp; + · apply CFConjFConj_of_subset; apply Finset.doubleton_subset.mpr; tauto; + · simp only [Finset.disj_singleton]; apply right_Fdisj_intro _ hψ; + +lemma CFConjFDisj_of_innerMDP [DecidableEq F] (hp : φ ∈ Γ) (hpq : φ ⇒ₗ ψ ∈ Γ) (hψ : ψ ∈ Δ) : 𝓢 ⊢ + (PointwiseComposition.Finset.conj Γ) ⇒ₗ (PointwiseComposition.Finset.disj Δ) := by + apply C_trans (ψ := Finset.disj {ψ}); + · apply C_trans (ψ := Finset.conj {φ, φ ⇒ₗ ψ}) ?_; + · apply FConj_DT.mpr; + have h₁ : ({φ, φ ⇒ₗ ψ}) *⊢[𝓢] φ ⇒ₗ ψ := Context.by_axm <| by simp; + have h₂ : ({φ, φ ⇒ₗ ψ}) *⊢[𝓢] φ := Context.by_axm <| by simp; + simpa using h₁ ⨀ h₂; + · apply CFConjFConj_of_subset; + apply Finset.doubleton_subset.mpr; + tauto; + · simp only [Finset.disj_singleton]; + apply right_Fdisj_intro _ hψ; + +lemma iff_FiniteContext_Context [DecidableEq F] {Γ : List F} : Γ ⊢[𝓢] φ ↔ ↑Γ.toFinset *⊢[𝓢] φ := + by + constructor; + · intro h; replace h := FiniteContext.provable_iff.mp h; apply FConj_DT.mp; + exact C_trans (by simp) h; + · intro h; replace h := FConj_DT.mpr h; apply FiniteContext.provable_iff.mpr; + exact C_trans (by simp) h; + +lemma FConj'_iff_forall_provable {s : Finset α} {ι : α → F} : + (𝓢 ⊢ ⋀ i ∈ s, ι i) ↔ (∀ i ∈ s, 𝓢 ⊢ ι i) := by + classical + have : 𝓢 ⊢ ⋀(s.toList.map ι) ↔ ∀ i ∈ s, 𝓢 ⊢ ι i := by + simpa using Conj₂_iff_forall_provable (Γ := s.toList.map ι); + apply Iff.trans ?_ this; simp [Finset.conj', List.conj']; + +end + +namespace Context + +lemma provable_iff_finset {Γ : Set F} {φ : F} : + Γ *⊢[𝓢] φ ↔ ∃ Δ : Finset F, (↑Δ ⊆ Γ) ∧ Δ *⊢[𝓢] φ := by + classical + apply Iff.trans Context.provable_iff; constructor; + · rintro ⟨Δ, hΔ₁, hΔ₂⟩; use Δ.toFinset; constructor; · simpa; + · apply provable_iff.mpr + use Δ; constructor <;> simp_all; + · rintro ⟨Δ, hΔ₁, hΔ₂⟩; use Δ.toList; constructor; · simpa; + · apply FiniteContext.provable_iff.mpr; refine C_trans ?_ (FConj_DT.mpr hΔ₂); simp; + +lemma bot_of_mem_neg {Γ : Set F} (h₁ : φ ∈ Γ) (h₂ : ∼φ ∈ Γ) : Γ *⊢[𝓢] ⊥ := by + classical + replace h₁ : Γ *⊢[𝓢] φ := by_axm h₁; + replace h₂ : Γ *⊢[𝓢] φ ⇒ₗ ⊥ := N_iff_CO.mp <| by_axm h₂; + exact h₂ ⨀ h₁; + +end Context + +end + +end Entailment +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/Syntax/Predicate/Language.lean b/LeanPool/PointwiseComposition/Foundation/Syntax/Predicate/Language.lean new file mode 100644 index 000000000..7f7b5a556 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/Syntax/Predicate/Language.lean @@ -0,0 +1,583 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.Logic.Entailment +public import Mathlib.Logic.Encodable.Basic + +/-! Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +/-! +# Language of first-order logic + +This file defines the language of first-order logic. + +- `FFL.FirstOrder.Language.empty` is the empty language. +- `FFL.FirstOrder.Language.ofConstants C` is a language with only constants of the element `C`. +- `FFL.FirstOrder.Language.oRing`, `ℒₒᵣ` is the language of ordered ring. +-/ + +namespace FFL + +namespace FirstOrder + +/-- Function and relation symbols indexed by their arities. -/ +structure Language where + /-- The Func construction in `FFL.FirstOrder.Language`. -/ + Func : Nat → Type u + /-- The Rel construction in `FFL.FirstOrder.Language`. -/ + Rel : Nat → Type u + +namespace Language + +/-- Data and laws for Relational in `FFL.FirstOrder.Language`. -/ +class Relational (L : Language) where + func_empty : ∀ k, IsEmpty (L.Func k) + +instance {L : Language} [L.Relational] : IsEmpty (L.Func k) := + Relational.func_empty k + +/-- Data and laws for Is Constant in `FFL.FirstOrder.Language`. -/ +class IsConstant (L : Language) where + func_empty : ∀ k, IsEmpty (L.Func (k + 1)) + rel_empty : ∀ k, IsEmpty (L.Rel k) + +/-- Data and laws for Constant Inhabited in `FFL.FirstOrder.Language`. -/ +class ConstantInhabited (L : Language) extends Inhabited (L.Func 0) + +instance {L : Language} [L.ConstantInhabited] : Inhabited (L.Func 0) := + inferInstance + +/-- The empty construction in `FFL.FirstOrder.Language`. -/ +protected def empty : Language where + Func := fun _ => PEmpty + Rel := fun _ => PEmpty + +instance : Inhabited Language := + ⟨Language.empty⟩ + +/-- Data and laws for Graph Func in `FFL.FirstOrder.Language`. -/ +inductive GraphFunc : ℕ → Type + | start : GraphFunc 0 + | terminal : GraphFunc 0 + +/-- Data and laws for Graph Rel in `FFL.FirstOrder.Language`. -/ +inductive GraphRel : ℕ → Type + | equal : GraphRel 2 + | le : GraphRel 2 + +/-- The graph construction in `FFL.FirstOrder.Language`. -/ +def graph : Language where + Func := GraphFunc + Rel := GraphRel + +/-- Data and laws for Binary Rel in `FFL.FirstOrder.Language`. -/ +inductive BinaryRel : ℕ → Type + | isone : BinaryRel 1 + | equal : BinaryRel 2 + | le : BinaryRel 2 + +/-- The binary construction in `FFL.FirstOrder.Language`. -/ +def binary : Language where + Func := fun _ => Empty + Rel := BinaryRel + +/-- Data and laws for Eq Rel in `FFL.FirstOrder.Language`. -/ +inductive EqRel : ℕ → Type + | equal : EqRel 2 + +/-- The equal construction in `FFL.FirstOrder.Language`. -/ +@[reducible] +def equal : Language where + Func := fun _ => Empty + Rel := EqRel + +instance (k) : ToString (equal.Func k) := + ⟨fun _ => ""⟩ + +instance (k) : ToString (equal.Rel k) := + ⟨fun _ => "\\mathrm{Eq}"⟩ + +instance (k) : DecidableEq (equal.Func k) := fun a b => by rcases a + +instance (k) : DecidableEq (equal.Rel k) := fun a b => by rcases a; rcases b; exact isTrue (by simp) + +instance (k) : Encodable (equal.Func k) := + IsEmpty.toEncodable + +instance (k) : Encodable (equal.Rel k) + where + encode := fun _ => 0 + decode := fun _ => + match k with + | 2 => some EqRel.equal + | _ => none + encodek := fun x => by rcases x; simp + +namespace ORing + +/-- Data and laws for Func in `FFL.FirstOrder.Language.ORing`. -/ +inductive Func : ℕ → Type + | zero : Func 0 + | one : Func 0 + | add : Func 2 + | mul : Func 2 + +/-- Data and laws for Rel in `FFL.FirstOrder.Language.ORing`. -/ +inductive Rel : ℕ → Type + | eq : Rel 2 + | lt : Rel 2 + +end ORing + +/-- The ℒₒᵣ construction in `ℒₒᵣ`. -/ +@[reducible] +def oRing : Language where + Func := ORing.Func + Rel := ORing.Rel + +/-- The termℒₒᵣ construction in `FFL.FirstOrder.Language`. -/ +notation "ℒₒᵣ" => oRing + +namespace ORing + +instance (k) : ToString (oRing.Func k) := + ⟨fun s => + match s with + | Func.zero => "0" + | Func.one => "1" + | Func.add => "(+)" + | Func.mul => "(\\cdot)"⟩ + +instance (k) : ToString (oRing.Rel k) := + ⟨fun s => + match s with + | Rel.eq => "\\mathrm{Eq}" + | Rel.lt => "\\mathrm{LT}"⟩ + +instance (k) : DecidableEq (oRing.Func k) := fun a b => by + rcases a <;> rcases b <;> simp only [reduceCtorEq] <;> + try { exact instDecidableTrue + } <;> + try { exact instDecidableFalse + } + +instance (k) : DecidableEq (oRing.Rel k) := fun a b => by + rcases a <;> rcases b <;> simp only [reduceCtorEq] <;> + try { exact instDecidableTrue + } <;> + try { exact instDecidableFalse + } + +instance (k) : Encodable (oRing.Func k) + where + encode := fun x => + match x with + | Func.zero => 0 + | Func.one => 1 + | Func.add => 0 + | Func.mul => 1 + decode := fun e => + match k, e with + | 0, 0 => some Func.zero + | 0, 1 => some Func.one + | 2, 0 => some Func.add + | 2, 1 => some Func.mul + | _, _ => none + encodek := fun x => by rcases x <;> simp + +instance Func1IsEmpty : IsEmpty (oRing.Func 1) := + ⟨by rintro ⟨⟩⟩ + +lemma FuncGe3IsEmpty : ∀ k ≥ 3, IsEmpty (oRing.Func k) + | 0 => by simp + | 1 => by simp [show ¬3 ≤ 1 from of_decide_eq_false rfl] + | 2 => by simp [show ¬3 ≤ 2 from of_decide_eq_false rfl] + | (n + 3) => fun _ => ⟨by rintro ⟨⟩⟩ + +instance (k) : Encodable (oRing.Rel k) + where + encode := fun x => + match x with + | Rel.eq => 0 + | Rel.lt => 1 + decode := fun e => + match k, e with + | 2, 0 => some Rel.eq + | 2, 1 => some Rel.lt + | _, _ => none + encodek := fun x => by rcases x <;> simp + +/-- The func Equiv Fin Four construction in `FFL.FirstOrder.Language.ORing`. -/ +def funcEquivFinFour : (k : ℕ) × oRing.Func k ≃ Fin 4 + where + toFun + f := + match f with + | ⟨0, Func.zero⟩ => 0 + | ⟨0, Func.one⟩ => 1 + | ⟨2, Func.add⟩ => 2 + | ⟨2, Func.mul⟩ => 3 + invFun + x := + match x with + | 0 => ⟨0, Func.zero⟩ + | 1 => ⟨0, Func.one⟩ + | 2 => ⟨2, Func.add⟩ + | 3 => ⟨2, Func.mul⟩ + left_inv + f := + match f with + | ⟨0, Func.zero⟩ => rfl + | ⟨0, Func.one⟩ => rfl + | ⟨2, Func.add⟩ => rfl + | ⟨2, Func.mul⟩ => rfl + right_inv + x := + match x with + | 0 => rfl + | 1 => rfl + | 2 => rfl + | 3 => rfl + +/-- The rel Equiv Fin Two construction in `FFL.FirstOrder.Language.ORing`. -/ +def relEquivFinTwo : (k : ℕ) × oRing.Rel k ≃ Fin 2 + where + toFun + f := + match f with + | ⟨2, Rel.eq⟩ => 0 + | ⟨2, Rel.lt⟩ => 1 + invFun + x := + match x with + | 0 => ⟨2, Rel.eq⟩ + | 1 => ⟨2, Rel.lt⟩ + left_inv + f := + match f with + | ⟨2, Rel.eq⟩ => rfl + | ⟨2, Rel.lt⟩ => rfl + right_inv + x := + match x with + | 0 => rfl + | 1 => rfl + +end ORing + +namespace Constant + +variable (C : Type*) + +/-- Data and laws for Func in `FFL.FirstOrder.Language.Constant`. -/ +inductive Func : ℕ → Type _ + | const (c : C) : Func 0 + +end Constant + +section Constant + +variable (C : Type*) + +/-- The of Constants construction in `FFL.FirstOrder.Language`. -/ +def ofConstants : Language := ⟨Constant.Func C, fun _ => PEmpty⟩ + +--instance : Coe (Type*) Language := ⟨ofConstants⟩ + +instance : Coe C ((ofConstants C).Func 0) := + ⟨Constant.Func.const⟩ + +instance : IsConstant (ofConstants C) + where + func_empty := fun k => ⟨by rintro ⟨⟩⟩ + rel_empty := fun k => ⟨by rintro ⟨⟩⟩ + +/-- The unit construction in `FFL.FirstOrder.Language`. -/ +abbrev unit : Language := + ofConstants PUnit + +end Constant + +/-- The of Func construction in `FFL.FirstOrder.Language`. -/ +def ofFunc (F : ℕ → Type v) : Language := + ⟨F, fun _ => PEmpty⟩ + +/-- The add construction in `FFL.FirstOrder.Language`. -/ +def add (L₁ : Language.{u₁}) (L₂ : Language.{u₂}) : Language := + ⟨fun k => L₁.Func k ⊕ L₂.Func k, fun k => L₁.Rel k ⊕ L₂.Rel k⟩ + +instance : _root_.Add Language := + ⟨add⟩ + +/-- The sigma construction in `FFL.FirstOrder.Language`. -/ +def sigma (L : ι → Language) : Language := + ⟨fun k => Σ i, (L i).Func k, fun k => Σ i, (L i).Rel k⟩ + +/-- Data and laws for Eq in `FFL.FirstOrder.Language`. -/ +protected class Eq (L : Language) where + /-- The eq construction in `FFL.FirstOrder.Language.Eq`. -/ + eq : L.Rel 2 + +/-- Data and laws for LT in `FFL.FirstOrder.Language`. -/ +protected class LT (L : Language) where + /-- The lt construction in `FFL.FirstOrder.Language.LT`. -/ + lt : L.Rel 2 + +/-- Data and laws for Mem in `FFL.FirstOrder.Language`. -/ +protected class Mem (L : Language) where + /-- The mem construction in `FFL.FirstOrder.Language.Mem`. -/ + mem : L.Rel 2 + +/-- Data and laws for Zero in `FFL.FirstOrder.Language`. -/ +protected class Zero (L : Language) where + /-- The zero construction in `FFL.FirstOrder.Language.Zero`. -/ + zero : L.Func 0 + +/-- Data and laws for One in `FFL.FirstOrder.Language`. -/ +protected class One (L : Language) where + /-- The one construction in `FFL.FirstOrder.Language.One`. -/ + one : L.Func 0 + +/-- Data and laws for Add in `FFL.FirstOrder.Language`. -/ +protected class Add (L : Language) where + /-- The add construction in `FFL.FirstOrder.Language.Add`. -/ + add : L.Func 2 + +/-- Data and laws for Mul in `FFL.FirstOrder.Language`. -/ +protected class Mul (L : Language) where + /-- The mul construction in `FFL.FirstOrder.Language.Mul`. -/ + mul : L.Func 2 + +/-- Data and laws for Pow in `FFL.FirstOrder.Language`. -/ +protected class Pow (L : Language) where + /-- The pow construction in `FFL.FirstOrder.Language.Pow`. -/ + pow : L.Func 2 + +/-- Data and laws for Exp in `FFL.FirstOrder.Language`. -/ +protected class Exp (L : Language) where + /-- The exp construction in `FFL.FirstOrder.Language.Exp`. -/ + exp : L.Func 1 + +/-- Data and laws for Pairing in `FFL.FirstOrder.Language`. -/ +class Pairing (L : Language) where + /-- The pair construction in `FFL.FirstOrder.Language.Pairing`. -/ + pair : L.Func 2 + +/-- Data and laws for Star in `FFL.FirstOrder.Language`. -/ +class Star (L : Language) where + /-- The star construction in `FFL.FirstOrder.Language.Star`. -/ + star : L.Func 0 + +attribute [match_pattern] Zero.zero One.one Add.add Mul.mul Exp.exp Eq.eq LT.lt Mem.mem + Star.star + +/-- Data and laws for ORing in `FFL.FirstOrder.Language`. -/ +class ORing (L : Language) extends L.Eq, L.LT, L.Zero, L.One, L.Add, L.Mul + +instance : ORing oRing where + eq := .eq + lt := .lt + zero := .zero + one := .one + add := .add + mul := .mul + +instance : ConstantInhabited ℒₒᵣ where default := Language.Zero.zero + +instance : Star unit where star := () + +instance (L : Language) (S : Language) [Star S] : Star (L.add S) where star := Sum.inr Star.star + +instance (L : Language) (S : Language) [L.Zero] : (L.add S).Zero where zero := Sum.inl Zero.zero + +instance (L : Language) (S : Language) [L.One] : (L.add S).One where one := Sum.inl One.one + +instance (L : Language) (S : Language) [L.Add] : (L.add S).Add where add := Sum.inl Add.add + +instance (L : Language) (S : Language) [L.Mul] : (L.add S).Mul where mul := Sum.inl Mul.mul + +instance (L : Language) (S : Language) [L.Eq] : (L.add S).Eq where eq := Sum.inl Eq.eq + +instance (L : Language) (S : Language) [L.LT] : (L.add S).LT where lt := Sum.inl LT.lt + +/-- Data and laws for Hom in `FFL.FirstOrder.Language`. -/ +@[ext] +structure Hom (L₁ L₂ : Language) where + /-- The func construction in `FFL.FirstOrder.Language.Hom`. -/ + func : {k : ℕ} → L₁.Func k → L₂.Func k + /-- The rel construction in `FFL.FirstOrder.Language.Hom`. -/ + rel : {k : ℕ} → L₁.Rel k → L₂.Rel k + +/-- +A structure for the homomorphisms (respecting function and relation symbols) between first-order +languages. +-/ +scoped[PointwiseComposition.FFL.FirstOrder] + infix:25 " →ᵥ " => PointwiseComposition.FFL.FirstOrder.Language.Hom + +namespace Hom +variable (L L₁ L₂ L₃ : Language) (Φ : Hom L₁ L₂) + +/-- The id construction in `FFL.FirstOrder.Language.Hom`. -/ +protected def id : L →ᵥ L where + func := id + rel := id + +variable {L L₁ L₂ L₃} + +/-- The comp construction in `FFL.FirstOrder.Language.Hom`. -/ +def comp (Ψ : L₂ →ᵥ L₃) (Φ : L₁ →ᵥ L₂) : L₁ →ᵥ L₃ + where + func := Ψ.func ∘ Φ.func + rel := Ψ.rel ∘ Φ.rel + +/-- The add₁ construction in `FFL.FirstOrder.Language.Hom`. -/ +def add₁ (L₁ : Language) (L₂ : Language) : L₁ →ᵥ L₁.add L₂ := + ⟨Sum.inl, Sum.inl⟩ + +/-- The add₂ construction in `FFL.FirstOrder.Language.Hom`. -/ +def add₂ (L₁ : Language) (L₂ : Language) : L₂ →ᵥ L₁.add L₂ := + ⟨Sum.inr, Sum.inr⟩ + +lemma func_add₁ (L₁ : Language) (L₂ : Language) (f : L₁.Func k) : + (add₁ L₁ L₂).func f = Sum.inl f := + rfl + +lemma rel_add₁ (L₁ : Language) (L₂ : Language) (r : L₁.Rel k) : + (add₁ L₁ L₂).rel r = Sum.inl r := + rfl + +lemma func_add₂ (L₁ : Language) (L₂ : Language) (f : L₂.Func k) : + (add₂ L₁ L₂).func f = Sum.inr f := + rfl + +lemma rel_add₂ (L₁ : Language) (L₂ : Language) (r : L₂.Rel k) : + (add₂ L₁ L₂).rel r = Sum.inr r := + rfl + +@[simp] +lemma add₂_star (L₁ : Language) (L₂ : Language) [Star L₂] : + (add₂ L₁ L₂).func Star.star = Star.star := + rfl + +@[simp] +lemma add₁_zero (L₁ : Language) (L₂ : Language) [L₁.Zero] : + (add₁ L₁ L₂).func Zero.zero = Zero.zero := + rfl + +@[simp] +lemma add₁_one (L₁ : Language) (L₂ : Language) [L₁.One] : (add₁ L₁ L₂).func One.one = One.one := + rfl + +@[simp] +lemma add₁_add (L₁ : Language) (L₂ : Language) [L₁.Add] : (add₁ L₁ L₂).func Add.add = Add.add := + rfl + +@[simp] +lemma add₁_mul (L₁ : Language) (L₂ : Language) [L₁.Mul] : (add₁ L₁ L₂).func Mul.mul = Mul.mul := + rfl + +@[simp] +lemma add₁_eq (L₁ : Language) (L₂ : Language) [L₁.Eq] : (add₁ L₁ L₂).rel Eq.eq = Eq.eq := + rfl + +@[simp] +lemma add₁_lt (L₁ : Language) (L₂ : Language) [L₁.LT] : (add₁ L₁ L₂).rel LT.lt = LT.lt := + rfl + +/-- The sigma construction in `FFL.FirstOrder.Language.Hom`. -/ +def sigma (L : ι → Language) (i : ι) : L i →ᵥ Language.sigma L := + ⟨fun f => ⟨i, f⟩, fun r => ⟨i, r⟩⟩ + +lemma func_sigma (L : ι → Language) (i : ι) (f : (L i).Func k) : (sigma L i).func f = ⟨i, f⟩ := + rfl + +lemma rel_sigma (L : ι → Language) (i : ι) (r : (L i).Rel k) : (sigma L i).rel r = ⟨i, r⟩ := + rfl + +end Hom + +/-- The embedding construction in `FFL.FirstOrder.Language.ORing`. -/ +def ORing.embedding (L : Language) [ORing L] : ℒₒᵣ →ᵥ L + where + func := fun {n} f ↦ + match n, f with + | 0, Zero.zero => Zero.zero + | 0, One.one => One.one + | 2, Add.add => Add.add + | 2, Mul.mul => Mul.mul + rel := fun {n} r ↦ + match n, r with + | 2, Eq.eq => Eq.eq + | 2, LT.lt => LT.lt +end Language + +/-- Data and laws for Decidable Eq in `FFL.FirstOrder.Language`. -/ +protected class Language.DecidableEq (L : Language) where + /-- The func construction in `FFL.FirstOrder.Language.DecidableEq`. -/ + func : (k : ℕ) → DecidableEq (L.Func k) + /-- The rel construction in `FFL.FirstOrder.Language.DecidableEq`. -/ + rel : (k : ℕ) → DecidableEq (L.Rel k) + +instance (L : Language) [(k : ℕ) → DecidableEq (L.Func k)] [(k : ℕ) → DecidableEq (L.Rel k)] : + L.DecidableEq := + ⟨fun _ ↦ inferInstance, fun _ ↦ inferInstance⟩ + +instance (L : Language) [L.DecidableEq] (k : ℕ) : DecidableEq (L.Func k) := + Language.DecidableEq.func k + +instance (L : Language) [L.DecidableEq] (k : ℕ) : DecidableEq (L.Rel k) := + Language.DecidableEq.rel k + +instance (L : Language) [L.DecidableEq] (k : ℕ) : DecidableEq (L.Rel k) := + Language.DecidableEq.rel k + +/-- Data and laws for Encodable in `FFL.FirstOrder.Language`. -/ +protected class Language.Encodable (L : Language) where + /-- The func construction in `FFL.FirstOrder.Language.Encodable`. -/ + func : (k : ℕ) → Encodable (L.Func k) + /-- The rel construction in `FFL.FirstOrder.Language.Encodable`. -/ + rel : (k : ℕ) → Encodable (L.Rel k) + +instance (L : Language) [(k : ℕ) → Encodable (L.Func k)] [(k : ℕ) → Encodable (L.Rel k)] : + L.Encodable := + ⟨fun _ ↦ inferInstance, fun _ ↦ inferInstance⟩ + +instance (L : Language) [L.Encodable] (k : ℕ) : Encodable (L.Func k) := + Language.Encodable.func k + +instance (L : Language) [L.Encodable] (k : ℕ) : Encodable (L.Rel k) := + Language.Encodable.rel k + +instance (L : Language) [L.Encodable] (k : ℕ) : Encodable (L.Rel k) := + Language.Encodable.rel k + +/-- Data and laws for Finite in `FFL.FirstOrder.Language`. -/ +class Language.Finite (L : Language) where + /-- The func construction in `FFL.FirstOrder.Language.Finite`. -/ + func : Fintype ((k : ℕ) × L.Func k) + /-- The rel construction in `FFL.FirstOrder.Language.Finite`. -/ + rel : Fintype ((k : ℕ) × L.Rel k) + +instance : Language.Finite ℒₒᵣ + where + func := Fintype.ofEquiv (Fin 4) Language.ORing.funcEquivFinFour.symm + rel := Fintype.ofEquiv (Fin 2) Language.ORing.relEquivFinTwo.symm + +end FirstOrder + +end FFL +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/Syntax/Predicate/Quantifier.lean b/LeanPool/PointwiseComposition/Foundation/Syntax/Predicate/Quantifier.lean new file mode 100644 index 000000000..fb27a1a79 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/Syntax/Predicate/Quantifier.lean @@ -0,0 +1,487 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.Logic.LogicSymbol + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace FFL + +/-- Data and laws for Polarity in `FFL`. -/ +inductive Polarity where + | sigma + | pi + +namespace Polarity + +instance : SigmaSymbol Polarity := + ⟨sigma⟩ + +instance : PiSymbol Polarity := + ⟨pi⟩ + +/-- The alt construction in `FFL.Polarity`. -/ +def alt : Polarity → Polarity + | Σ => Π + | Π => Σ + +lemma eq_sigma : sigma = Σ := + rfl + +lemma eq_pi : pi = Π := + rfl + +@[simp] +lemma alt_sigma : alt Σ = Π := + rfl + +@[simp] +lemma alt_pi : alt Π = Σ := + rfl + +@[simp] +lemma alt_alt (Γ : Polarity) : Γ.alt.alt = Γ := by cases Γ <;> rfl + +/-- `Γ` with its polarity flipped `k` times. -/ +abbrev altItr (Γ : Polarity) (k : ℕ) : Polarity := + Polarity.alt^[k] Γ + +@[simp] +lemma altItr_zero (Γ : Polarity) : Γ.altItr 0 = Γ := + rfl + +lemma altItr_succ (Γ : Polarity) (k : ℕ) : Γ.altItr (k + 1) = (Γ.altItr k).alt := + Function.iterate_succ_apply' _ _ _ + +lemma altItr_succ' (Γ : Polarity) (k : ℕ) : Γ.altItr (k + 1) = Γ.alt.altItr k := + Function.iterate_succ_apply _ _ _ + +section symbol + +variable {α : Type*} [SigmaSymbol α] [PiSymbol α] + +/-- The coe construction in `FFL.Polarity`. -/ +protected def coe : Polarity → α + | Σ => Σ + | Π => Π + +instance : Coe Polarity α := + ⟨Polarity.coe⟩ + +@[simp] +lemma coe_sigma : ((Σ : Polarity) : α) = Σ := + rfl + +@[simp] +lemma coe_pi : ((Π : Polarity) : α) = Π := + rfl + +end symbol + +end Polarity + +/-- Data and laws for Sigma Pi Delta in `FFL`. -/ +inductive SigmaPiDelta where + | sigma + | pi + | delta + +namespace SigmaPiDelta + +instance : SigmaSymbol SigmaPiDelta := + ⟨sigma⟩ + +instance : PiSymbol SigmaPiDelta := + ⟨pi⟩ + +instance : DeltaSymbol SigmaPiDelta := + ⟨delta⟩ + +/-- The alt construction in `FFL.SigmaPiDelta`. -/ +def alt : SigmaPiDelta → SigmaPiDelta + | Σ => Π + | Π => Σ + | ∆ => ∆ + +lemma eq_sigma : sigma = Σ := + rfl + +lemma eq_pi : pi = Π := + rfl + +lemma eq_delta : delta = ∆ := + rfl + +@[simp] +lemma alt_sigma : alt Σ = Π := + rfl + +@[simp] +lemma alt_pi : alt Π = Σ := + rfl + +@[simp] +lemma alt_delta : alt ∆ = ∆ := + rfl + +@[simp] +lemma alt_alt (Γ : SigmaPiDelta) : Γ.alt.alt = Γ := by cases Γ <;> rfl + +@[simp] +lemma alt_coe (Γ : Polarity) : SigmaPiDelta.alt Γ = (Γ.alt : SigmaPiDelta) := by cases Γ <;> rfl + +end SigmaPiDelta + +/-! +## First-order quantifiers -/ + +namespace FirstOrder + +/-- Data and laws for Univ Quantifier in `FFL.FirstOrder`. -/ +class UnivQuantifier (α : ℕ → Type*) where + /-- The all construction in `FFL.FirstOrder.UnivQuantifier`. -/ + all : α (n + 1) → α n + +/-- The «term∀¹ » construction in `FFL.FirstOrder`. -/ +prefix:64 "∀¹ " => UnivQuantifier.all + +/-- Data and laws for Exs Quantifier in `FFL.FirstOrder`. -/ +class ExsQuantifier (α : ℕ → Type*) where + /-- The exs construction in `FFL.FirstOrder.ExsQuantifier`. -/ + exs : α (n + 1) → α n + +/-- The «term∃¹ » construction in `FFL.FirstOrder`. -/ +prefix:64 "∃¹ " => ExsQuantifier.exs + +attribute [match_pattern] UnivQuantifier.all ExsQuantifier.exs + +/-- Data and laws for Quantifier in `FFL.FirstOrder`. -/ +class Quantifier (α : ℕ → Type*) extends UnivQuantifier α, ExsQuantifier α + +/-- Logical Connectives with Quantifiers. -/ +class LCWQ (α : ℕ → Type*) extends Quantifier α where + /-- The connectives construction in `FFL.FirstOrder.LCWQ`. -/ + connectives : (n : ℕ) → LogicalConnective (α n) + /-- The neutrals construction in `FFL.FirstOrder.LCWQ`. -/ + neutrals : (n : ℕ) → LogicalNeutral (α n) + +instance (α : ℕ → Type*) [LCWQ α] (n : ℕ) : LogicalConnective (α n) := + LCWQ.connectives n + +instance (α : ℕ → Type*) [LCWQ α] (n : ℕ) : LogicalNeutral (α n) := + LCWQ.neutrals n + +instance (α : ℕ → Type*) [Quantifier α] [(n : ℕ) → LogicalConnective (α n)] + [(n : ℕ) → LogicalNeutral (α n)] : LCWQ α + where + connectives := inferInstance + neutrals := inferInstance + +section UnivQuantifier + +variable {α : ℕ → Type*} [UnivQuantifier α] + +/-- The all Closure construction in `FFL.FirstOrder`. -/ +def allClosure : {n : ℕ} → α n → α 0 + | 0, a => a + | _ + 1, a => allClosure (∀¹ a) + +/-- The universal closure of a formula. +-/ +prefix:64 "∀¹* " => allClosure + +@[simp] +lemma allClosure_zero (a : α 0) : ∀¹* a = a := + rfl + +lemma allClosure_succ {n} (a : α (n + 1)) : ∀¹* a = ∀¹* ∀¹ a := + rfl + +/-- The all Itr construction in `FFL.FirstOrder`. -/ +def allItr : (k : ℕ) → α (n + k) → α n + | 0, a => a + | k + 1, a => allItr k (∀¹ a) + +/-- The «term∀¹^[ ] » construction in `FFL.FirstOrder`. -/ +notation "∀¹^[" k "] " φ:64 => allItr k φ + +@[simp] +lemma allItr_zero (a : α n) : ∀¹^[0] a = a := + rfl + +@[simp] +lemma allItr_one (a : α (n + 1)) : ∀¹^[1] a = ∀¹ a := + rfl + +lemma allItr_succ {k} (a : α (n + (k + 1))) : ∀¹^[k + 1] a = ∀¹^[k] (∀¹ a) := + rfl + +end UnivQuantifier + +section ExsQuantifier + +variable {α : ℕ → Type*} [ExsQuantifier α] + +/-- The exs Closure construction in `FFL.FirstOrder`. -/ +def exsClosure : {n : ℕ} → α n → α 0 + | 0, a => a + | _ + 1, a => exsClosure (∃¹ a) + +/-- The existential closure of a formula. +-/ +prefix:64 "∃¹* " => exsClosure + +@[simp] +lemma exsClosure_zero (a : α 0) : ∃¹* a = a := + rfl + +lemma exsClosure_succ {n} (a : α (n + 1)) : ∃¹* a = ∃¹* ∃¹ a := + rfl + +/-- The exs Itr construction in `FFL.FirstOrder`. -/ +def exsItr : (k : ℕ) → α (n + k) → α n + | 0, a => a + | k + 1, a => exsItr k (∃¹ a) + +/-- Iterated application of `k` existential quantifiers. -/ +notation "∃¹^[" k "] " φ:64 => exsItr k φ + +@[simp] +lemma exsItr_zero (a : α n) : ∃¹^[0] a = a := + rfl + +@[simp] +lemma exsItr_one (a : α (n + 1)) : ∃¹^[1] a = ∃¹ a := + rfl + +lemma exsItr_succ {k} (a : α (n + (k + 1))) : ∃¹^[k + 1] a = ∃¹^[k] (∃¹ a) := + rfl + +end ExsQuantifier + +section quantifier + +variable {α : ℕ → Type*} + +/-- The ball construction in `FFL.FirstOrder`. -/ +def ball [UnivQuantifier α] [Arrow (α (n + 1))] (φ : α (n + 1)) (ψ : α (n + 1)) : α n := + ∀¹ (φ ⇒ₗ ψ) + +/-- The bexs construction in `FFL.FirstOrder`. -/ +def bexs [ExsQuantifier α] [Wedge (α (n + 1))] (φ : α (n + 1)) (ψ : α (n + 1)) : α n := + ∃¹ (φ ⋏ ψ) + +/-- A bounded universal quantifier. `∀¹[φ] ψ` is defined as `∀¹ (φ ⇒ₗ ψ)`. -/ +notation:64 "∀¹[" φ "] " ψ => ball φ ψ + +/-- A bounded existential quantifier. `∃¹[φ] ψ` is defined as `∃¹ (φ ⋏ ψ)`. -/ +notation:64 "∃¹[" φ "] " ψ => bexs φ ψ + +end quantifier + +end FirstOrder + +namespace Polarity + +variable {α : ℕ → Type*} [FirstOrder.UnivQuantifier α] [FirstOrder.ExsQuantifier α] {n : ℕ} + {Γ : Polarity} + +/-- The quant construction in `FFL.Polarity`. -/ +def quant : Polarity → α (n + 1) → α n + | Σ => FirstOrder.ExsQuantifier.exs + | Π => FirstOrder.UnivQuantifier.all + +@[simp] +lemma quant_sigma (φ : α (n + 1)) : (Σ : Polarity).quant φ = ∃¹ φ := + rfl + +@[simp] +lemma quant_pi (φ : α (n + 1)) : (Π : Polarity).quant φ = ∀¹ φ := + rfl + +/-- Prefixes `k` alternating quantifiers starting with `Γ`. -/ +def quantItr (Γ : Polarity) : (k : ℕ) → {n : ℕ} → α (n + k) → α n + | 0, n, φ => φ + | k + 1, n, φ => Γ.quant <| quantItr Γ.alt k (cast (by grind) φ) + +@[simp] +lemma quantItr_zero (φ : α n) : quantItr Γ 0 φ = φ := + rfl + +@[simp] +lemma quantItr_one (φ : α (n + 1)) : quantItr Γ 1 φ = Γ.quant φ := + rfl + +lemma quantItr_succ {k} (φ : α (n + (k + 1))) : + quantItr Γ (k + 1) φ = Γ.quant (quantItr Γ.alt k (cast (by grind) φ)) := + rfl + +lemma cast_quant {m₁ m₂ : ℕ} (h : m₁ = m₂) (Γ : Polarity) (φ : α (m₁ + 1)) : + cast (congrArg α h) (Γ.quant φ) = Γ.quant (cast (by grind) φ) := by subst h; rfl + +lemma quantItr_succ' {k} (φ : α (n + (k + 1))) : + quantItr Γ (k + 1) φ = quantItr Γ k ((Γ.altItr k).quant φ) := by + induction k generalizing n Γ with + | zero => simp [quantItr_one]; + | succ k ih => + rw [quantItr_succ, ih, quantItr_succ, altItr_succ'] + congr 2; grind; + +end Polarity + +/-! +## Second-order quantifiers -/ + +namespace SecondOrder + +/-- Data and laws for Univ Quantifier in `FFL.SecondOrder`. -/ +class UnivQuantifier (α : ℕ → ℕ → Type*) where + /-- The all₁ construction in `FFL.SecondOrder.UnivQuantifier`. -/ + all₁ : α (m + 1) n → α m n + +/-- The «term∀² » construction in `FFL.SecondOrder`. -/ +prefix:64 "∀² " => UnivQuantifier.all₁ + +/-- Data and laws for Exs Quantifier in `FFL.SecondOrder`. -/ +class ExsQuantifier (α : ℕ → ℕ → Type*) where + /-- The exs₁ construction in `FFL.SecondOrder.ExsQuantifier`. -/ + exs₁ : α (m + 1) n → α m n + +/-- The «term∃² » construction in `FFL.SecondOrder`. -/ +prefix:64 "∃² " => ExsQuantifier.exs₁ + +attribute [match_pattern] UnivQuantifier.all₁ ExsQuantifier.exs₁ + +/-- Data and laws for Quantifier in `FFL.SecondOrder`. -/ +class Quantifier (α : ℕ → ℕ → Type*) extends UnivQuantifier α, ExsQuantifier α + +/-- Logical Connectives with Quantifiers. -/ +class LCWQ (α : ℕ → ℕ → Type*) extends Quantifier α where + /-- The first Order construction in `FFL.SecondOrder.LCWQ`. -/ + firstOrder : (m : ℕ) → FirstOrder.LCWQ (α m) + +instance (α : ℕ → ℕ → Type*) [LCWQ α] (m : ℕ) : FirstOrder.LCWQ (α m) := + LCWQ.firstOrder m + +instance (α : ℕ → ℕ → Type*) [Quantifier α] [(m : ℕ) → FirstOrder.LCWQ (α m)] : LCWQ α where + firstOrder := inferInstance + +section UnivQuantifier + +variable {α : ℕ → ℕ → Type*} [UnivQuantifier α] + +/-- The all Closure construction in `FFL.SecondOrder`. -/ +def allClosure : {m : ℕ} → α m n → α 0 n + | 0, a => a + | _ + 1, a => allClosure (∀² a) + +/-- The «term∀²* » construction in `FFL.SecondOrder`. -/ +prefix:64 "∀²* " => allClosure + +@[simp] +lemma allClosure_zero (a : α 0 n) : ∀²* a = a := + rfl + +lemma allClosure_succ {n} (a : α (n + 1) n) : ∀²* a = ∀²* ∀² a := + rfl + +/-- The all Itr construction in `FFL.SecondOrder`. -/ +def allItr : (k : ℕ) → α (m + k) n → α m n + | 0, a => a + | k + 1, a => allItr k (∀² a) + +/-- The «term∀²^[ ] » construction in `FFL.SecondOrder`. -/ +notation "∀²^[" k "] " φ:64 => allItr k φ + +@[simp] +lemma allItr_zero (a : α m n) : ∀²^[0] a = a := + rfl + +@[simp] +lemma allItr_one (a : α (m + 1) n) : ∀²^[1] a = ∀² a := + rfl + +lemma allItr_succ {k} (a : α (m + (k + 1)) n) : ∀²^[k + 1] a = ∀²^[k] (∀² a) := + rfl + +end UnivQuantifier + +section ExsQuantifier + +variable {α : ℕ → ℕ → Type*} [ExsQuantifier α] + +/-- The exs Closure construction in `FFL.SecondOrder`. -/ +def exsClosure : {m : ℕ} → α m n → α 0 n + | 0, a => a + | _ + 1, a => exsClosure (∃² a) + +/-- The «term∃²* » construction in `FFL.SecondOrder`. -/ +prefix:64 "∃²* " => exsClosure + +@[simp] +lemma exsClosure_zero (a : α 0 n) : ∃²* a = a := + rfl + +lemma exsClosure_succ {n} (a : α (m + 1) n) : ∃²* a = ∃²* ∃² a := + rfl + +/-- The exs Itr construction in `FFL.SecondOrder`. -/ +def exsItr : (k : ℕ) → α (m + k) n → α m n + | 0, a => a + | k + 1, a => exsItr k (∃² a) + +/-- The «term∃²^[ ] » construction in `FFL.SecondOrder`. -/ +notation "∃²^[" k "] " φ:64 => exsItr k φ + +@[simp] +lemma exsItr_zero (a : α m n) : ∃²^[0] a = a := + rfl + +@[simp] +lemma exsItr_one (a : α (m + 1) n) : ∃²^[1] a = ∃² a := + rfl + +lemma exsItr_succ {k} (a : α (m + (k + 1)) n) : ∃²^[k + 1] a = ∃²^[k] (∃² a) := + rfl + +end ExsQuantifier + +section quantifier + +variable {α : ℕ → ℕ → Type*} + +/-- The ball construction in `FFL.SecondOrder`. -/ +def ball [UnivQuantifier α] [Arrow (α (m + 1) n)] (φ : α (m + 1) n) (ψ : α (m + 1) n) : α m n := + ∀² (φ ⇒ₗ ψ) + +/-- The bexs construction in `FFL.SecondOrder`. -/ +def bexs [ExsQuantifier α] [Wedge (α (m + 1) n)] (φ : α (m + 1) n) (ψ : α (m + 1) n) : α m n := + ∃² (φ ⋏ ψ) + +/-- The «term∀²[ ] » construction in `FFL.SecondOrder`. -/ +notation:64 "∀²[" φ "] " ψ => ball φ ψ + +/-- The «term∃²[ ] » construction in `FFL.SecondOrder`. -/ +notation:64 "∃²[" φ "] " ψ => bexs φ ψ + +end quantifier + +end SecondOrder + +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/Syntax/Predicate/Rew.lean b/LeanPool/PointwiseComposition/Foundation/Syntax/Predicate/Rew.lean new file mode 100644 index 000000000..88fdabe2b --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/Syntax/Predicate/Rew.lean @@ -0,0 +1,1445 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.Syntax.Predicate.Quantifier +public import LeanPool.PointwiseComposition.Foundation.Syntax.Predicate.Term +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Function +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Multiset + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# Rewriting + +term/formula morphisms such as rewritings, substitutions, and embeddings are handled by the +structure `FFL.FirstOrder.Rew`. +- `FFL.FirstOrder.Rew.rewrite f` is a rewriting of the free variables occurring in a term by `f +: ξ₁ → Semiterm L ξ₂ n`. +- `FFL.FirstOrder.Rew.subst v` is a substitution of the bounded variables occurring in a term by +`v : Fin n → Semiterm L ξ n'`. +- `FFL.FirstOrder.Rew.bShift` is a transformation of the bounded variables occurring in a term +by `#x ↦ #(Fin.succ x)`. +- `FFL.FirstOrder.Rew.shift` is a transformation of the free variables occurring in a term by +`&x ↦ &(x + 1)`. +- `FFL.FirstOrder.Rew.emb` is a embedding of a term with no free variables. + +Rewritings `FFL.FirstOrder.Rew` is naturally converted to formula rewritings by +`FFL.FirstOrder.Rew.hom`. + +-/ + +@[expose] public section + +namespace FFL + +namespace FirstOrder + +/-- A structure for maps which rewrite the semiterms occurring in a term. + +toFun - A function from `Semiterm L ξ₁ n₁` to `Semiterm L ξ₂ n₂`. + +func'' - A proof that `toFun` respects the function symbols of `L`. +-/ +structure Rew (L : Language) (ξ₁ : Type*) (n₁ : ℕ) (ξ₂ : Type*) (n₂ : ℕ) where + /-- The to Fun construction in `FFL.FirstOrder.Rew`. -/ + toFun : Semiterm L ξ₁ n₁ → Semiterm L ξ₂ n₂ + func'' (f : L.Func k) (v : Fin k → Semiterm L ξ₁ n₁) : + toFun (Semiterm.func f v) = Semiterm.func f fun i ↦ toFun (v i) + +/-- The Syntactic Rew construction in `FFL.FirstOrder`. -/ +abbrev SyntacticRew (L : Language) (n₁ n₂ : ℕ) := + Rew L ℕ n₁ ℕ n₂ + +namespace Rew + +open Semiterm + +variable {L L' L₁ L₂ L₃ : Language} {ξ ξ' ξ₁ ξ₂ ξ₃ : Type*} {n n₁ n₂ n₃ : ℕ} + +variable (ω : Rew L ξ₁ n₁ ξ₂ n₂) + +instance : FunLike (Rew L ξ₁ n₁ ξ₂ n₂) (Semiterm L ξ₁ n₁) (Semiterm L ξ₂ n₂) + where + coe := fun f => f.toFun + coe_injective := fun f g h => by rcases f; rcases g; simpa using h + +instance : CoeFun (Rew L ξ₁ n₁ ξ₂ n₂) (fun _ => Semiterm L ξ₁ n₁ → Semiterm L ξ₂ n₂) := + DFunLike.toCoeFun + +@[simp] +protected lemma func {k} (f : L.Func k) (v : Fin k → Semiterm L ξ₁ n₁) : + ω (func f v) = func f (ω ∘ v) := + ω.func'' f v + +lemma func' {k} (f : L.Func k) (v : Fin k → Semiterm L ξ₁ n₁) : + ω (func f v) = func f fun i ↦ ω (v i) := + ω.func'' f v + +@[ext] +lemma ext (ω₁ ω₂ : Rew L ξ₁ n₁ ξ₂ n₂) (hb : ∀ x, ω₁ #x = ω₂ #x) (hf : ∀ x, ω₁ &x = ω₂ &x) : + ω₁ = ω₂ := by + apply DFunLike.ext ω₁ ω₂; intro t + induction t <;> simp [*, ω₁.func, ω₂.func, Function.comp_def] + +lemma ext' {ω₁ ω₂ : Rew L ξ₁ n₁ ξ₂ n₂} (h : ω₁ = ω₂) (t) : ω₁ t = ω₂ t := by simp [h] + +/-- The id construction in `FFL.FirstOrder.Rew`. -/ +protected def id : Rew L ξ n ξ n where + toFun := id + func'' := fun _ _ => rfl + +@[simp] +lemma id_app (t : Semiterm L ξ n) : Rew.id t = t := + rfl + +/-- The comp construction in `FFL.FirstOrder.Rew`. -/ +protected def comp (ω₂ : Rew L ξ₂ n₂ ξ₃ n₃) (ω₁ : Rew L ξ₁ n₁ ξ₂ n₂) : Rew L ξ₁ n₁ ξ₃ n₃ + where + toFun := fun t => ω₂ (ω₁ t) + func'' := fun f v => by simp; rfl + +lemma comp_app (ω₂ : Rew L ξ₂ n₂ ξ₃ n₃) (ω₁ : Rew L ξ₁ n₁ ξ₂ n₂) (t : Semiterm L ξ₁ n₁) : + (ω₂.comp ω₁) t = ω₂ (ω₁ t) := + rfl + +@[simp] +lemma id_comp (ω : Rew L ξ₁ n₁ ξ₂ n₂) : Rew.id.comp ω = ω := by ext <;> simp [comp_app] + +@[simp] +lemma comp_id (ω : Rew L ξ₁ n₁ ξ₂ n₂) : ω.comp Rew.id = ω := by ext <;> simp [comp_app] + +/-- The bind Aux construction in `FFL.FirstOrder.Rew`. -/ +def bindAux (b : Fin n₁ → Semiterm L ξ₂ n₂) (e : ξ₁ → Semiterm L ξ₂ n₂) : + Semiterm L ξ₁ n₁ → Semiterm L ξ₂ n₂ + | #x => b x + | &x => e x + | func f v => func f (fun i => bindAux b e (v i)) + +/-- +`FFL.FirstOrder.Rew.bind f` is a substitution of the bound variables occurring in a term by `b : +Fin n₁ → Semiterm L ξ₂ n₂`, and the free variables occurring in a term by `e : ξ₁ → Semiterm L +ξ₂ n₂`. -/ +def bind (b : Fin n₁ → Semiterm L ξ₂ n₂) (e : ξ₁ → Semiterm L ξ₂ n₂) : Rew L ξ₁ n₁ ξ₂ n₂ + where + toFun := bindAux b e + func'' := fun _ _ => rfl + +/-- +`FFL.FirstOrder.Rew.rewrite f` is a substitution of the free variables occurring in a term by `f +: ξ₁ → Semiterm L ξ₂ n`. -/ +def rewrite (f : ξ₁ → Semiterm L ξ₂ n) : Rew L ξ₁ n ξ₂ n := + bind Semiterm.bvar f + +/-- +`FFL.FirstOrder.Rew.rewriteMap` f is a substitution of the free variables occurring in a term by +`e : ξ₁ → ξ₂`. -/ +def rewriteMap (e : ξ₁ → ξ₂) : Rew L ξ₁ n ξ₂ n := + rewrite (fun m => &(e m)) + +/-- The map construction in `FFL.FirstOrder.Rew`. -/ +def map (b : Fin n₁ → Fin n₂) (e : ξ₁ → ξ₂) : Rew L ξ₁ n₁ ξ₂ n₂ := + bind (fun n => #(b n)) (fun m => &(e m)) + +/-- +`FFL.FirstOrder.Rew.subst v` is a substitution of the bound variables occurring in a term by `v +: Fin n → Semiterm L ξ n'`. -/ +def subst {n'} (v : Fin n → Semiterm L ξ n') : Rew L ξ n ξ n' := + bind v fvar + +/-- +`FFL.FirstOrder.Rew.emb` is a embedding of a term with no free variables. It can be thought of +as a cast from `Semiterm L Empty n` to `Semiterm L ξ n` for any type `ξ`. -/ +def emb {o : Type v₁} [h : IsEmpty o] {ξ : Type v₂} {n} : Rew L o n ξ n := + map id h.elim + +/-- The embs construction in `FFL.FirstOrder.Rew`. -/ +abbrev embs {o : Type v₁} [IsEmpty o] {n} : Rew L o n ℕ n := + emb + +/-- The empty construction in `FFL.FirstOrder.Rew`. -/ +def empty {o : Type v₁} [h : IsEmpty o] {ξ : Type v₂} {n} : Rew L o 0 ξ n := + map Fin.elim0 h.elim + +/-- +`FFL.FirstOrder.Rew.bShift` is a transformation of the bounded variables occurring in a term by +`#x ↦ #(Fin.succ x)`. -/ +def bShift : Rew L ξ n ξ (n + 1) := + map Fin.succ id + +/-- The b Shift Add construction in `FFL.FirstOrder.Rew`. -/ +def bShiftAdd (m : ℕ) : Rew L ξ n ξ (n + m) := + map (Fin.addNat · m) id + +/-- The cast construction in `FFL.FirstOrder.Rew`. -/ +def cast {n n' : ℕ} (h : n = n') : Rew L ξ n ξ n' := + map (Fin.cast h) id + +/-- The cast LE construction in `FFL.FirstOrder.Rew`. -/ +def castLE {n n' : ℕ} (h : n ≤ n') : Rew L ξ n ξ n' := + map (Fin.castLE h) id + +/-- +`FFL.FirstOrder.Rew.embSubsts v` is a substitution of the bound variables occurring in a term +with no free variables by `v : Fin n → Semiterm L ξ n'`. +This closely resembles `FFL.FirstOrder.Rew.subst`, however the term is required to have free +variables of type `Empty`. -/ +def embSubsts (v : Fin k → Semiterm L ξ n) : Rew L Empty k ξ n := + Rew.bind v Empty.elim + +/-- The q construction in `FFL.FirstOrder.Rew`. -/ +protected def q (ω : Rew L ξ₁ n₁ ξ₂ n₂) : Rew L ξ₁ (n₁ + 1) ξ₂ (n₂ + 1) := + bind (#0 :> bShift ∘ ω ∘ bvar) (bShift ∘ ω ∘ fvar) + +lemma eq_id_of_eq {ω : Rew L ξ n ξ n} (hb : ∀ x, ω #x = #x) (he : ∀ x, ω &x = &x) (t) : + ω t = t := by + have : ω = Rew.id := by ext <;> simp [*] + simp [this] + +/-- The qpow construction in `FFL.FirstOrder.Rew`. -/ +def qpow (ω : Rew L ξ₁ n₁ ξ₂ n₂) : (k : ℕ) → Rew L ξ₁ (n₁ + k) ξ₂ (n₂ + k) + | 0 => ω + | k + 1 => (ω.qpow k).q + +@[simp] +lemma qpow_zero (ω : Rew L ξ₁ n₁ ξ₂ n₂) : qpow ω 0 = ω := + rfl + +@[simp] +lemma qpow_succ (ω : Rew L ξ₁ n₁ ξ₂ n₂) (k : ℕ) : qpow ω (k + 1) = (ω.qpow k).q := + rfl + +section bind + +variable (b : Fin n₁ → Semiterm L ξ₂ n₂) (e : ξ₁ → Semiterm L ξ₂ n₂) + +@[simp] +lemma bind_fvar (m : ξ₁) : bind b e (&m : Semiterm L ξ₁ n₁) = e m := + rfl + +@[simp] +lemma bind_bvar (n : Fin n₁) : bind b e (#n : Semiterm L ξ₁ n₁) = b n := + rfl + +lemma eq_bind (ω : Rew L ξ₁ n₁ ξ₂ n₂) : ω = bind (ω ∘ bvar) (ω ∘ fvar) := + by + ext t; induction t + · simp + · simp [*] + +@[simp] +lemma bind_eq_id_of_zero (f : Fin 0 → Semiterm L ξ₂ 0) : bind f fvar = Rew.id := by + ext x <;> simp only [bind_bvar, bind_fvar, id_app]; exact Fin.elim0 x + +end bind + +section map + +variable (b : Fin n₁ → Fin n₂) (e : ξ₁ → ξ₂) + +@[simp] +lemma map_fvar (m : ξ₁) : map b e (&m : Semiterm L ξ₁ n₁) = &(e m) := + rfl + +@[simp] +lemma map_bvar (n : Fin n₁) : map b e (#n : Semiterm L ξ₁ n₁) = #(b n) := + rfl + +@[simp] +lemma map_id : map (L := L) (id : Fin n → Fin n) (id : ξ → ξ) = Rew.id := by ext <;> simp + +lemma map_inj {b : Fin n₁ → Fin n₂} {e : ξ₁ → ξ₂} (hb : Function.Injective b) + (he : Function.Injective e) : Function.Injective <| map (L := L) b e + | #x, #y => by simpa using @hb _ _ + | #x, &y => by simp + | #x, func f w => by simp [Rew.func] + | &x, #y => by simp + | &x, &y => by simpa using @he _ _ + | &x, func f w => by simp [Rew.func] + | func f v, #y => by simp [Rew.func] + | func f v, &y => by simp [Rew.func] + | func (arity := k) f v, func (arity := l) g w => fun h ↦ + by + have : k = l := by + simp [Rew.func] at h + simp_all + rcases this + have : f = g := by + simp [Rew.func] at h + simp_all + rcases this + have : v = w := + by + have hv : (fun i ↦ (map b e) (v i)) = (fun i ↦ (map b e) (w i)) := by + simpa [Rew.func, Function.comp_def] using h + funext i + exact map_inj hb he (congrFun hv i) + simp_all + +end map + +section rewrite + +variable (f : ξ₁ → Semiterm L ξ₂ n) + +@[simp] +lemma rewrite_fvar (x : ξ₁) : rewrite f &x = f x := + rfl + +@[simp] +lemma rewrite_bvar (x : Fin n) : rewrite e (#x : Semiterm L ξ₁ n) = #x := + rfl + +lemma rewrite_comp_rewrite (v : ξ₂ → Semiterm L ξ₃ n) (w : ξ₁ → Semiterm L ξ₂ n) : + (rewrite v).comp (rewrite w) = rewrite (rewrite v ∘ w) := by ext <;> simp [comp_app] + +@[simp] +lemma rewrite_eq_id : (rewrite Semiterm.fvar : Rew L ξ n ξ n) = Rew.id := by ext <;> simp + +end rewrite + +section rewriteMap + +variable (e : ξ₁ → ξ₂) + +@[simp] +lemma rewriteMap_fvar (x : ξ₁) : rewriteMap e (&x : Semiterm L ξ₁ n) = &(e x) := + rfl + +@[simp] +lemma rewriteMap_bvar (x : Fin n) : rewriteMap e (#x : Semiterm L ξ₁ n) = #x := + rfl + +@[simp] +lemma rewriteMap_id : rewriteMap (L := L) (n := n) (id : ξ → ξ) = Rew.id := by ext <;> simp + +lemma eq_rewriteMap_of_funEqOn_fv [DecidableEq ξ₁] (t : Semiterm L ξ₁ n₁) + (f g : ξ₁ → Semiterm L ξ₂ n₂) (h : Function.funEqOn t.HasFreeVariable f g) : + Rew.rewriteMap f t = Rew.rewriteMap g t := + by + induction t + case bvar => simp + case fvar x => simpa using h x (by simp) + case func f v ih => + simp only [Rew.func, func.injEq, heq_eq_eq, true_and] + funext i + exact ih i (fun x hx ↦ h x (by simpa [Semiterm.hasFreeVariable_func] using ⟨i, hx⟩)) + +end rewriteMap + +section emb + +variable {o : Type v₂} [IsEmpty o] + +@[simp] +lemma emb_bvar (x : Fin n) : emb (ξ := ξ) (#x : Semiterm L o n) = #x := + rfl + +@[simp] +lemma emb_eq_id : (emb : Rew L o n o n) = Rew.id := by + ext x <;> simp only [emb_bvar, id_app]; + exact isEmptyElim x + +lemma eq_empty [h : IsEmpty ξ₁] (ω : Rew L ξ₁ 0 ξ₂ n) : ω = empty := by + ext x; + { exact x.elim0 + }; + { exact h.elim' x + } + +end emb + +section bShift + +@[simp] +lemma bShift_bvar (x : Fin n) : bShift (#x : Semiterm L ξ n) = #(Fin.succ x) := + rfl + +@[simp] +lemma bShift_fvar (x : ξ) : bShift (&x : Semiterm L ξ n) = &x := + rfl + +@[simp] +lemma bShift_ne_zero (t : Semiterm L ξ n) : bShift t ≠ #0 := by + cases t <;> simp [Rew.func, Fin.succ_ne_zero] + +@[simp] +lemma bShift_positive (t : Semiterm L ξ n) : (bShift t).Positive := by + induction t <;> simp [Rew.func, *] + +lemma positive_iff {t : Semiterm L ξ (n + 1)} : t.Positive ↔ ∃ t', t = bShift t' := + by + constructor + · induction t + case bvar x => + simp only [Positive.bvar] + intro hx + exact ⟨#(x.pred (Fin.pos_iff_ne_zero.mp hx)), by simp⟩ + case fvar x => simpa using ⟨&x, by simp⟩ + case func k f v ih => + simp only [Positive.func] + intro h + have hw : ∀ i, ∃ t', v i = bShift t' := fun i => ih i (h i) + choose w hw using hw + refine ⟨func f w, ?_⟩ + simp only [Rew.func, func.injEq, heq_eq_eq, true_and] + funext i + exact hw i + · rintro ⟨t', rfl⟩ + simp + +@[simp] +lemma leftConcat_bShift_comp_bvar : + (#0 :> bShift ∘ bvar : Fin (n + 1) → Semiterm L ξ (n + 1)) = bvar := + funext (Fin.cases (by simp) (by simp)) + +@[simp] +lemma bShift_comp_fvar : (bShift ∘ fvar : ξ → Semiterm L ξ (n + 1)) = fvar := + funext (by simp) + +end bShift + +section bShiftAdd + +@[simp] +lemma bShiftAdd_bvar (m) (x : Fin n) : bShiftAdd m (#x : Semiterm L ξ n) = #(Fin.addNat x m) := + rfl + +@[simp] +lemma bShiftAdd_fvar (m) (x : ξ) : bShiftAdd m (&x : Semiterm L ξ n) = &x := + rfl + +end bShiftAdd + +section subst + +variable {n'} (w : Fin n → Semiterm L ξ n') + +@[simp] +lemma subst_bvar (x : Fin n) : subst w #x = w x := by simp [subst] + +@[simp] +lemma subst_fvar (x : ξ) : subst w &x = &x := by simp [subst] + +@[simp] +lemma subst_zero (w : Fin 0 → Term L ξ) : subst w = Rew.id := + by + ext x + · exact Fin.elim0 x + · simp + +lemma subst_comp_subst (v : Fin l → Semiterm L ξ k) (w : Fin k → Semiterm L ξ n) : + (subst w).comp (subst v) = subst (subst w ∘ v) := by ext <;> simp [comp_app] + +@[simp] +lemma subst_eq_id : (subst Semiterm.bvar : Rew L ξ n ξ n) = Rew.id := by ext <;> simp + +end subst + +section cast + +variable {n'} (h : n = n') + +@[simp] +lemma cast_bvar (x : Fin n) : cast h (#x : Semiterm L ξ n) = #(Fin.cast h x) := + rfl + +@[simp] +lemma cast_fvar (x : ξ) : cast h (&x : Semiterm L ξ n) = &x := + rfl + +@[simp] +lemma cast_eq_id {h} : (cast h : Rew L ξ n ξ n) = Rew.id := by ext <;> simp + +end cast + +section castLE + +@[simp] +lemma castLe_bvar {n'} (h : n ≤ n') (x : Fin n) : + castLE h (#x : Semiterm L ξ n) = #(Fin.castLE h x) := + rfl + +@[simp] +lemma castLe_fvar {n'} (h : n ≤ n') (x : ξ) : castLE h (&x : Semiterm L ξ n) = &x := + rfl + +@[simp] +lemma castLe_eq_id {h} : (castLE h : Rew L ξ n ξ n) = Rew.id := by ext <;> simp + +@[simp] +lemma castLE_comp {h₁ : n₁ ≤ n₂} {h₂ : n₂ ≤ n₃} : + (castLE h₂).comp (castLE h₁) = (castLE (h₁.trans h₂) : Rew L ξ n₁ ξ n₃) := by + ext x <;> simp [comp_app] + +end castLE + +section embSubsts + +variable {k} (w : Fin k → Semiterm L ξ n) + +@[simp] +lemma embSubsts_bvar (x : Fin k) : embSubsts w #x = w x := by simp [embSubsts] + +@[simp] +lemma embSubsts_zero (w : Fin 0 → Term L ξ) : embSubsts w = Rew.emb := + by + ext x + · exact Fin.elim0 x + · exact Empty.elim x + +lemma subst_comp_embSubsts (v : Fin l → Semiterm L ξ k) (w : Fin k → Semiterm L ξ n) : + (subst w).comp (embSubsts v) = embSubsts (subst w ∘ v) := + by + ext x + · simp [comp_app] + · exact Empty.elim x + +@[simp] +lemma embSubsts_eq_id : (embSubsts Semiterm.bvar : Rew L Empty n ξ n) = Rew.emb := + by + ext x <;> try simp + · exact Empty.elim x + +end embSubsts + +section ψ + +variable (ω : Rew L ξ₁ n₁ ξ₂ n₂) + +@[simp] +lemma q_bvar_zero : ω.q #0 = #0 := by simp [Rew.q] + +@[simp] +lemma q_bvar_succ (i : Fin n₁) : ω.q #(i.succ) = bShift (ω #i) := by simp [Rew.q] + +@[simp] +lemma q_fvar (x : ξ₁) : ω.q &x = bShift (ω &x) := by simp [Rew.q] + +@[simp] +lemma q_comp_bShift : ω.q.comp bShift = bShift.comp ω := by ext x <;> simp [comp_app] + +@[simp] +lemma q_comp_bShift_app (t : Semiterm L ξ₁ n₁) : ω.q (bShift t) = bShift (ω t) := by + have := ext' (ω.q_comp_bShift) t; simpa only [comp_app] using this + +@[simp] +lemma q_id : (Rew.id : Rew L ξ n ξ n).q = Rew.id := + by + ext x + · cases x using Fin.cases <;> simp + · simp + +@[simp] +lemma q_eq_zero_iff : ω.q t = #0 ↔ t = #0 := + by + cases t + case bvar i => cases i using Fin.cases <;> simp [Fin.succ_ne_zero] + · simp + · simp [Rew.func] + +@[simp] +lemma q_positive_iff : (ω.q t).Positive ↔ t.Positive := + by + induction t + case bvar x => cases x using Fin.cases <;> simp + · simp + · simp [Rew.func, *] + +@[simp] +lemma qpow_id {k} : (Rew.id : Rew L ξ n ξ n).qpow k = Rew.id := by induction k <;> simp [*] + +lemma q_comp (ω₂ : Rew L ξ₂ n₂ ξ₃ n₃) (ω₁ : Rew L ξ₁ n₁ ξ₂ n₂) : + (Rew.comp ω₂ ω₁).q = ω₂.q.comp ω₁.q := by + ext x + · cases x using Fin.cases <;> simp [comp_app] + · simp [comp_app] + +lemma qpow_comp (k) (ω₂ : Rew L ξ₂ n₂ ξ₃ n₃) (ω₁ : Rew L ξ₁ n₁ ξ₂ n₂) : + (Rew.comp ω₂ ω₁).qpow k = (ω₂.qpow k).comp (ω₁.qpow k) := by + induction k <;> simp [*, q_comp] + +lemma q_bind (b : Fin n₁ → Semiterm L ξ₂ n₂) (e : ξ₁ → Semiterm L ξ₂ n₂) : + (bind b e).q = bind (#0 :> bShift ∘ b) (bShift ∘ e) := + by + ext x + · cases x using Fin.cases <;> simp + · simp + +lemma q_map (b : Fin n₁ → Fin n₂) (e : ξ₁ → ξ₂) : + (map (L := L) b e).q = map (0 :> Fin.succ ∘ b) e := + by + ext x + · cases x using Fin.cases <;> simp + · simp + +lemma q_rewrite (f : ξ₁ → Semiterm L ξ₂ n) : (rewrite f).q = rewrite (bShift ∘ f) := + by + ext x + · cases x using Fin.cases <;> simp + · simp + +@[simp] +lemma q_rewriteMap (e : ξ₁ → ξ₂) : (rewriteMap (L := L) (n := n) e).q = rewriteMap e := + by + ext x + · cases x using Fin.cases <;> simp + · simp + +@[simp] +lemma q_emb {o : Type v₁} [e : IsEmpty o] {n} : + (emb (L := L) (o := o) (ξ := ξ₂) (n := n)).q = emb := + by + ext x + · cases x using Fin.cases <;> simp + · exact e.elim x + +@[simp] +lemma qpow_emb {o : Type v₁} [e : IsEmpty o] {n k} : + (emb (L := L) (o := o) (ξ := ξ₂) (n := n)).qpow k = emb := by induction k <;> simp [*] + +@[simp] +lemma q_cast {n n'} (h : n = n') : + (cast h : Rew L ξ n ξ n').q = cast (congrFun (congrArg HAdd.hAdd h) 1) := by + ext x <;> simp; + cases x using Fin.cases <;> simp + +@[simp] +lemma q_castLE {n n'} (h : n ≤ n') : + (castLE h : Rew L ξ n ξ n').q = castLE (Nat.add_le_add_right h 1) := by + ext x <;> simp; + cases x using Fin.cases <;> simp + +@[simp] +lemma qpow_castLE {n n'} (h : n ≤ n') : + (castLE h : Rew L ξ n ξ n').qpow k = castLE (Nat.add_le_add_right h k) := by + induction k <;> simp [*] + +lemma q_subst (w : Fin n → Semiterm L ξ n') : (subst w).q = subst (#0 :> bShift ∘ w) := by + ext x; + { cases x using Fin.cases <;> simp + }; + { simp + } + +lemma q_embSubsts (w : Fin k → Semiterm L ξ n) : + (embSubsts w).q = embSubsts (#0 :> bShift ∘ w) := by + ext x; + { cases x using Fin.cases <;> simp + }; + { simpa using Empty.elim x + } + +end ψ + +section Syntactic + +/-- +`FFL.FirstOrder.Rew.shift` is a transformation of the free variables occurring in the term by +`&x ↦ &(x + 1)`. -/ +def shift : SyntacticRew L n n := + map id Nat.succ + +/-- The free construction in `FFL.FirstOrder.Rew`. -/ +def free : SyntacticRew L (n + 1) n := + bind (bvar <: &0) (fun m => &(Nat.succ m)) + +/-- The fix construction in `FFL.FirstOrder.Rew`. -/ +def fix : SyntacticRew L n (n + 1) := + bind (fun x => #(Fin.castSucc x)) (#(Fin.last n) :>ₙ fvar) + +/-- The rewrite1 construction in `FFL.FirstOrder.Rew`. -/ +abbrev rewrite1 (t : SyntacticSemiterm L n) : SyntacticRew L n n := + bind Semiterm.bvar (t :>ₙ fvar) + +section shift + +@[simp] +lemma shift_bvar (x : Fin n) : shift (#x : SyntacticSemiterm L n) = #x := + rfl + +@[simp] +lemma shift_fvar (x : ℕ) : shift (&x : SyntacticSemiterm L n) = &(x + 1) := + rfl + +lemma shift_func {k} (f : L.Func k) (v : Fin k → SyntacticSemiterm L n) : + shift (func f v) = func f (fun i => shift (v i)) := + rfl + +lemma shift_Injective : Function.Injective (@shift L n) := + Function.LeftInverse.injective (g := map id Nat.pred) + (by intros φ; simp only [← comp_app]; apply eq_id_of_eq <;> simp [comp_app]) + +end shift + +section free + +@[simp] +lemma free_bvar_castSucc (x : Fin n) : + free (#(Fin.castSucc x) : SyntacticSemiterm L (n + 1)) = #x := by simp [free] + +@[simp] +lemma free_bvar_castSucc_zero : free (#0 : SyntacticSemiterm L (n + 1 + 1)) = #0 := + free_bvar_castSucc 0 + +@[simp] +lemma free_bvar_last : free (#(Fin.last n) : SyntacticSemiterm L (n + 1)) = &0 := by simp [free] + +@[simp] +lemma free_bvar_last_zero : free (#0 : SyntacticSemiterm L 1) = &0 := + free_bvar_last + +@[simp] +lemma free_fvar (x : ℕ) : free (&x : SyntacticSemiterm L (n + 1)) = &(x + 1) := by simp [free] + +end free + +section fix + +@[simp] +lemma fix_bvar (x : Fin n) : fix (#x : SyntacticSemiterm L n) = #(Fin.castSucc x) := by + simp [fix] + +@[simp] +lemma fix_fvar_zero : fix (&0 : SyntacticSemiterm L n) = #(Fin.last n) := by simp [fix] + +@[simp] +lemma fix_fvar_succ (x : ℕ) : fix (&(x + 1) : SyntacticSemiterm L n) = &x := by simp [fix] + +end fix + +@[simp] +lemma free_comp_fix : (free (L := L) (n := n)).comp fix = Rew.id := + by + ext x + · simp [comp_app] + · simp [comp_app] + cases x <;> simp + +@[simp] +lemma fix_comp_free : (fix (L := L) (n := n)).comp free = Rew.id := + by + ext x + · simp [comp_app] + cases x using Fin.lastCases <;> simp + · simp [comp_app] + +@[simp] +lemma bShift_free_eq_shift : (free (L := L) (n := 0)).comp bShift = shift := + by + ext x + · exact Fin.elim0 x + · simp [comp_app] + +lemma bShift_comp_subst (v : Fin n₁ → Semiterm L ξ₂ n₂) : + bShift.comp (subst v) = subst (bShift ∘ v) := by ext x <;> simp [comp_app] + +lemma shift_comp_subst (v : Fin n₁ → SyntacticSemiterm L n₂) : + shift.comp (subst v) = (subst (shift ∘ v)).comp shift := by ext x <;> simp [comp_app] + +lemma shift_comp_subst1 (t : SyntacticSemiterm L n₂) : + shift.comp (subst ![t]) = (subst ![shift t]).comp shift := by ext x <;> simp [comp_app] + +@[simp] +lemma rewrite_comp_emb {o : Type v₁} [e : IsEmpty o] (f : ξ₂ → Semiterm L ξ₃ n) : + (rewrite f).comp emb = (emb : Rew L o n ξ₃ n) := + by + ext x + · simp [comp_app] + · exact IsEmpty.elim e x + +@[simp] +lemma shift_comp_emb {o : Type v₁} [e : IsEmpty o] : shift.comp emb = (emb : Rew L o n ℕ n) := + by + ext x + · simp [comp_app] + · exact IsEmpty.elim e x + +@[simp] +lemma comp_emb_eq_emb {o : Type v₁} [e : IsEmpty o] {ω : Rew L ξ₁ 0 ξ₂ 0} : + ω.comp emb = (emb : Rew L o 0 ξ₂ 0) := by + ext x + · exact Fin.elim0 x + · exact IsEmpty.elim e x + +lemma rewrite_comp_free_eq_subst (t : SyntacticTerm L) : + (rewrite (t :>ₙ Semiterm.fvar)).comp free = subst ![t] := by + ext x <;> simp [PointwiseComposition.Fin.Fin1.eq_one, comp_app] + +lemma rewrite_comp_shift_eq_id (t : SyntacticTerm L) : + (rewrite (t :>ₙ Semiterm.fvar)).comp shift = Rew.id := by ext x <;> simp [comp_app] + +@[simp] +lemma subst_mbar_zero_comp_shift_eq_free : (subst (L := L) ![&0]).comp shift = free := by + ext x <;> simp [PointwiseComposition.Fin.Fin1.eq_one, comp_app] + +@[simp] +lemma subst_comp_bShift_eq_id (v : Fin 1 → Semiterm L ξ 0) : + (subst (L := L) v).comp bShift = Rew.id := + by + ext x + · exact Fin.elim0 x + · simp [comp_app] + +lemma free_comp_subst_eq_subst_comp_shift {Lf : Language} {n'} + (w : Fin n' → SyntacticSemiterm Lf (n + 1)) : + free.comp (subst w) = (subst (free ∘ w)).comp shift := by ext x <;> simp [comp_app] + +@[simp] +lemma rewriteMap_comp_rewriteMap (f : ξ₁ → ξ₂) (g : ξ₂ → ξ₃) : + (rewriteMap (L := L) (n := n) g).comp (rewriteMap f) = rewriteMap (g ∘ f) := by + ext x <;> simp [comp_app] + +@[simp] +lemma fix_free_app (t : SyntacticSemiterm L (n + 1)) : fix (free t) = t := by simp [← comp_app] + +@[simp] +lemma free_fix_app (t : SyntacticSemiterm L n) : free (fix t) = t := by simp [← comp_app] + +@[simp] +lemma free_bShift_app (t : SyntacticSemiterm L 0) : free (bShift t) = shift t := by + simp [← comp_app] + +@[simp] +lemma subst_bShift_app (v : Fin 1 → Semiterm L ξ 0) : subst v (bShift t) = t := by + simp [← comp_app] + +lemma rewrite_comp_fix_eq_subst (t) : + ((rewrite (t :>ₙ (&·))).comp free : SyntacticRew L 1 0) = subst ![t] := by + ext x <;> simp [PointwiseComposition.Fin.Fin1.eq_one, comp_app] + +lemma bShift_eq_rewrite : (Rew.bShift : SyntacticRew L 0 1) = Rew.subst ![] := + by + ext x + · exact x.elim0 + · simp + +section ψ + +variable (ω : SyntacticRew L n₁ n₂) + +@[simp] +lemma q_shift : (shift (L := L) (n := n)).q = shift := + by + ext x + · cases x using Fin.cases <;> simp + · simp + +@[simp] +lemma q_free : (free (L := L) (n := n)).q = free := + by + ext x + · refine Fin.cases ?_ (fun x => ?_) x + · simp + · simp + cases x using Fin.lastCases <;> simp [-Fin.castSucc_succ, Fin.succ_castSucc] + · simp + +@[simp] +lemma q_fix : (fix (L := L) (n := n)).q = fix := by + ext x; + { cases x using Fin.cases <;> simp [-Fin.castSucc_succ, Fin.succ_castSucc] + }; + { cases x <;> simp + } + --@[simp] lemma qpow_fix (k : ℕ) : (fix (L := L) (n := n)).qpow k = fix := by + +end ψ + +/-- The fixitr construction in `FFL.FirstOrder.Rew`. -/ +def fixitr (n : ℕ) : (m : ℕ) → SyntacticRew L n (n + m) + | 0 => Rew.id + | m + 1 => Rew.fix.comp (fixitr n m) + +@[simp] +lemma fixitr_zero : fixitr (L := L) n 0 = Rew.id := by simp [fixitr] + +lemma fixitr_succ (m) : fixitr (L := L) n (m + 1) = Rew.fix.comp (fixitr n m) := by + simp [fixitr] + +@[simp] +lemma fixitr_bvar (n m) (x : Fin n) : + fixitr n m (#x : SyntacticSemiterm L n) = #(x.castAdd m) := + by + induction m + · simp [*] + case succ m ih => rw [fixitr_succ, comp_app, ih]; simp [Fin.castSucc_castAdd] + +lemma fixitr_fvar (n m) (x : ℕ) : + fixitr n m (&x : SyntacticSemiterm L n) = + if h : x < m then #(Fin.natAdd n ⟨x, h⟩) else &(x - m) := + by + induction m + · simp [*] + case succ m + ih => + suffices fix (fixitr n m &x) = if h : x < m + 1 then #⟨n + x, _⟩ else &(x - (m + 1)) from + Eq.trans (comp_app _ _ _) this + simp only [ih, Fin.natAdd_mk] + by_cases hx : x < m + · simp [hx, Nat.lt_add_right 1 hx] + by_cases hx2 : x < m + 1 + · have : x = m := + Nat.le_antisymm + (by { simpa [Nat.lt_succ_iff] using hx2 + }) + (by simpa using hx) + aesop + · simp [hx, hx2] + have : x - m = x - (m + 1) + 1 := by omega + simp [this] + +end Syntactic + +lemma subst_bv (t : Semiterm L ξ n) (v : Fin n → Semiterm L ξ m) : + (Rew.subst v t).bv = t.bv.biUnion (fun i ↦ (v i).bv) := by + induction t <;> simp [Rew.func, Semiterm.bv_func, Finset.biUnion_biUnion, *] + +@[simp] +lemma subst_positive (t : Semiterm L ξ n) (v : Fin n → Semiterm L ξ (m + 1)) : + (Rew.subst v t).Positive ↔ ∀ i ∈ t.bv, (v i).Positive := by + simpa [Semiterm.Positive, subst_bv] using + ⟨fun H i hi x hx ↦ H x i hi hx, fun H x i hi hx ↦ H i hi x hx⟩ + +lemma embSubsts_bv (t : ClosedSemiterm L n) (v : Fin n → Semiterm L ξ m) : + (Rew.embSubsts v t).bv = t.bv.biUnion (fun i ↦ (v i).bv) := + by + induction t + · simp + · contradiction + · simp [Rew.func, Semiterm.bv_func, Finset.biUnion_biUnion, *] + +@[simp] +lemma embSubsts_positive (t : ClosedSemiterm L n) (v : Fin n → Semiterm L ξ (m + 1)) : + (Rew.embSubsts v t).Positive ↔ ∀ i ∈ t.bv, (v i).Positive := by + simpa [Semiterm.Positive, embSubsts_bv] using + ⟨fun H i hi x hx ↦ H x i hi hx, fun H x i hi hx ↦ H i hi x hx⟩ + +lemma bshift_positive (t : Semiterm L ξ n) : Positive (Rew.bShift t) := by + exact bShift_positive t + +lemma emb_comp_bShift_comm {o : Type v₁} [IsEmpty o] : + Rew.bShift.comp (Rew.emb : Rew L o n ξ n) = Rew.emb.comp Rew.bShift := + by + ext x + · simp [comp_app] + · exact IsEmpty.elim (by assumption) x + +lemma emb_bShift_term {o : Type v₁} [IsEmpty o] (t : Semiterm L o n) : + Rew.bShift (Rew.emb t : Semiterm L ξ n) = Rew.emb (Rew.bShift t) := by + simp [← comp_app, emb_comp_bShift_comm] + +end Rew + +/-! +### Rewriting system of terms -/ + +namespace Semiterm + +variable {L L' L₁ L₂ L₃ : Language} {ξ ξ' ξ₁ ξ₂ ξ₃ : Type*} {n n₁ n₂ n₃ : ℕ} + +instance : Coe (ClosedSemiterm L n) (SyntacticSemiterm L n) := + ⟨Rew.emb⟩ + +@[simp] +lemma freeVariables_emb {ο : Type*} [IsEmpty ο] [DecidableEq ξ] {t : Semiterm L ο n} : + (Rew.emb t : Semiterm L ξ n).freeVariables = ∅ := + by + induction t + case bvar => simp + case fvar x => exact IsEmpty.elim inferInstance x + case func k f v ih => ext x; simp [Rew.func, freeVariables_func, ih] + +lemma rew_eq_of_funEqOn [DecidableEq ξ₁] (ω₁ ω₂ : Rew L ξ₁ n₁ ξ₂ n₂) (t : Semiterm L ξ₁ n₁) + (hb : ∀ x, ω₁ #x = ω₂ #x) + (he : Function.funEqOn t.HasFreeVariable (ω₁ ∘ Semiterm.fvar) (ω₂ ∘ Semiterm.fvar)) : + ω₁ t = ω₂ t := by + induction t + case bvar => simp [hb] + case fvar => simpa [HasFreeVariable, Function.funEqOn] using he + case func k f v ih => + simp only [Rew.func, func.injEq, heq_eq_eq, true_and] + funext i + exact ih i (he.of_subset <| by intro x hx; simpa using ⟨i, hx⟩) + +section lMap + +variable (Φ : L₁ →ᵥ L₂) + +open Rew + +lemma lMap_bind (b : Fin n₁ → Semiterm L₁ ξ₂ n₂) (e : ξ₁ → Semiterm L₁ ξ₂ n₂) (t) : + lMap Φ (bind b e t) = bind (lMap Φ ∘ b) (lMap Φ ∘ e) (t.lMap Φ) := by + induction t <;> simp [*, -lMap_func, lMap_func', -Rew.func, Rew.func'] + +lemma lMap_map (b : Fin n₁ → Fin n₂) (e : ξ₁ → ξ₂) (t) : + (map b e t).lMap Φ = map b e (t.lMap Φ) := by simp [map, lMap_bind, Function.comp_def] + +lemma lMap_bShift (t : Semiterm L₁ ξ₁ n) : (bShift t).lMap Φ = bShift (t.lMap Φ) := by + simp [bShift, lMap_map] + +lemma lMap_shift (t : SyntacticSemiterm L₁ n) : (shift t).lMap Φ = shift (t.lMap Φ) := by + simp [shift, lMap_map] + +lemma lMap_free (t : SyntacticSemiterm L₁ (n + 1)) : (free t).lMap Φ = free (t.lMap Φ) := + by + simp only [free, Nat.succ_eq_add_one, lMap_bind] + congr; exact funext <| Fin.lastCases (by simp) (by simp) + +lemma lMap_fix (t : SyntacticSemiterm L₁ n) : (fix t).lMap Φ = fix (t.lMap Φ) := + by + simp only [fix, lMap_bind] + congr; funext x; cases x <;> simp + +end lMap + +lemma hasFreeVariable_rew [DecidableEq ξ₁] [DecidableEq ξ₂] {ω : Rew L ξ₁ n₁ ξ₂ n₂} + {t : Semiterm L ξ₁ n₁} {x} : + (ω t).HasFreeVariable x → + (∃ i : Fin n₁, (ω #i).HasFreeVariable x) ∨ + (∃ z : ξ₁, t.HasFreeVariable z ∧ (ω &z).HasFreeVariable x) := + by + induction t + case bvar z => intro h; left; exact ⟨z, h⟩ + case fvar z => intro h; right; exact ⟨z, by simp [h]⟩ + case func k F v + ih => + simp only [Rew.func, hasFreeVariable_func, forall_exists_index] + intro i hx + rcases ih i hx with (h | ⟨z, hi, hz⟩) + · left; exact h + · right; exact ⟨z, ⟨i, hi⟩, hz⟩ + +@[simp] +lemma hasFreeVariable_bShift [DecidableEq ξ] {t : Semiterm L ξ n} {x} : + (Rew.bShift t).HasFreeVariable x ↔ t.HasFreeVariable x := by + induction t <;> simp [Rew.func, *] + +/-- The to Empty construction in `FFL.FirstOrder.Semiterm`. -/ +def toEmpty [DecidableEq ξ] {n : ℕ} : + (t : Semiterm L ξ n) → t.freeVariables = ∅ → ClosedSemiterm L n + | #x, _ => #x + | &x, h => by simp at h + | func f v, h => + have : ∀ i, (v i).freeVariables = ∅ := by + intro i; ext x + have := by simpa using Eq.to_iff (congrFun (congrArg Membership.mem h) x) + simpa using this i + func f fun i ↦ toEmpty (v i) (this i) + +@[simp] +lemma emb_toEmpty [DecidableEq ξ] (t : Semiterm L ξ n) (ht : t.freeVariables = ∅) : + Rew.emb (t.toEmpty ht) = t := + by + induction t <;> try simp [toEmpty, Rew.func, *, Function.comp_def] + case fvar => simp at ht + +@[simp] +lemma toEmpty_emb [DecidableEq ξ] (t : ClosedSemiterm L n) : + (Rew.emb t : Semiterm L ξ n).toEmpty (by simp) = t := + by + induction t <;> try simp [toEmpty, Rew.func, *] + case fvar => contradiction + +end Semiterm + +/-! +### Rewriting system of formulae -/ + +/-- A typeclass for `Rew`s which additionally respect quantifiers. + +`app` - A notion of application of `Rew`s to formulas. + +`app_all` - Application preserves universal quantification. + +`app_exs` - Application preserves existential quantification. +-/ +class Rewriting (L : outParam Language) (ξ : outParam Type*) (F : ℕ → Type*) (ζ : Type*) + (G : outParam (ℕ → Type*)) [LCWQ F] [LCWQ G] where + /-- The app construction in `FFL.FirstOrder.Rewriting`. -/ + app {n₁ n₂} : Rew L ξ n₁ ζ n₂ → F n₁ →ˡᶜ G n₂ + app_all (ω₁₂ : Rew L ξ n₁ ζ n₂) (φ) : app ω₁₂ (∀¹ φ) = ∀¹ (app ω₁₂.q φ) + app_exs (ω₁₂ : Rew L ξ n₁ ζ n₂) (φ) : app ω₁₂ (∃¹ φ) = ∃¹ (app ω₁₂.q φ) + +/-- The Syntactic Rewriting construction in `FFL.FirstOrder`. -/ +abbrev SyntacticRewriting (L : outParam Language) (F : ℕ → Type*) (G : outParam (ℕ → Type*)) + [LCWQ F] [LCWQ G] := + Rewriting L ℕ F ℕ G + +namespace Rewriting + +variable [LCWQ F] [LCWQ G] [Rewriting L ξ F ζ G] + +attribute [simp] app_all app_exs + +/-- Application of a `Rewriting` to a formula. -/ +infixr:73 " ▹ " => app + +lemma smul_ext' {ω₁ ω₂ : Rew L ξ n₁ ζ n₂} (h : ω₁ = ω₂) {φ : F n₁} : ω₁ ▹ φ = ω₂ ▹ φ := by + rw [h] + +@[simp] +lemma smul_ball (ω : Rew L ξ n₁ ζ n₂) (φ ψ : F (n₁ + 1)) : + ω ▹ (∀¹[φ] ψ) = ∀¹[ω.q ▹ φ] (ω.q ▹ ψ) := by simp [ball] + +@[simp] +lemma smul_bexs (ω : Rew L ξ n₁ ζ n₂) (φ ψ : F (n₁ + 1)) : + ω ▹ (∃¹[φ] ψ) = ∃¹[ω.q ▹ φ] (ω.q ▹ ψ) := by simp [bexs] + +@[simp] +lemma smul_allItr (ω : Rew L ξ n₁ ζ n₂) (φ : F (n₁ + k)) : + ω ▹ (∀¹^[k] φ) = ∀¹^[k] (ω.qpow k ▹ φ : G (n₂ + k)) := by + induction k <;> simp [allItr_succ, *] + +@[simp] +lemma smul_exsItr (ω : Rew L ξ n₁ ζ n₂) (φ : F (n₁ + k)) : + ω ▹ (∃¹^[k] φ) = ∃¹^[k] (ω.qpow k ▹ φ : G (n₂ + k)) := by + induction k <;> simp [exsItr_succ, *] + +@[simp] +lemma smul_quant (ω : Rew L ξ n₁ ζ n₂) (Γ : Polarity) (φ : F (n₁ + 1)) : + ω ▹ Γ.quant φ = Γ.quant (ω.q ▹ φ) := by cases Γ <;> simp [Polarity.eq_sigma, Polarity.eq_pi] + +@[simp] +lemma smul_quantItr (ω : Rew L ξ n₁ ζ n₂) (Γ : Polarity) (φ : F (n₁ + k)) : + ω ▹ Polarity.quantItr Γ k φ = Polarity.quantItr Γ k (ω.qpow k ▹ φ : G (n₂ + k)) := by + induction k <;> simp [Polarity.quantItr_succ', *] + +/-- The subst construction in `FFL.FirstOrder.Rewriting`. -/ +abbrev subst [Rewriting L ξ F ξ F] (φ : F n₁) (w : Fin n₁ → Semiterm L ξ n₂) : F n₂ := + Rew.subst w ▹ φ + +/-- +Applies the substitution `FFL.FirstOrder.Rew.subst w` to a formula. This substitutes the bound +variables occurring in the formula by `w : Fin n₁ → Semiterm L ξ n₂`. -/ +infix:90 " ↜ " => FFL.FirstOrder.Rewriting.subst + +/-- +Applies the substitution `FFL.FirstOrder.Rew.shift` to a formula. This substitutes each free +variable `&x` with `&(x + 1)`. -/ +abbrev shift [Rewriting L ℕ F ℕ F] : F n →ˡᶜ F n := + app Rew.shift + +/-- The free construction in `FFL.FirstOrder.Rewriting`. -/ +abbrev free [Rewriting L ℕ F ℕ F] : F (n + 1) →ˡᶜ F n := + app Rew.free + +/-- The fix construction in `FFL.FirstOrder.Rewriting`. -/ +abbrev fix [Rewriting L ℕ F ℕ F] : F n →ˡᶜ F (n + 1) := + app Rew.fix + +/-- The shifts construction in `FFL.FirstOrder.Rewriting`. -/ +def shifts [Rewriting L ℕ F ℕ F] (Γ : Multiset (F n)) : Multiset (F n) := + Γ.map Rewriting.shift + +/-- The «term ⁺» construction in `FFL.FirstOrder`. -/ +scoped[PointwiseComposition.FFL.FirstOrder] postfix:max "⁺" => FirstOrder.Rewriting.shifts + +@[simp] +lemma shifts_empty [Rewriting L ℕ F ℕ F] : (0 : Multiset (F n))⁺ = 0 := by rfl + +@[simp] +lemma shifts_add [Rewriting L ℕ F ℕ F] (Γ Δ : Multiset (F n)) : (Γ + Δ)⁺ = Γ⁺ + Δ⁺ := by + simp [shifts] + +@[simp] +lemma shifts_singleton [Rewriting L ℕ F ℕ F] (φ : F n) : (⦃φ⦄ : Multiset (F n))⁺ = ⦃shift φ⦄ := + by simp [shifts] + +@[simp] +lemma shifts_neg [Rewriting L ℕ F ℕ F] (Γ : Multiset (F n)) : (∼Γ)⁺ = ∼(Γ⁺) := by + simp [shifts, Multiset.tilde_def] + +/-- The emb construction in `FFL.FirstOrder.Rewriting`. -/ +abbrev emb {ο ξ} [IsEmpty ο] {O F : ℕ → Type*} [LCWQ O] [LCWQ F] [Rewriting L ο O ξ F] : + O n →ˡᶜ F n := + app (Rew.emb (ξ := ξ)) + +end Rewriting + +section Notation + +open _root_.Lean Lean PrettyPrinter Delaborator + +/-- The subst Notation construction in `FFL.FirstOrder`. -/ +syntax (name := substNotation) term:max "/[" term,* "]" : term + +/-- Slash notation for rewriting bound variables of a formula. + +The notation `φ/w` is equivalent to `φ ↜ w`, which for a formula `φ` with bound variables from +`Fin n₁`, substitutes the bound variables occurring in `φ` by `w : Fin n₁ → Semiterm L ξ n₂`. -/ +macro_rules (kind := substNotation) + | `($φ:term /[$terms:term,*]) => `($φ ↜ ![$terms,*]) + + + + + + + +/-- The unexpander Substitute construction in `unexpanderSubstitute`. -/ +@[app_unexpander Rewriting.subst] +meta def _root_.PointwiseComposition.unexpanderSubstitute : Unexpander + | `($_ $φ:term ![$ts:term,*]) => `($φ /[ $ts,* ]) + | _ => throw () + + + + + + + +end Notation + +/-- Data and laws for Reflective Rewriting in `FFL.FirstOrder`. -/ +class ReflectiveRewriting (L : outParam Language) (ξ : outParam Type*) (F : ℕ → Type*) [LCWQ F] + [Rewriting L ξ F ξ F] where + id_app (φ : F n) : @Rew.id L ξ n ▹ φ = φ + +/-- Data and laws for Transitive Rewriting in `FFL.FirstOrder`. -/ +class TransitiveRewriting (L : outParam Language) (ξ₁ : outParam Type*) (F₁ : ℕ → Type*) + (ξ₂ : Type*) (F₂ : outParam (ℕ → Type*)) (ξ₃ : Type*) (F₃ : outParam (ℕ → Type*)) [LCWQ F₁] + [LCWQ F₂] [LCWQ F₃] [Rewriting L ξ₁ F₁ ξ₂ F₂] [Rewriting L ξ₂ F₂ ξ₃ F₃] + [Rewriting L ξ₁ F₁ ξ₃ F₃] where + comp_app (ω₁₂ : Rew L ξ₁ n₁ ξ₂ n₂) (ω₂₃ : Rew L ξ₂ n₂ ξ₃ n₃) (φ : F₁ n₁) : + (ω₂₃.comp ω₁₂) ▹ φ = ω₂₃ ▹ ω₁₂ ▹ φ + +/-- Data and laws for Inj Map Rewriting in `FFL.FirstOrder`. -/ +class InjMapRewriting (L : outParam Language) (ξ : outParam Type*) (F : ℕ → Type*) (ζ : Type*) + (G : outParam (ℕ → Type*)) [LCWQ F] [LCWQ G] [Rewriting L ξ F ζ G] where + smul_map_injective {b : Fin n₁ → Fin n₂} {f : ξ → ζ} : + (hb : Function.Injective b) → + (hf : Function.Injective f) → Function.Injective fun φ : F n₁ ↦ Rew.map (L := L) b f ▹ φ + +/-- Data and laws for Lawful Syntactic Rewriting in `FFL.FirstOrder`. -/ +class LawfulSyntacticRewriting (L : outParam Language) (S : ℕ → Type*) [LCWQ S] + [SyntacticRewriting L S S] extends ReflectiveRewriting L ℕ S, + TransitiveRewriting L ℕ S ℕ S ℕ S, InjMapRewriting L ℕ S ℕ S + +attribute [simp] ReflectiveRewriting.id_app + +namespace Rewriting + +variable [LCWQ F] [Rewriting L ξ F ξ F] [ReflectiveRewriting L ξ F] + +lemma quantItr_succ_smul_castLE {φ : F ((n + 1) + s)} : + Polarity.quantItr Γ (s + 1) + ((Rew.castLE (Nat.succ_add n s).le : Rew L ξ ((n + 1) + s) ξ (n + (s + 1))) ▹ φ) = + Γ.quant (Polarity.quantItr Γ.alt s φ) := + by + induction s with + | zero => simp [Polarity.quantItr_succ'] + | succ s + ih => + have hcast : + (Rew.castLE (Nat.succ_add n (s + 1)).le : + Rew L ξ ((n + 1) + (s + 1)) ξ (n + ((s + 1) + 1))) = + (Rew.castLE (Nat.succ_add n s).le : Rew L ξ ((n + 1) + s) ξ (n + (s + 1))).q := + by simp + rw [Polarity.quantItr_succ', hcast, ← smul_quant] + rw [ih] + congr 1 + rw [Polarity.quantItr_succ', Polarity.altItr_succ'] + +end Rewriting + +namespace Rewriting + +variable {S : ℕ → Type*} [LCWQ S] [SyntacticRewriting L S S] [ReflectiveRewriting L ℕ S] + [TransitiveRewriting L ℕ S ℕ S ℕ S] + +/-- Renaming free variables by predecessor undoes shift (a routine substitution law). -/ +lemma rewriteMap_pred_shift (φ : S n) : Rew.rewriteMap Nat.pred ▹ shift φ = φ := by + change Rew.rewriteMap Nat.pred ▹ (Rew.rewriteMap Nat.succ ▹ φ) = φ; + rw [← TransitiveRewriting.comp_app, Rew.rewriteMap_comp_rewriteMap]; + change Rew.rewriteMap id ▹ φ = φ; simp; + +end Rewriting + +namespace LawfulSyntacticRewriting + +variable {S : ℕ → Type*} [LCWQ S] [SyntacticRewriting L S S] + +open Rewriting ReflectiveRewriting TransitiveRewriting InjMapRewriting Semiterm + +lemma fix_allClosure (φ : S n) : ∀¹ fix (∀¹* φ) = ∀¹* fix φ := + by + induction n + case zero => simp [allClosure_succ] + case succ n ih => simp [allClosure_succ, ih] + +variable [LawfulSyntacticRewriting L S] + +lemma shift_injective : Function.Injective fun φ : S n ↦ shift φ := + smul_map_injective Function.injective_id Nat.succ_injective + +@[simp] +lemma fix_free (φ : S (n + 1)) : fix (free φ) = φ := by simp [← comp_app] + +@[simp] +lemma free_fix (φ : S n) : free (fix φ) = φ := by simp [← comp_app] + +@[simp] +lemma subst_empty (φ : S 0) (v : Fin 0 → Semiterm L ℕ 0) : (φ ↜ v) = φ := by simp [subst] + +/-- `hom_subst_mbar_zero_comp_shift_eq_free` -/ +@[simp] +lemma app_subst_fbar_zero_comp_shift_eq_free (φ : S 1) : (shift φ)/[&0] = free φ := by + simp [← comp_app, Rew.subst_mbar_zero_comp_shift_eq_free] + +lemma free_rewrite_eq (f : ℕ → SyntacticTerm L) (φ : S 1) : + free ((Rew.rewrite fun x ↦ Rew.bShift (f x)) ▹ φ) = + Rew.rewrite (&0 :>ₙ fun x ↦ Rew.shift (f x)) ▹ free φ := + by + simpa [← comp_app] using + smul_ext' <| by ext x <;> simp [PointwiseComposition.Fin.Fin1.eq_one, Rew.comp_app] + +lemma shift_rewrite_eq (f : ℕ → SyntacticTerm L) (φ : S 0) : + shift (Rew.rewrite f ▹ φ) = (Rew.rewrite (&0 :>ₙ fun x ↦ Rew.shift (f x))) ▹ shift φ := by + simpa [← comp_app] using smul_ext' <| by ext x <;> simp [Rew.comp_app] + +lemma rewrite_subst_eq (f : ℕ → SyntacticTerm L) (t) (φ : S 1) : + Rew.rewrite f ▹ φ/[t] = (Rew.rewrite (Rew.bShift ∘ f) ▹ φ)/[Rew.rewrite f t] := by + simpa [← comp_app] using smul_ext' <| by ext x <;> simp [Rew.comp_app] + +@[simp] +lemma free_subst_nil (φ : S 0) : free (Rewriting.subst (ξ := ℕ) φ ![]) = shift φ := by + simpa [← comp_app] using + smul_ext' <| by + ext x <;> simp only [Rew.comp_app, Rew.subst_fvar, Rew.free_fvar, Rew.shift_fvar]; + { exact Fin.elim0 x + } + +lemma rewrite_subst_nil (f : ℕ → SyntacticTerm L) (φ : S 0) : + Rew.rewrite (Rew.bShift ∘ f) ▹ (Rewriting.subst (ξ := ℕ) φ ![]) = + Rewriting.subst (ξ := ℕ) (Rew.rewrite f ▹ φ) ![] := + by + simpa [← comp_app] using + smul_ext' <| by + ext x + · exact x.elim0 + · simp [Rew.comp_app, Rew.bShift_eq_rewrite] + +@[simp] +lemma cast_subst_eq (t : SyntacticTerm L) (φ : S 0) : + (Rewriting.subst (ξ := ℕ) φ ![])/[t] = φ := + by + suffices (Rewriting.subst (ξ := ℕ) φ ![])/[t] = Rew.id ▹ φ by + rwa [ReflectiveRewriting.id_app] at this + simpa [← comp_app, -id_app] using + smul_ext' <| + by + ext x <;> simp only [Rew.comp_app, Rew.subst_bvar, Rew.subst_fvar, Rew.id_app] + exact x.elim0 + +lemma rewrite_free_eq_subst (t : SyntacticTerm L) (φ : S 1) : + Rew.rewrite (t :>ₙ fun x ↦ &x) ▹ free φ = φ/[t] := by + simpa [← comp_app] using + smul_ext' <| by ext x <;> simp [PointwiseComposition.Fin.Fin1.eq_one, Rew.comp_app] + +/-- The shift Emb construction in `FFL.FirstOrder.LawfulSyntacticRewriting`. -/ +def shiftEmb : S n ↪ S n where + toFun := shift + inj' := shift_injective + +lemma shiftEmb_def (φ : S n) : shiftEmb φ = shift φ := + rfl + +lemma allClosure_fixitr (φ : S 0) : + ∀¹* Rew.fixitr 0 (m + 1) ▹ φ = ∀¹ Rew.fix ▹ (∀¹* Rew.fixitr 0 m ▹ φ) := by + simp [Rew.fixitr_succ, fix_allClosure, comp_app]; + +@[simp] +lemma mem_shifts_iff {φ : S n} {Γ : Multiset (S n)} : Rewriting.shift φ ∈ Γ⁺ ↔ φ ∈ Γ := + Multiset.mem_map_of_injective shift_injective + +@[simp] +lemma shifts_ss (Γ Δ : Multiset (S n)) : Γ⁺ ⊆ Δ⁺ ↔ Γ ⊆ Δ := + Multiset.map_subset_iff _ shift_injective + +end LawfulSyntacticRewriting + +namespace Rewriting + +variable {ο ξ : Type*} [IsEmpty ο] {O F F₁ F₂ : ℕ → Type*} [LCWQ O] [LCWQ F] [LCWQ F₁] [LCWQ F₂] + +open ReflectiveRewriting TransitiveRewriting InjMapRewriting Semiterm + +lemma emb_injective [Rewriting L ο O ξ F] [InjMapRewriting L ο O ξ F] : + Function.Injective fun φ : O n ↦ (emb (ξ := ξ) φ : F n) := + smul_map_injective Function.injective_id (IsEmpty.elim inferInstance) + +@[simp] +lemma emb_allClosure [Rewriting L ο O ξ F] {σ : O n} : + (emb (ξ := ξ) (∀¹* σ)) = ∀¹* (emb (ξ := ξ) σ) := by + induction n <;> simp [*, allClosure_succ] + +@[simp] +lemma rew_emb_eq_emb [Rewriting L ξ₁ F₁ ξ₂ F₂] [Rewriting L ο O ξ₁ F₁] [Rewriting L ο O ξ₂ F₂] + [TransitiveRewriting L ο O ξ₁ F₁ ξ₂ F₂] (φ : O 0) (ω : Rew L ξ₁ 0 ξ₂ 0) : + ω ▹ (emb (ξ := ξ₁) φ) = emb (ξ := ξ₂) φ := + by + unfold emb + rw [← comp_app] + congr 2 + simp + +/-- `coe_subst_eq_subst_coe` -/ +lemma emb_subst_eq_subst_emb [Rewriting L ο O ο O] [Rewriting L ο O ξ F] [Rewriting L ξ F ξ F] + [TransitiveRewriting L ο O ο O ξ F] [TransitiveRewriting L ο O ξ F ξ F] (φ : O k) + (v : Fin k → Semiterm L ο n) : + (emb (ξ := ξ) (φ ↜ v)) = + Rewriting.subst (ξ := ξ) (emb (ξ := ξ) φ) (fun i ↦ Rew.emb (v i)) := + by + unfold emb subst + rw [← comp_app, ← comp_app] + congr 2 + ext x + · simp [Rew.comp_app] + · exact IsEmpty.elim inferInstance x + +/-- `coe_subst_eq_subst_coe₁` -/ +lemma emb_subst_eq_subst_coe₁ [Rewriting L ο O ο O] [Rewriting L ο O ξ F] [Rewriting L ξ F ξ F] + [TransitiveRewriting L ο O ο O ξ F] [TransitiveRewriting L ο O ξ F ξ F] (φ : O 1) + (t : Semiterm L ο n) : + (emb (ξ := ξ) (φ/[t])) = (emb (ξ := ξ) φ)/[(Rew.emb t : Semiterm L ξ n)] := by + simpa [Matrix.constant_eq_singleton] using emb_subst_eq_subst_emb φ ![t] + +variable {S : ℕ → Type*} [LCWQ S] [SyntacticRewriting L S S] [LawfulSyntacticRewriting L S] + +@[simp] +lemma shifts_emb [Rewriting L ο O ℕ F] [Rewriting L ℕ F ℕ F] [TransitiveRewriting L ο O ℕ F ℕ F] + (Γ : Multiset (O n)) : (Γ.map (Rewriting.emb (ξ := ℕ)))⁺ = Γ.map (Rewriting.emb (ξ := ℕ)) := + by + suffices ∀ a ∈ Γ, shift (emb (ξ := ℕ) a) = emb (ξ := ℕ) a by simp [shifts, ← comp_app] + intro j hj + unfold emb shift + rw [← comp_app]; congr 2 + ext x <;> simp + +@[simp] +lemma subst1_bvar0_eq [Rewriting L ξ F ξ F] [ReflectiveRewriting L ξ F] (φ : F 1) : + φ/[(#0 : Semiterm L ξ 1)] = φ := + by + suffices φ/[(#0 : Semiterm L ξ 1)] = Rew.id ▹ φ by rwa [ReflectiveRewriting.id_app] at this + apply smul_ext' + ext x <;> simp [PointwiseComposition.Fin.Fin1.eq_one] + +end Rewriting + +end FirstOrder + +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/Syntax/Predicate/Term.lean b/LeanPool/PointwiseComposition/Foundation/Syntax/Predicate/Term.lean new file mode 100644 index 000000000..b7a758a59 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/Syntax/Predicate/Term.lean @@ -0,0 +1,345 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.Syntax.Predicate.Language +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.String + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +/-! +# Terms of first-order logic + +This file defines the terms of first-order logic. + +The bounded variables are denoted by `#x` for `x : Fin n`, and free variables are denoted by +`&x` for `x : ξ`. +`t : Semiterm L ξ n` is a (semi-)term of language `L` with bounded variables of `Fin n` and free +variables of `ξ`. + +-/ + +namespace FFL + +namespace FirstOrder + +/-- +A semiterm of language `L`, with bound variables indexed by `Fin n` and free variables indexed +by `ξ`. In `FFL.FirstOrder.Semiformula`, bound variables are de Bruijn indices with a separate +type from free variables. +-/ +inductive Semiterm (L : Language) (ξ : Type*) (n : ℕ) + | bvar : Fin n → Semiterm L ξ n + | fvar : ξ → Semiterm L ξ n + | func : ∀ {arity}, L.Func arity → (Fin arity → Semiterm L ξ n) → Semiterm L ξ n + +/-- `&x` is the free variable indexed by the element `x : ξ`. -/ +scoped prefix:max "&" => Semiterm.fvar + +/-- `#x` is the bound variable with de Bruijn index `x`. -/ +scoped prefix:max "#" => Semiterm.bvar + +/-- The Term construction in `FFL.FirstOrder`. -/ +abbrev Term (L : Language) (ξ : Type*) := + Semiterm L ξ 0 + +/-- The Closed Semiterm construction in `FFL.FirstOrder`. -/ +abbrev ClosedSemiterm (L : Language) (n : ℕ) := + Semiterm L Empty n + +/-- The Closed Term construction in `FFL.FirstOrder`. -/ +abbrev ClosedTerm (L : Language) := + Semiterm L Empty 0 + +/-- The Syntactic Semiterm construction in `FFL.FirstOrder`. -/ +abbrev SyntacticSemiterm (L : Language) (n : ℕ) := + Semiterm L ℕ n + +/-- The Syntactic Term construction in `FFL.FirstOrder`. -/ +abbrev SyntacticTerm (L : Language) := + SyntacticSemiterm L 0 + +namespace Semiterm + +variable {L L' L₁ L₂ L₃ : Language} {ξ ξ' ξ₁ ξ₂ ξ₃ : Type*} {n n₁ n₂ n₃ : ℕ} + +instance [Inhabited ξ] : Inhabited (Semiterm L ξ n) := + ⟨&default⟩ + +section ToString + +variable [∀ k, ToString (L.Func k)] [ToString ξ] + +/-- The to Str construction in `FFL.FirstOrder.Semiterm`. -/ +def toStr : Semiterm L ξ n → String + | #x => "x_{" ++ toString (n - 1 - (x : ℕ)) ++ "}" + | &x => "z_{" ++ toString x ++ "}" + | func (arity := 0) c _ => toString c + | func (arity := _ + 1) f v => + "{" ++ toString f ++ "} \\left(" ++ String.vecToStr (fun i => toStr (v i)) ++ "\\right)" + +instance : Repr (Semiterm L ξ n) := + ⟨fun t _ => toStr t⟩ + +instance : ToString (Semiterm L ξ n) := + ⟨toStr⟩ + +end ToString + +section Decidable + +variable [∀ k, DecidableEq (L.Func k)] [DecidableEq ξ] + +/-- The has Dec Eq construction in `FFL.FirstOrder.Semiterm`. -/ +def hasDecEq : (t u : Semiterm L ξ n) → Decidable (Eq t u) + | #x, #y => by simpa using decEq x y + | #_, &_ => isFalse (by simp) + | #_, func _ _ => isFalse (by simp) + | &_, #_ => isFalse (by simp) + | &x, &y => by simpa using decEq x y + | &_, func _ _ => isFalse (by simp) + | func _ _, #_ => isFalse (by simp) + | func _ _, &_ => isFalse (by simp) + | @func L ξ _ k₁ r₁ v₁, @func L ξ _ k₂ r₂ v₂ => + by + by_cases e : k₁ = k₂ + · rcases e with rfl + exact + match decEq r₁ r₂ with + | isTrue h => by simpa [h] using Matrix.decVec _ _ fun i ↦ hasDecEq (v₁ i) (v₂ i) + | isFalse h => isFalse (by simp [h]) + · exact isFalse (by simp [e]) + +instance : DecidableEq (Semiterm L ξ n) := + hasDecEq + +end Decidable + +/-- The complexity of a semiterm, taking suprema at function symbols. +-/ +def complexity : Semiterm L ξ n → ℕ + | #_ => 0 + | &_ => 0 + | func _ v => Finset.sup Finset.univ (fun i ↦ complexity (v i)) + 1 + +@[simp] +lemma complexity_bvar (x : Fin n) : (#x : Semiterm L ξ n).complexity = 0 := + rfl + +@[simp] +lemma complexity_fvar (x : ξ) : (&x : Semiterm L ξ n).complexity = 0 := + rfl + +lemma complexity_func {k} (f : L.Func k) (v : Fin k → Semiterm L ξ n) : + (func f v).complexity = Finset.sup Finset.univ (fun i ↦ complexity (v i)) + 1 := + rfl + +@[simp] +lemma complexity_func_lt {k} (f : L.Func k) (v : Fin k → Semiterm L ξ n) (i) : + (v i).complexity < (func f v).complexity := by + simpa [complexity_func, Nat.lt_add_one_iff] using + Finset.le_sup (f := fun i ↦ complexity (v i)) (by simp) + +/-- The func! construction in `FFL.FirstOrder.Semiterm`. -/ +abbrev funcWithArity (k) (f : L.Func k) (v : Fin k → Semiterm L ξ n) := + func f v + +/-- The set of bound variables occurring in a semiterm. +-/ +def bv : Semiterm L ξ n → Finset (Fin n) + | #x => { x } + | &_ => ∅ + | func _ v => .biUnion .univ fun i ↦ bv (v i) + +@[simp] +lemma bv_bvar : (#x : Semiterm L ξ n).bv = { x } := + rfl + +@[simp] +lemma bv_fvar : (&x : Semiterm L ξ n).bv = ∅ := + rfl + +lemma bv_func {k} (f : L.Func k) (v : Fin k → Semiterm L ξ n) : + (func f v).bv = .biUnion .univ fun i ↦ bv (v i) := + rfl + +@[simp] +lemma bv_constant (f : L.Func 0) (v : Fin 0 → Semiterm L ξ n) : (func f v).bv = ∅ := + rfl + +/-- The Positive construction in `FFL.FirstOrder.Semiterm`. -/ +def Positive (t : Semiterm L ξ (n + 1)) : Prop := + ∀ x ∈ t.bv, 0 < x + +namespace Positive + +@[simp] +protected lemma bvar : Positive (#x : Semiterm L ξ (n + 1)) ↔ 0 < x := by simp [Positive] + +@[simp] +protected lemma fvar : Positive (&x : Semiterm L ξ (n + 1)) := by simp [Positive] + +@[simp] +protected lemma func {k} (f : L.Func k) (v : Fin k → Semiterm L ξ (n + 1)) : + Positive (func f v) ↔ ∀ i, Positive (v i) := by simpa [Positive, bv] using forall_comm + +end Positive + +lemma bv_eq_empty_of_positive {t : Semiterm L ξ 1} (ht : t.Positive) : t.bv = ∅ := + Finset.eq_empty_of_forall_notMem <| by simp_all [Positive] + +section freeVariables + +variable [DecidableEq ξ] + +/-- The set of free variables occuring in a semiterm. +-/ +def freeVariables : Semiterm L ξ n → Finset ξ + | #_ => ∅ + | &x => { x } + | func _ v => .biUnion .univ fun i ↦ freeVariables (v i) + +@[simp] +lemma freeVariables_bvar : (#x : Semiterm L ξ n).freeVariables = ∅ := + rfl + +@[simp] +lemma freeVariables_fvar : (&x : Semiterm L ξ n).freeVariables = { x } := + rfl + +lemma freeVariables_func {k} (f : L.Func k) (v : Fin k → Semiterm L ξ n) : + (func f v).freeVariables = .biUnion .univ fun i ↦ (v i).freeVariables := + rfl + +@[simp] +lemma freeVariables_constant (f : L.Func 0) (v : Fin 0 → Semiterm L ξ n) : + (func f v).freeVariables = ∅ := + rfl + +@[simp] +lemma freeVariables_empty {ο : Type*} [IsEmpty ο] {t : Semiterm L ο n} : t.freeVariables = ∅ := + by ext x; exact IsEmpty.elim inferInstance x + +/-- The FVar? construction in `FFL.FirstOrder.Semiterm`. -/ +abbrev HasFreeVariable (t : Semiterm L ξ n) (x : ξ) : Prop := + x ∈ t.freeVariables + +@[simp] +lemma hasFreeVariable_bvar (x z) : ¬(#x : Semiterm L ξ n).HasFreeVariable z := by + simp [HasFreeVariable] + +@[simp] +lemma hasFreeVariable_fvar (x z) : (&x : Semiterm L ξ n).HasFreeVariable z ↔ x = z := by + simp [HasFreeVariable, Eq.comm] + +@[simp] +lemma hasFreeVariable_func (x) {k} (f : L.Func k) (v : Fin k → Semiterm L ξ n) : + (func f v).HasFreeVariable x ↔ ∃ i, (v i).HasFreeVariable x := by + simp [HasFreeVariable, freeVariables_func] + +end freeVariables + +section lMap + +variable (Φ : L₁ →ᵥ L₂) + +/-- The map on terms induced from a homomorphism between languages. +-/ +def lMap (Φ : L₁ →ᵥ L₂) : Semiterm L₁ ξ n → Semiterm L₂ ξ n + | #x => #x + | &x => &x + | func f v => func (Φ.func f) fun i ↦ lMap Φ (v i) + +@[simp] +lemma lMap_bvar (x : Fin n) : (#x : Semiterm L₁ ξ n).lMap Φ = #x := + rfl + +@[simp] +lemma lMap_fvar (x : ξ) : (&x : Semiterm L₁ ξ n).lMap Φ = &x := + rfl + +@[simp] +lemma lMap_func {k} (f : L₁.Func k) (v : Fin k → Semiterm L₁ ξ n) : + (func f v).lMap Φ = func (Φ.func f) (lMap Φ ∘ v) := + rfl + +lemma lMap_func' {k} (f : L₁.Func k) (v : Fin k → Semiterm L₁ ξ n) : + (func f v).lMap Φ = func (Φ.func f) fun i ↦ lMap Φ (v i) := + rfl + +@[simp] +lemma lMap_positive (t : Semiterm L₁ ξ (n + 1)) : (t.lMap Φ).Positive ↔ t.Positive := by + induction t <;> simp [lMap_func, *] + +@[simp] +lemma freeVariables_lMap [DecidableEq ξ] (Φ : L₁ →ᵥ L₂) (t : Semiterm L₁ ξ n) : + (Semiterm.lMap Φ t).freeVariables = t.freeVariables := + by + induction t + case bvar => simp + case fvar => simp + case func k f v ih => ext x; simp [lMap_func, freeVariables_func, ih] + +end lMap + +section + +variable [L.ConstantInhabited] + +instance : Inhabited (Semiterm L ξ n) := + ⟨func default ![]⟩ + +lemma default_def : (default : Semiterm L ξ n) = func default ![] := + rfl + +end + +section idxOfFVar + +/-- The fvar List construction in `FFL.FirstOrder.Semiterm`. -/ +def fvarList : Semiterm L ξ n → List ξ + | #_ => [] + | &x => [x] + | func _ v => List.flatten <| Matrix.toList fun i ↦ fvarList (v i) + +/-- The idx Of FVar construction in `FFL.FirstOrder.Semiterm`. -/ +def idxOfFVar [DecidableEq ξ] (t : Semiterm L ξ n) : ξ → ℕ := + t.fvarList.idxOf + +/-- The enumerate FVar construction in `FFL.FirstOrder.Semiterm`. -/ +def enumerateFVar [Inhabited ξ] (t : Semiterm L ξ n) : ℕ → ξ := fun i ↦ + if hi : i < t.fvarList.length then t.fvarList.get ⟨i, hi⟩ else default + +lemma enumerateFVar_idxOfFVar [DecidableEq ξ] [Inhabited ξ] {t : Semiterm L ξ n} {x : ξ} + (hx : x ∈ t.fvarList) : enumerateFVar t (idxOfFVar t x) = x := by + simpa [enumerateFVar, idxOfFVar] using fun h ↦ + False.elim <| not_le.mpr (List.idxOf_lt_length_iff.mpr <| hx) h + +lemma mem_fvarList_iff_hasFreeVariable [DecidableEq ξ] {t : Semiterm L ξ n} : + x ∈ t.fvarList ↔ t.HasFreeVariable x := by + induction t <;> + { simp [fvarList, *]; try tauto + } + +end idxOfFVar + +end Semiterm + +end FirstOrder + +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/Vorspiel/AdjunctiveSet.lean b/LeanPool/PointwiseComposition/Foundation/Vorspiel/AdjunctiveSet.lean new file mode 100644 index 000000000..96b25cc88 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/Vorspiel/AdjunctiveSet.lean @@ -0,0 +1,180 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import Mathlib.Data.Set.Finite.Basic + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +/-- Data and laws for Adjoin in `Adjoin`. -/ +class Adjoin (β : outParam Type*) (α : Type*) where + /-- The adjoin construction in `adjoin`. -/ + adjoin : β → α → α + +export Adjoin (adjoin) + +instance (α : Type*) : Adjoin α (Set α) := + ⟨insert⟩ + +instance (α : Type*) : Adjoin α (List α) := + ⟨List.cons⟩ + +instance (α : Type*) : Adjoin α (Multiset α) := + ⟨Multiset.cons⟩ + +instance (α : Type*) [DecidableEq α] : Adjoin α (Finset α) := + ⟨insert⟩ + +/-- Data and laws for Adjunctive Set in `AdjunctiveSet`. -/ +class AdjunctiveSet (β : outParam Type*) (α : Type*) extends Membership β α, HasSubset α, + EmptyCollection α, Adjoin β α where + subset_iff {a b : α} : a ⊆ b ↔ ∀ x ∈ a, x ∈ b + not_mem_empty (x : β) : ¬x ∈ (∅ : α) + mem_cons_iff {x z : β} {a : α} : x ∈ adjoin z a ↔ x = z ∨ x ∈ a + +attribute [simp] AdjunctiveSet.not_mem_empty AdjunctiveSet.mem_cons_iff + +instance Set.adjunctiveSet : AdjunctiveSet α (Set α) + where + Subset := (· ⊆ ·) + subset_iff := iff_of_eq Set.subset_def + not_mem_empty := by simp + mem_cons_iff := by simp [Adjoin.adjoin] + +instance List.adjunctiveSet : AdjunctiveSet α (List α) + where + subset_iff := List.subset_def + not_mem_empty := by simp + mem_cons_iff := by simp [Adjoin.adjoin] + +instance Multiset.adjunctiveSet : AdjunctiveSet α (Multiset α) + where + subset_iff := Multiset.subset_iff + not_mem_empty := by simp + mem_cons_iff := by simp [Adjoin.adjoin] + +instance Finset.adjunctiveSet [DecidableEq α] : AdjunctiveSet α (Finset α) + where + Subset := (· ⊆ ·) + subset_iff := Finset.subset_iff + not_mem_empty := by simp + mem_cons_iff := by simp [Adjoin.adjoin] + +namespace AdjunctiveSet + +variable {β α : Type*} [AdjunctiveSet β α] + +/-- The set construction in `AdjunctiveSet`. -/ +def set : α → Set β := fun a ↦ {x | x ∈ a} + +@[simp] +lemma mem_set_iff {x : β} {a : α} : x ∈ (set a : Set β) ↔ x ∈ a := by simp [set] + +lemma subset_iff_set_subset_set {a b : α} : a ⊆ b ↔ set a ⊆ set b := by simp [subset_iff, set] + +@[simp, refl] +lemma subset_refl (a : α) : a ⊆ a := + subset_iff_set_subset_set.mpr (Set.Subset.refl _) + +@[trans] +lemma subset_trans {a b c : α} (ha : a ⊆ b) (hb : b ⊆ c) : a ⊆ c := + subset_iff_set_subset_set.mpr + (Set.Subset.trans (subset_iff_set_subset_set.mp ha) (subset_iff_set_subset_set.mp hb)) + +lemma subset_antisymm {a b : α} (ha : a ⊆ b) (hb : b ⊆ a) : set a = set b := + Set.Subset.antisymm (subset_iff_set_subset_set.mp ha) (subset_iff_set_subset_set.mp hb) + +@[simp] +lemma empty_subset (a : α) : ∅ ⊆ a := by simp [subset_iff] + +lemma mem_cons (a : α) (x : β) : x ∈ adjoin x a := by simp [mem_cons_iff] + +@[simp] +lemma subset_cons (a : α) (x : β) : a ⊆ adjoin x a := by simp [subset_iff, mem_cons_iff]; tauto + +@[simp] +lemma set_empty : set (∅ : α) = ∅ := by ext; simp [set] + +@[simp] +lemma set_cons (z : β) (a : α) : set (adjoin z a) = insert z (set a) := by ext; simp [set] + +/-- The Finite construction in `AdjunctiveSet`. -/ +def Finite (a : α) : Prop := + (set a).Finite + +@[simp] +lemma empty_finite : Finite (∅ : α) := by simp [Finite] + +lemma Finite.of_subset {a b : α} (ha : Finite a) (h : b ⊆ a) : Finite b := + Set.Finite.subset ha (subset_iff_set_subset_set.mp h) + +@[simp] +lemma cons_finite_iff {z : β} {a : α} : Finite (adjoin z a) ↔ Finite a := + ⟨fun h ↦ h.of_subset (by simp), by simp [Finite]⟩ + +/-- The add List construction in `AdjunctiveSet`. -/ +def addList (a : α) : List β → α + | [] => a + | x :: xs => adjoin x (addList a xs) + +/-- The to Adjunctive Set construction in `List`. -/ +def _root_.PointwiseComposition.List.toAdjunctiveSet : List β → α + | [] => ∅ + | x :: xs => adjoin x (List.toAdjunctiveSet xs) + +/-- The to Adjunctive Set construction in `Finset`. -/ +noncomputable def _root_.PointwiseComposition.Finset.toAdjunctiveSet : Finset β → α := fun s ↦ + List.toAdjunctiveSet s.toList + +@[simp] +lemma mem_list_toAdjunctiveSet {x : β} {l : List β} : + x ∈ (List.toAdjunctiveSet l : α) ↔ x ∈ l := by + induction l <;> simp [List.toAdjunctiveSet, *] + +@[simp] +lemma mem_finset_toAdjunctiveSet {x : β} {s : Finset β} : + x ∈ (Finset.toAdjunctiveSet s : α) ↔ x ∈ s := by simp [Finset.toAdjunctiveSet] + +@[simp] +lemma list_toAdjunctiveSet_finite (l : List β) : Finite (List.toAdjunctiveSet l : α) := by + simp [Finite, set] + +@[simp] +lemma finset_toAdjunctiveSet_finite (s : Finset β) : Finite (Finset.toAdjunctiveSet s : α) := by + simp [Finite, set] + +end AdjunctiveSet + +namespace Set + +open _root_.Set + +variable {α : Type*} + +lemma cons_eq (a : α) (s : Set α) : adjoin a s = insert a s := + rfl + +@[simp] +lemma adjunctiveSet_set (s : Set α) : AdjunctiveSet.set s = s := + rfl + +@[simp] +lemma adjunctiveSet_finite_iff (s : Set α) : AdjunctiveSet.Finite s ↔ s.Finite := by + simp [AdjunctiveSet.Finite] + +end Set + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/Vorspiel/Arithmetic.lean b/LeanPool/PointwiseComposition/Foundation/Vorspiel/Arithmetic.lean new file mode 100644 index 000000000..ea965c50c --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/Vorspiel/Arithmetic.lean @@ -0,0 +1,811 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.List.Basic +public import Mathlib.Computability.Halting +public import Mathlib.Computability.PartrecBasis +public import Mathlib.Logic.Godel.GodelBetaFunction + +/-! Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +open _root_.Part Mathlib _root_.List.Vector Part + +namespace Nat + +open _root_.Nat +lemma pos_of_eq_one (h : n = 1) : 0 < n := by simp [h] + +/-- The is Eq Nat construction in `Nat`. -/ +def isEqNat (n m : ℕ) : ℕ := + if n = m then 1 else 0 + +/-- The is Lt Nat construction in `Nat`. -/ +def isLtNat (n m : ℕ) : ℕ := + if n < m then 1 else 0 + +/-- The is Le Nat construction in `Nat`. -/ +def isLeNat (n m : ℕ) : ℕ := + if n ≤ m then 1 else 0 + +/-- The is Dvd Nat construction in `Nat`. -/ +def isDvdNat (n m : ℕ) : ℕ := + if n ∣ m then 1 else 0 + +@[simp] lemma isEqNat_pos_iff : 0 < isEqNat n m ↔ n = m := by + simp [isEqNat]; by_cases n = m <;> simp [*] + +@[simp] lemma isLtNat_pos_iff : 0 < isLtNat n m ↔ n < m := by + simp [isLtNat]; by_cases n < m <;> simp [*] + +@[simp] lemma isLeNat_pos_iff : 0 < isLeNat n m ↔ n ≤ m := by + simp [isLeNat]; by_cases n ≤ m <;> simp [*] + +@[simp] lemma isDvdNat_pos_iff : 0 < isDvdNat n m ↔ n ∣ m := by + simp [isDvdNat]; by_cases n ∣ m <;> simp [*] + +/-- The inv construction in `Nat`. -/ +def inv (n : ℕ) : ℕ := + isEqNat n 0 + +/-- The pos construction in `Nat`. -/ +def pos (n : ℕ) : ℕ := + isLtNat 0 n + +@[simp] +lemma inv_zero : inv 0 = 1 := + rfl + +@[simp] +lemma inv_iff_ne_zero : inv n = 0 ↔ 0 < n := by simp [inv, isEqNat, zero_lt_iff] + +@[simp] +lemma inv_ne_zero (h : n ≠ 0) : inv n = 0 := by simp [inv, isEqNat, h] + +@[simp] +lemma pos_zero : pos 0 = 0 := + rfl + +@[simp] +lemma pos_ne_zero (h : n ≠ 0) : pos n = 1 := by simp [pos, isLtNat, h] + +/-- The and construction in `Nat`. -/ +def and (n m : ℕ) : ℕ := + isLtNat 0 (n * m) + +/-- The or construction in `Nat`. -/ +def or (n m : ℕ) : ℕ := + isLtNat 0 (n + m) + +lemma and_eq (n m : ℕ) : and n m = if 0 < n ∧ 0 < m then 1 else 0 := by + simp [mul_pos_iff, and, isLtNat] + +lemma and_eq_one (n m : ℕ) : and n m = 1 ↔ 0 < n ∧ 0 < m := by + simp [and_eq, imp_false, Nat.pos_iff_ne_zero] + +lemma or_eq (n m : ℕ) : or n m = if 0 < n ∨ 0 < m then 1 else 0 := by simp [or, isLtNat] + +@[simp] lemma and_pos_iff (n m : ℕ) : 0 < and n m ↔ 0 < n ∧ 0 < m := by + simp [and_eq]; by_cases 0 < n ∧ 0 < m <;> simp [*] + +@[simp] lemma orNat_pos_iff (n m : ℕ) : 0 < or n m ↔ 0 < n ∨ 0 < m := by + simp [or_eq]; by_cases 0 < n ∨ 0 < m <;> simp [*] + +@[simp] +lemma inv_pos_iff (n : ℕ) : 0 < inv n ↔ ¬0 < n := by simp [inv] + +@[simp] +lemma pos_pos_iff (n : ℕ) : 0 < pos n ↔ 0 < n := by simp [pos] + +/-- The ball construction in `Nat`. -/ +def ball (n : ℕ) (φ : ℕ → ℕ) : ℕ := + n.rec 1 (fun n ih => (PointwiseComposition.Nat.and (PointwiseComposition.Nat.pos (φ n))) ih) + +@[simp] +lemma ball_pos_iff {φ : ℕ → ℕ} {n : ℕ} : 0 < ball n φ ↔ ∀ m < n, 0 < φ m := + by + induction n + · simp [ball] + · grind only [ball, and, pos, isLtNat, => zero_lt_of_not_zero] + +@[simp] +lemma ball_eq_zero_iff {φ : ℕ → ℕ} {n : ℕ} : ball n φ = 0 ↔ ∃ m < n, φ m = 0 := by + simpa [-ball_pos_iff] using not_iff_not.mpr (ball_pos_iff (φ := φ) (n := n)) + +lemma ball_pos_iff_eq_one {φ : ℕ → ℕ} {n : ℕ} : ball n φ = 1 ↔ 0 < ball n φ := + by + induction n + · simp [ball] + · grind only [=> zero_lt_of_not_zero, ball, and, isLtNat] + +/-- Data and laws for Arith Part₁ in `Nat`. -/ +inductive ArithPart₁ : ∀ {n}, (List.Vector ℕ n →. ℕ) → Prop + | zero {n} : @ArithPart₁ n (fun _ => 0) + | one {n} : @ArithPart₁ n (fun _ => 1) + | add {n} (i j : Fin n) : @ArithPart₁ n (fun v => v.get i + v.get j : List.Vector ℕ n → ℕ) + | mul {n} (i j : Fin n) : @ArithPart₁ n (fun v => v.get i * v.get j : List.Vector ℕ n → ℕ) + | proj {n} (i : Fin n) : @ArithPart₁ n (fun v => v.get i : List.Vector ℕ n → ℕ) + | + equal {n} (i j : Fin n) : + @ArithPart₁ n (fun v => isEqNat (v.get i) (v.get j) : List.Vector ℕ n → ℕ) + | + lt {n} (i j : Fin n) : + @ArithPart₁ n (fun v => isLtNat (v.get i) (v.get j) : List.Vector ℕ n → ℕ) + | + comp {m n f} (g : Fin n → List.Vector ℕ m →. ℕ) : + ArithPart₁ f → + (∀ i, ArithPart₁ (g i)) → ArithPart₁ fun v => (List.Vector.mOfFn fun i => g i v) >>= f + | + rfind {n} {f : List.Vector ℕ (n + 1) → ℕ} : + ArithPart₁ (n := n + 1) f → ArithPart₁ (fun v => rfind fun n => Part.some (f (n ::ᵥ v) = 0)) + +/-- The Arithmetic₁ construction in `Nat`. -/ +def Arithmetic₁ (f : List.Vector ℕ n → ℕ) := + ArithPart₁ (n := n) f + +end Nat + +namespace Nat +namespace ArithPart₁ + +open _root_.Nat +open _root_.Nat +open _root_.Primrec + +lemma to_partrec' {n} {f : List.Vector ℕ n →. ℕ} (hf : ArithPart₁ f) : Partrec' f := + by + induction hf + case zero => exact Partrec'.of_part (Partrec.const' 0) + case one => exact Partrec'.of_part (Partrec.const' 1) + case add n i j => + exact + (Partrec'.of_part + ((Primrec.nat_add.comp + (Primrec.vector_get.comp _root_.Primrec.id (_root_.Primrec.const i)) + (Primrec.vector_get.comp _root_.Primrec.id + (_root_.Primrec.const j))).to_comp.partrec)) + case mul n i j => + exact + (Partrec'.of_part + ((Primrec.nat_mul.comp + (Primrec.vector_get.comp _root_.Primrec.id (_root_.Primrec.const i)) + (Primrec.vector_get.comp _root_.Primrec.id + (_root_.Primrec.const j))).to_comp.partrec)) + case proj n i => + exact + Partrec'.of_part + (Primrec.vector_get.comp _root_.Primrec.id (_root_.Primrec.const i)).to_comp.partrec + case equal n i + j => + have : Primrec (fun (v : List.Vector ℕ n) => if v.get i = v.get j then 1 else 0) := + Primrec.ite + (Primrec.eq.comp (Primrec.vector_get.comp _root_.Primrec.id (_root_.Primrec.const i)) + (Primrec.vector_get.comp _root_.Primrec.id (_root_.Primrec.const j))) + (_root_.Primrec.const 1) (_root_.Primrec.const 0) + exact Partrec'.of_part this.to_comp.partrec + case lt n i + j => + have : Primrec (fun (v : List.Vector ℕ n) => if v.get i < v.get j then 1 else 0) := + Primrec.ite + (Primrec.nat_lt.comp + (Primrec.vector_get.comp _root_.Primrec.id (_root_.Primrec.const i)) + (Primrec.vector_get.comp _root_.Primrec.id (_root_.Primrec.const j))) + (_root_.Primrec.const 1) (_root_.Primrec.const 0) + exact Partrec'.of_part this.to_comp.partrec + case comp m n f g _ _ hf hg => exact Partrec'.comp g hf hg + case rfind f _ hf => exact Partrec'.rfind hf + +lemma of_eq {n} {f g : List.Vector ℕ n →. ℕ} (hf : ArithPart₁ f) (H : ∀ i, f i = g i) : + ArithPart₁ g := + (funext H : f = g) ▸ hf + +lemma bind (f : List.Vector ℕ n → ℕ →. ℕ) (hf : @ArithPart₁ (n + 1) fun v => f v.tail v.head) + {g} (hg : @ArithPart₁ n g) : + @ArithPart₁ n fun v ↦ (g v).bind (f v) := + (hf.comp (g :> fun i v ↦ v.get i) (fun i ↦ by + cases i using Fin.cases + · simp_all + · solve_by_elim)).of_eq (by + intro v; simp only [succ_eq_add_one, coe_some, bind_eq_bind] + rcases Part.eq_none_or_eq_some (g v) with (hgv | ⟨x, hgv⟩) + · simp only [mOfFn, Matrix.cons_val, hgv, pure_eq_some, bind_eq_bind, bind_none] + exact (Part.bind_none _).symm + · simp only [hgv] + have : List.Vector.mOfFn (fun i => (g :> fun j v => Part.some <| v.get j) i v) = pure + (List.Vector.ofFn (x :> fun j => v.get j)) := by + rw [←List.Vector.mOfFn_pure]; apply congr_arg + funext i; cases i using Fin.cases + -- `simp [hgv]` here triggers a simproc panic (`Lean.Expr.appArg!`, reached via + -- `Simp.SimprocEntry.try`): deterministic, but non-fatal, so the build still + -- succeeds. This `simp only` + `exact` avoids the unrestricted simp set that pulls + -- the offending simproc in. Still reproduces verbatim on v4.34.0, so keep this + -- until an upstream fix actually lands. + · simp only [Matrix.cons_val_zero]; exact hgv.trans (Part.pure_eq_some x).symm + · rfl + simp only [this, succ_eq_add_one, pure_eq_some, bind_some, tail_ofFn, Matrix.cons_val_succ, + ofFn_get, head_ofFn, Matrix.cons_val_zero] + exact (Part.bind_some x (f v)).symm) + + + +lemma map (f : List.Vector ℕ n → ℕ → ℕ) (hf : @Arithmetic₁ (n + 1) fun v => f v.tail v.head) {g} + (hg : @ArithPart₁ n g) : + @ArithPart₁ n fun v => (g v).map (f v) := + (bind (Part.some <| f · ·) (hf.of_eq <| by simp) hg).of_eq <| by + intro v; rcases Part.eq_none_or_eq_some (g v) with (_ | ⟨x, _⟩) <;> simp [*] + +lemma comp₁ (f : ℕ →. ℕ) (hf : @ArithPart₁ 1 fun v => f (v.get 0)) {n g} + (hg : @Arithmetic₁ n g) : @ArithPart₁ n fun v => f (g v) := + (hf.comp _ fun _ => hg).of_eq (by simp) + +lemma comp₂ (f : ℕ → ℕ →. ℕ) (hf : @ArithPart₁ 2 fun v => f (v.get 0) (v.get 1)) {n g h} (hg : + @Arithmetic₁ n g) (hh : @Arithmetic₁ n h) : + @ArithPart₁ n fun v => f (g v) (h v) := + (hf.comp ![g, h] (fun i => i.cases hg (fun i => by + simp only [Matrix.cons_val_succ, Matrix.cons_val_fin_one] + exact hh))).of_eq + (by intro i + have : (fun j ↦ (![↑g, h] : Fin 2 → List.Vector ℕ n →. ℕ) j i) = + (fun j => pure (![g i, h i] j)) := by + funext j; cases j using Fin.cases <;> simp + simp [this]) + +lemma rfind' {n} {f : ℕ → List.Vector ℕ n → ℕ} + (h : Arithmetic₁ (n := n + 1) (fun v => f v.head v.tail)) : + ArithPart₁ (fun v => Nat.rfind fun n => Part.some (f n v = 0)) := + rfind h + +lemma rfind'₁ {n} (i : Fin n) {f : ℕ → ℕ → ℕ} + (h : Arithmetic₁ (n := 2) (fun v => f (v.get 0) (v.get 1))) : + ArithPart₁ (fun v => Nat.rfind fun n => Part.some (f n (v.get i) = 0)) := + (rfind h).comp₁ (fun m => Nat.rfind fun n => Part.some (f n m = 0)) (proj i) + +end ArithPart₁ +end Nat + +namespace Nat +namespace Arithmetic₁ + +open _root_.Nat +open _root_.Nat +lemma of_eq {n} {f g : List.Vector ℕ n → ℕ} (hf : Arithmetic₁ f) (H : ∀ i, f i = g i) : + Arithmetic₁ g := + (funext H : f = g) ▸ hf + +lemma zero {n} : @Arithmetic₁ n (fun _ => 0 : List.Vector ℕ n → ℕ) := + Nat.ArithPart₁.zero + +lemma one {n} : @Arithmetic₁ n (fun _ => 1 : List.Vector ℕ n → ℕ) := + Nat.ArithPart₁.one + +lemma add {n} (i j : Fin n) : @Arithmetic₁ n (fun v => v.get i + v.get j) := + Nat.ArithPart₁.add i j + +lemma mul {n} (i j : Fin n) : @Arithmetic₁ n (fun v => v.get i * v.get j) := + Nat.ArithPart₁.mul i j + +lemma proj {n} (i : Fin n) : @Arithmetic₁ n (fun v => v.get i) := + Nat.ArithPart₁.proj i + +lemma head {n} : @Arithmetic₁ (n + 1) (fun v => v.head) := + (Nat.ArithPart₁.proj 0).of_eq <| by simp + +lemma equal {n} (i j : Fin n) : @Arithmetic₁ n (fun v => isEqNat (v.get i) (v.get j)) := + Nat.ArithPart₁.equal i j + +lemma lt {n} (i j : Fin n) : @Arithmetic₁ n (fun v => isLtNat (v.get i) (v.get j)) := + Nat.ArithPart₁.lt i j + +lemma comp {m n f} (g : Fin n → List.Vector ℕ m → ℕ) (hf : Arithmetic₁ f) + (hg : ∀ i, Arithmetic₁ (g i)) : Arithmetic₁ fun v => f (List.Vector.ofFn fun i => g i v) := + (Nat.ArithPart₁.comp (fun i => g i : Fin n → List.Vector ℕ m →. ℕ) hf hg).of_eq <| + by + intro i; simp only [Vector.mOfFn_part_some, PFun.coe_val] + exact (Part.bind_eq_bind _ _).trans ((Part.bind_some _ _).trans (PFun.coe_val f _)) + +/-- The Vec construction in `Nat.Arithmetic₁`. -/ +def Vec {n m} (f : List.Vector ℕ n → List.Vector ℕ m) : Prop := + ∀ i, Arithmetic₁ fun v => (f v).get i + +protected lemma nil {n} : @Vec n 0 (fun _ => nil) := fun i => i.elim0 + +protected lemma cons {n m f g} (hf : @Arithmetic₁ n f) (hg : @Vec n m g) : + Vec (fun v => f v ::ᵥ g v) := fun i => Fin.cases (by simp [*]) (fun i => by simp [hg i]) i + +lemma tail {n f} (hf : @Arithmetic₁ n f) : @Arithmetic₁ n.succ fun v => f v.tail := + (hf.comp _ fun i => @proj _ i.succ).of_eq fun v => by + rw [←ofFn_get v.tail]; congr; funext i; simp + +lemma comp' {n m f g} (hf : @Arithmetic₁ m f) (hg : @Vec n m g) : + Arithmetic₁ fun v => f (g v) := + (hf.comp _ hg).of_eq fun v => by simp + +lemma comp₁ (f : ℕ → ℕ) (hf : @Arithmetic₁ 1 fun v => f (v.get 0)) {n g} + (hg : @Arithmetic₁ n g) : @Arithmetic₁ n fun v => f (g v) := + (hf.comp _ fun _ => hg).of_eq (by simp) + +lemma comp₂ (f : ℕ → ℕ → ℕ) (hf : @Arithmetic₁ 2 fun v => f (v.get 0) (v.get 1)) {n g h} (hg : + @Arithmetic₁ n g) (hh : @Arithmetic₁ n h) : + @Arithmetic₁ n fun v => f (g v) (h v) := + (hf.comp ![g, h] (fun i => i.cases hg (fun i => by + simp only [Matrix.cons_val_succ, Matrix.cons_val_fin_one] + exact hh))).of_eq (by simp) + +lemma succ {n} (i : Fin n) : Arithmetic₁ (fun v => v.get i + 1) := + (add 0 1).comp₂ _ (proj i) one + +lemma const {n} : ∀ m, @Arithmetic₁ n fun _ => m + | 0 => zero + | m + 1 => (succ 0).comp₁ _ (const m) + +lemma inv {n} (i : Fin n) : Arithmetic₁ (fun v => inv (v.get i)) := + (equal 0 1).comp₂ _ (proj i) zero + +lemma pos {n} (i : Fin n) : Arithmetic₁ (fun v => pos (v.get i)) := + (lt 0 1).comp₂ _ zero (proj i) + +lemma and {n} (i j : Fin n) : Arithmetic₁ (fun v => and (v.get i) (v.get j)) := + (lt 0 1).comp₂ _ zero (mul i j) + +lemma or {n} (i j : Fin n) : Arithmetic₁ (fun v => or (v.get i) (v.get j)) := + (lt 0 1).comp₂ _ zero (add i j) + +lemma le {n} (i j : Fin n) : @Arithmetic₁ n (fun v => isLeNat (v.get i) (v.get j)) := + ((or 0 1).comp₂ _ (lt i j) (equal i j)).of_eq <| by + simp [Nat.or_eq, Nat.le_iff_lt_or_eq, isLeNat] + +lemma if_pos {n} {f g h : List.Vector ℕ n → ℕ} (hf : Arithmetic₁ f) (hg : Arithmetic₁ g) + (hh : Arithmetic₁ h) : Arithmetic₁ (fun v => if 0 < f v then g v else h v) := + by + have : + Arithmetic₁ + (fun v => + (PointwiseComposition.Nat.pos (f v)) * (g v) + + (PointwiseComposition.Nat.inv (f v)) * (h v)) := + (add 0 1).comp₂ _ ((mul 0 1).comp₂ _ ((pos 0).comp₁ _ hf) hg) + ((mul 0 1).comp₂ _ ((inv 0).comp₁ _ hf) hh) + exact this.of_eq <| by intro i; by_cases hf : f i = 0 <;> simp [hf, zero_lt_iff] + +lemma to_arith₁ {f : List.Vector ℕ n → ℕ} (h : Arithmetic₁ f) : @ArithPart₁ n (fun x => f x) := + h + +end Arithmetic₁ +end Nat + +namespace Nat +namespace ArithPart₁ + +open _root_.Nat +open _root_.Nat +lemma rfindPos {n} {f : List.Vector ℕ (n + 1) → ℕ} (h : Arithmetic₁ f) : + ArithPart₁ (fun v => Nat.rfind fun n => Part.some (0 < f (n ::ᵥ v))) := + (ArithPart₁.rfind + ((Arithmetic₁.inv 0).comp₁ _ ((Arithmetic₁.lt 0 1).comp₂ _ zero h))).of_eq <| + by simp + +lemma rfindPos₁ {n} (i : Fin n) {f : ℕ → ℕ → ℕ} + (h : Arithmetic₁ (n := 2) (fun v => f (v.get 0) (v.get 1))) : + ArithPart₁ (fun v => Nat.rfind fun n => Part.some (0 < f n (v.get i))) := + (rfindPos h).comp₁ (fun m => Nat.rfind fun n => Part.some (0 < f n m)) (proj i) + +lemma inv_fun {n} (i : Fin n) (f : ℕ → ℕ) (hf : Arithmetic₁ (n := 1) (fun v => f (v.get 0))) : + ArithPart₁ + (fun v => Nat.rfind (fun x => Part.some (f x ≤ v.get i ∧ v.get i < f (x + 1)))) := + by + let F : ℕ → ℕ → ℕ := fun x y => + (PointwiseComposition.Nat.and (isLeNat (f x) y)) (isLtNat y (f (x + 1))) + have := + rfindPos₁ i (f := F) <| + (Arithmetic₁.and 0 1).comp₂ _ + ((Arithmetic₁.le 0 1).comp₂ _ (hf.comp₁ _ (proj 0)) (proj 1)) + ((Arithmetic₁.lt 0 1).comp₂ _ (proj 1) + (hf.comp₁ _ <| (Arithmetic₁.succ 0).comp₁ _ <| proj 0)) + exact this.of_eq <| by intro v; simp [F] + +lemma implicit_fun {n} (i : Fin n) (f : List.Vector ℕ n → ℕ → ℕ) + (hf : Arithmetic₁ (n := n + 1) (fun v => f v.tail v.head)) : + ArithPart₁ + (fun v => Nat.rfind (fun x => Part.some (f v x ≤ v.get i ∧ v.get i < f v (x + 1)))) := + by + let F : List.Vector ℕ (n + 1) → ℕ := fun v => + (PointwiseComposition.Nat.and (isLeNat (f v.tail v.head) (v.get i.succ))) + (isLtNat (v.get i.succ) (f v.tail (v.head + 1))) + have : Arithmetic₁ F := + (Arithmetic₁.and 0 1).comp₂ _ ((Arithmetic₁.le 0 1).comp₂ _ hf (proj i.succ)) + ((Arithmetic₁.lt 0 1).comp₂ _ (proj i.succ) + (Arithmetic₁.comp' hf + (Arithmetic₁.cons ((Arithmetic₁.add 0 1).comp₂ _ Arithmetic₁.head one) + (fun i => Arithmetic₁.tail (proj i))))) + have := rfindPos this + exact this.of_eq <| by intro v; simp [F] + +end ArithPart₁ +end Nat + +namespace Nat +namespace Arithmetic₁ + +open _root_.Nat +open _root_.Nat +protected lemma sqrt {n} (i : Fin n) : Arithmetic₁ (fun v => sqrt (v.get i)) := + by + have := ArithPart₁.implicit_fun i (fun _ x => x * x) ((mul 0 1).comp₂ _ head head) + exact + this.of_eq <| by + intro v; simp only [Bool.decide_and, PFun.coe_val, eq_some_iff] + refine Nat.mem_rfind.mpr ⟨?_, ?_⟩ <;> simp only [Part.mem_some_iff] + · simpa using ⟨sqrt_le (List.Vector.get v i), lt_succ_sqrt (List.Vector.get v i)⟩ + · intro m hm; symm + simp only [Bool.and_eq_false_eq_eq_false_or_eq_false, decide_eq_false_iff_not, not_le, + not_lt] + right; exact Iff.mp le_sqrt hm + +lemma sub {n} (i j : Fin n) : Arithmetic₁ (fun v => v.get i - v.get j) := + by + let F : List.Vector ℕ (n + 1) → ℕ := fun v => + (PointwiseComposition.Nat.or (isEqNat (v.head + v.get j.succ) (v.get i.succ))) + ((PointwiseComposition.Nat.and (isLtNat (v.get i.succ) (v.get j.succ))) + (isEqNat v.head 0)) + have : Arithmetic₁ F := + (or 0 1).comp₂ _ ((equal 0 1).comp₂ _ ((add 0 1).comp₂ _ head (proj j.succ)) (proj i.succ)) + ((and 0 1).comp₂ _ ((lt 0 1).comp₂ _ (proj i.succ) (proj j.succ)) + ((equal 0 1).comp₂ _ head zero)) + exact + (ArithPart₁.rfindPos this).of_eq <| by + intro v + simp only [head_cons, get_cons_succ, orNat_pos_iff, isEqNat_pos_iff, and_pos_iff, + isLtNat_pos_iff, Bool.decide_or, Bool.decide_and, PFun.coe_val, eq_some_iff, F] + refine Nat.mem_rfind.mpr ⟨?_, ?_⟩ <;> simp only [Part.mem_some_iff] + · suffices + v.get i - v.get j + v.get j = v.get i ∨ v.get i < v.get j ∧ v.get i - v.get j = 0 by + symm; simpa + have : v.get i < v.get j ∨ v.get j ≤ v.get i := Nat.lt_or_ge _ _ + rcases this with (hv | hv) + · right; exact ⟨hv, Nat.sub_eq_zero_of_le (Nat.le_of_lt hv)⟩ + · left; exact Nat.sub_add_cancel hv + · intro m hm; symm + simp only [Bool.or_eq_false_eq_eq_false_and_eq_false, decide_eq_false_iff_not, + Bool.and_eq_false_eq_eq_false_or_eq_false, not_lt] + have : m + v.get j < v.get i := add_lt_of_lt_sub hm + exact ⟨_root_.ne_of_lt this, by left; exact le_trans le_add_self (le_of_lt this)⟩ + +protected lemma pair {n} (i j : Fin n) : Arithmetic₁ (fun v => (v.get i).pair (v.get j)) := + by + have := + if_pos (lt i j) ((add 0 1).comp₂ _ (mul j j) (proj i)) + ((add 0 1).comp₂ _ ((add 0 1).comp₂ _ (mul i i) (proj i)) (proj j)) + exact this.of_eq <| by intro v; simp [pair] + +lemma unpair₁ {n} (i : Fin n) : Arithmetic₁ (fun v => (v.get i).unpair.1) := + by + have hf : + Arithmetic₁ (fun v => isLtNat (v.get i - (v.get i).sqrt * (v.get i).sqrt) (v.get i).sqrt) := + (lt 0 1).comp₂ _ + ((Arithmetic₁.sub 0 1).comp₂ _ (proj i) + ((mul 0 1).comp₂ _ (Arithmetic₁.sqrt i) (Arithmetic₁.sqrt i))) + (Arithmetic₁.sqrt i) + have hg : Arithmetic₁ (fun v => v.get i - (v.get i).sqrt * (v.get i).sqrt) := + (sub 0 1).comp₂ _ (proj i) ((mul 0 1).comp₂ _ (Arithmetic₁.sqrt i) (Arithmetic₁.sqrt i)) + have hh : Arithmetic₁ (fun v => sqrt (v.get i)) := Arithmetic₁.sqrt i + have := if_pos hf hg hh + exact + this.of_eq <| by + intro v + simp only [isLtNat_pos_iff, unpair] + by_cases v.get i - (v.get i).sqrt * (v.get i).sqrt < sqrt (v.get i) <;> simp [*] + +lemma unpair₂ {n} (i : Fin n) : Arithmetic₁ (fun v => (v.get i).unpair.2) := + by + have hf : + Arithmetic₁ (fun v => isLtNat (v.get i - (v.get i).sqrt * (v.get i).sqrt) (v.get i).sqrt) := + (lt 0 1).comp₂ _ + ((Arithmetic₁.sub 0 1).comp₂ _ (proj i) + ((mul 0 1).comp₂ _ (Arithmetic₁.sqrt i) (Arithmetic₁.sqrt i))) + (Arithmetic₁.sqrt i) + have hg : Arithmetic₁ (fun v => sqrt (v.get i)) := Arithmetic₁.sqrt i + have hh : Arithmetic₁ (fun v => v.get i - (v.get i).sqrt * (v.get i).sqrt - (v.get i).sqrt) := + (sub 0 1).comp₂ _ + ((sub 0 1).comp₂ _ (proj i) ((mul 0 1).comp₂ _ (Arithmetic₁.sqrt i) (Arithmetic₁.sqrt i))) + (Arithmetic₁.sqrt i) + have := if_pos hf hg hh + exact + this.of_eq <| by + intro v + simp only [isLtNat_pos_iff, unpair] + by_cases v.get i - (v.get i).sqrt * (v.get i).sqrt < sqrt (v.get i) <;> simp [*] + +lemma dvd (i j : Fin n) : Arithmetic₁ (fun v => isDvdNat (v.get i) (v.get j)) := by + have hr : @Arithmetic₁ (n + 1) (fun v => + (PointwiseComposition.Nat.or (isEqNat (v.head * (v.get i.succ)) (v.get j.succ))) (isLtNat + (v.get j.succ) v.head)) := + (or 0 1).comp₂ _ + ((equal 0 1).comp₂ _ ((mul 0 1).comp₂ _ head (proj i.succ)) (proj j.succ)) + ((lt 0 1).comp₂ _ (proj j.succ) head) + have : @Arithmetic₁ (n + 1) (fun v => isLeNat v.head (v.tail.get j)) := + (le 0 1).comp₂ _ head ((proj j.succ).of_eq <| by simp) + have := ArithPart₁.map (fun v x => isLeNat x (v.get j)) this (ArithPart₁.rfindPos hr) + exact this.of_eq <| by + intro v + let p : ℕ →. Bool := fun k => Part.some (decide (0 < Nat.or (isEqNat (k * v.get i) (v.get + j)) (isLtNat (v.get j) k))) + change Part.map (fun k => isLeNat k (v.get j)) (rfind p) = Part.some (isDvdNat (v.get i) + (v.get j)) + rw [Part.eq_some_iff, Part.mem_map_iff] + simp only [Nat.mem_rfind] + simp only [p, orNat_pos_iff, isEqNat_pos_iff, isLtNat_pos_iff, + Bool.decide_or, isDvdNat, mem_some_iff] + by_cases hv : v.get i ∣ v.get j + · simp only [hv, ↓reduceIte] + rcases least_number _ hv with ⟨k, hk, hkm⟩ + have hkvj : k ≤ v.get j := by + by_cases hkz : k = 0 + · simp [hkz] + · rw [hk]; exact Nat.le_mul_of_pos_left _ (Nat.zero_lt_of_ne_zero <| fun hvi => by + simp [hvi] at hk + have : v.get j ≠ 0 := hkm 0 (Nat.pos_of_ne_zero hkz) + contradiction) + refine ⟨k, + ⟨by grind [mul_comm], + by intro m hm; simp [mul_comm m, Ne.symm (hkm m hm), le_of_lt (lt_of_lt_of_le hm hkvj)]⟩, + by simp [isLeNat, hkvj]⟩ + · simp only [hv, ↓reduceIte] + refine ⟨v.get j + 1, ⟨by simp, ?_⟩, by simp [isLeNat]⟩ + intro m hm + suffices ¬m * v.get i = v.get j by simpa [Nat.lt_succ_iff.mp hm] + intro A + have : v.get i ∣ v.get j := by rw [←A]; exact Nat.dvd_mul_left (List.Vector.get v i) m + contradiction + +lemma rem (i j : Fin n) : Arithmetic₁ (fun v => v.get i % v.get j) := + by + let F : List.Vector ℕ (n + 1) → ℕ := fun v => isDvdNat (v.get j.succ) (v.get i.succ - v.head) + have : Arithmetic₁ F := (dvd 0 1).comp₂ _ (proj j.succ) ((sub 0 1).comp₂ _ (proj i.succ) head) + exact + (ArithPart₁.rfindPos this).of_eq <| by + intro v + suffices ∀ m < v.get i % v.get j, ¬v.get j ∣ v.get i - m + by + simp only [F, PFun.coe_val, Part.eq_some_iff] + refine Nat.mem_rfind.mpr ⟨?_, ?_⟩ + · simp [Nat.dvd_sub_mod] + · intro m hm + simpa [F] using this m hm + intro m hm A + have hmvi : m < v.get i := lt_of_lt_of_le hm <| Nat.mod_le (v.get i) (v.get j) + have hsub : v.get j ∣ v.get i % v.get j - m := + by + have : v.get i - m - (v.get i - v.get i % v.get j) = v.get i % v.get j - m := by + rw [Nat.sub_eq_iff_eq_add (Nat.sub_le_sub_left (le_of_lt hm) _), + Nat.sub_eq_iff_eq_add (le_of_lt hmvi), ← Nat.sub_add_comm (le_of_lt hm), + Nat.add_sub_of_le (Nat.mod_le (v.get i) (v.get j)), + Nat.sub_add_cancel (le_of_lt hmvi)] + rw [← this] + exact Nat.dvd_sub A (@Nat.dvd_sub_mod (v.get j) (v.get i)) + have hpos : 0 < v.get i % v.get j - m := Nat.lt_sub_of_add_lt (by simpa using hm) + have : v.get i % v.get j - m < v.get j := + by + have : v.get i % v.get j < v.get j := + Nat.mod_lt _ + (Nat.pos_of_ne_zero <| fun h => + (Nat.not_lt.mpr (by simpa [Nat.sub_eq_zero_iff_le, h] using hsub)) hmvi) + exact lt_of_le_of_lt (sub_le _ _) this + have : ¬v.get j ∣ v.get i % v.get j - m := Nat.not_dvd_of_pos_of_lt hpos this + contradiction + +lemma beta (i j : Fin n) : Arithmetic₁ (fun v => Nat.beta (v.get i) (v.get j)) := + (rem 0 1).comp₂ _ ((unpair₁ 0).comp₁ (·.unpair.1) (proj i)) + ((succ 0).comp₁ _ <| (mul 0 1).comp₂ _ (succ j) ((unpair₂ 0).comp₁ (·.unpair.2) (proj i))) + +lemma ball {φ : List.Vector ℕ n → ℕ → ℕ} (hp : @Arithmetic₁ (n + 1) (fun v => φ v.tail v.head)) + (i) : Arithmetic₁ (fun v => ball (v.get i) (φ v)) := + by + let F : List.Vector ℕ (n + 1) → ℕ := fun v => + (PointwiseComposition.Nat.or (PointwiseComposition.Nat.inv (φ v.tail v.head))) + (isLeNat (v.get i.succ) v.head) + have hF : Arithmetic₁ F := + (or 0 1).comp₂ _ ((inv 0).comp₁ _ hp) ((le 0 1).comp₂ _ (proj i.succ) head) + have : @Arithmetic₁ (n + 1) (fun v => isEqNat v.head (v.get i.succ)) := + (equal 0 1).comp₂ _ head (proj i.succ) + have := + ArithPart₁.map (fun v x => isEqNat x (v.get i)) (this.of_eq <| by simp) + (ArithPart₁.rfindPos hF) + exact + this.of_eq <| by + intro v + let p : ℕ →. Bool := fun k => Part.some (decide (0 < F (k ::ᵥ v))) + change + Part.map (fun k => isEqNat k (v.get i)) (rfind p) = + Part.some (PointwiseComposition.Nat.ball (v.get i) (φ v)) + rw [Part.eq_some_iff, Part.mem_map_iff] + simp only [Nat.mem_rfind] + simp only [p, tail_cons, head_cons, get_cons_succ, orNat_pos_iff, inv_pos_iff, not_lt, + nonpos_iff_eq_zero, isLeNat_pos_iff, Bool.decide_or, mem_some_iff, F] + by_cases H : ∀ m < v.get i, 0 < φ v m + · exact + ⟨v.get i, + ⟨by symm; simp, by intro m hm; symm; simpa [hm] using Nat.ne_zero_of_lt (H m hm)⟩, + by symm; simpa [isEqNat] using ball_pos_iff_eq_one.mpr (by simpa)⟩ + · have : ∃ x < List.Vector.get v i, φ v x = 0 ∧ ∀ y < x, φ v y ≠ 0 := + by + have H : ∃ x < v.get i, φ v x = 0 := by simpa using H + rcases least_number _ H with ⟨x, hx, hxl⟩ + exact + ⟨x, hx.1, hx.2, by + intro y hy; have : y < v.get i → φ v y ≠ 0 := by simpa using hxl y hy + exact this (lt_trans hy hx.1)⟩ + rcases this with ⟨x, hx, hpx, hlx⟩ + exact + ⟨x, ⟨by symm; simp [hpx], by intro m hm; symm; simp [hlx m hm, lt_trans hm hx]⟩, + by + have : isEqNat x (v.get i) = 0 := by + simpa [isEqNat, imp_false] using _root_.ne_of_lt hx + symm; simpa [this] using ⟨x, hx, hpx⟩⟩ + +/-- The rec Sequence construction in `Nat.Arithmetic₁`. -/ +def recSequence (f : List.Vector ℕ n → ℕ) (g : List.Vector ℕ (n + 2) → ℕ) (z : ℕ) + (v : List.Vector ℕ n) : List ℕ := + List.ofFn fun i : Fin (z + 1) => Nat.recOn i (f v) (fun y IH => g (y ::ᵥ IH ::ᵥ v)) + +lemma beta_unbeta_recSequence_eq (f : List.Vector ℕ n → ℕ) (g : List.Vector ℕ (n + 2) → ℕ) + (z : ℕ) (v : List.Vector ℕ n) (m : ℕ) (hm : m < z + 1) : + Nat.beta (unbeta (recSequence f g z v)) m = m.rec (f v) (fun y IH => g (y ::ᵥ IH ::ᵥ v)) := + by + have : (unbeta (recSequence f g z v)).beta m = (recSequence f g z v).get ⟨m, _⟩ := + Nat.beta_unbeta_coe (recSequence f g z v) ⟨m, by simp [recSequence, hm]⟩ + rw [this]; simp [List.get_ofFn, recSequence, -List.get_eq_getElem] + +lemma beta_unbeta_recSequence_zero (f : List.Vector ℕ n → ℕ) (g : List.Vector ℕ (n + 2) → ℕ) + (z : ℕ) (v : List.Vector ℕ n) : Nat.beta (unbeta (recSequence f g z v)) 0 = f v := by + simpa using beta_unbeta_recSequence_eq f g z v 0 (inv_iff_ne_zero.mp rfl) + +lemma beta_unbeta_recSequence_succ (f : List.Vector ℕ n → ℕ) (g : List.Vector ℕ (n + 2) → ℕ) + (z : ℕ) (v : List.Vector ℕ n) {m : ℕ} (hm : m < z) : + Nat.beta (unbeta (recSequence f g z v)) (m + 1) = + g (m ::ᵥ Nat.beta (unbeta (recSequence f g z v)) m ::ᵥ v) := + by + rw [beta_unbeta_recSequence_eq f g z v m (Nat.lt_add_right 1 hm), + beta_unbeta_recSequence_eq f g z v (m + 1) (Nat.add_lt_add_right hm 1)] + +lemma beta_eq_rec (f : List.Vector ℕ n → ℕ) (g : List.Vector ℕ (n + 2) → ℕ) {z : ℕ} {v} + (h0 : z.beta 0 = f v) (hs : ∀ i < m, z.beta (i + 1) = g (i ::ᵥ z.beta i ::ᵥ v)) : + z.beta m = m.rec (f v) (fun y IH => g (y ::ᵥ IH ::ᵥ v)) := + by + induction m + · simp [h0] + · grind + +lemma prec {n f g} (hf : @Arithmetic₁ n f) (hg : @Arithmetic₁ (n + 2) g) : + @Arithmetic₁ (n + 1) (fun v => v.head.rec (f v.tail) fun y IH => g (y ::ᵥ IH ::ᵥ v.tail)) := by + let F : List.Vector ℕ (n + 2) → ℕ := fun v => + (PointwiseComposition.Nat.and (isEqNat (Nat.beta v.head 0) (f v.tail.tail))) + (Nat.ball v.tail.head <| fun i => + isEqNat (Nat.beta v.head (i + 1)) (g (i ::ᵥ Nat.beta v.head i ::ᵥ v.tail.tail))) + have hp : @Arithmetic₁ (n + 3) (fun v => + isEqNat (Nat.beta v.tail.head (v.head + 1)) + (g (v.head ::ᵥ Nat.beta v.tail.head v.head ::ᵥ v.tail.tail.tail))) := + (equal 0 1).comp₂ _ + ((beta 0 1).comp₂ _ head.tail ((succ 0).comp₁ _ head)) + (hg.comp' <| head.cons <| ((beta 0 1).comp₂ _ head.tail head).cons <| by + intro i + simpa using proj _) + have hF : Arithmetic₁ F := (and 0 1).comp₂ _ + ((equal 0 1).comp₂ _ ((beta 0 1).comp₂ _ head zero) hf.tail.tail) + ((@ball (n + 2) (fun v i => + isEqNat (Nat.beta v.head (i + 1)) + (g (i ::ᵥ Nat.beta v.head i ::ᵥ v.tail.tail))) hp 1).of_eq <| by + simp [List.Vector.get_one]) + have : @Arithmetic₁ (n + 2) (fun v => Nat.beta v.head v.tail.head) := + (beta 0 1).of_eq (by simp [List.Vector.get_one]) + exact (ArithPart₁.map (fun v x => Nat.beta x v.head) this (ArithPart₁.rfindPos hF)).of_eq <| by + intro v + let p : ℕ →. Bool := fun k => Part.some (decide (0 < F (k ::ᵥ v))) + change Part.map (fun k => Nat.beta k v.head) (rfind p) = + Part.some (v.head.rec (f v.tail) fun y ih => g (y ::ᵥ ih ::ᵥ v.tail)) + rw [Part.eq_some_iff, Part.mem_map_iff] + simp only [Nat.mem_rfind] + simp only [p, add_succ_sub_one, head_cons, tail_cons, and_pos_iff, isEqNat_pos_iff, + ball_pos_iff, Bool.decide_and, + mem_some_iff, F] + suffices ∃ z : ℕ, z.beta 0 = f v.tail ∧ + ∀ i < v.head, z.beta (i + 1) = g (i ::ᵥ z.beta i ::ᵥ v.tail) by + rcases least_number _ this with ⟨z, ⟨hz0, hzs⟩, hzm⟩ + exact ⟨z, ⟨by symm; simpa [hz0] using hzs, + by intro m hm; symm; simpa [imp_iff_not_or, not_or] using hzm m hm⟩, + beta_eq_rec f g hz0 hzs⟩ + let l : List ℕ := recSequence f g v.head v.tail + exact ⟨unbeta l, + beta_unbeta_recSequence_zero f g v.head v.tail, + fun i hi => beta_unbeta_recSequence_succ f g v.head v.tail hi⟩ + +lemma of_primrec {f : List.Vector ℕ n → ℕ} (hf : Primrec' f) : Arithmetic₁ f := + by + induction hf + case zero => exact zero + case succ => exact (@succ 1 0).of_eq (by simp) + case get i => exact proj i + case comp f g _ _ hf hg => exact hf.comp _ hg + case prec f g _ _ hf hg => exact hf.prec hg + +lemma _root_.PointwiseComposition.Nat.ArithPart₁.of_partrec {f : List.Vector ℕ n →. ℕ} + (hf : Partrec' f) : ArithPart₁ f := by + induction hf + case prim f hf => exact of_primrec hf + case comp f g _ _ hf hg => exact hf.comp _ hg + case rfind f _ hf => exact ArithPart₁.rfind hf + +end Arithmetic₁ +end Nat + +namespace Nat +namespace ArithPart₁ + +open _root_.Nat +open _root_.Nat +/-- Data and laws for Code in `Nat.ArithPart₁`. -/ +inductive Code : ℕ → Type + | zero (n) : Code n + | one (n) : Code n + | add {n} (i j : Fin n) : Code n + | mul {n} (i j : Fin n) : Code n + | proj {n} (i : Fin n) : Code n + | equal {n} (i j : Fin n) : Code n + | lt {n} (i j : Fin n) : Code n + | comp {m n} : Code n → (Fin n → Code m) → Code m + | rfind {n} : Code (n + 1) → Code n + +instance (k) : Inhabited (Code k) := + ⟨Code.zero k⟩ + +/-- Data and laws for eval in `Nat.ArithPart₁.Code`. -/ +inductive Code.eval : {n : ℕ} → Code n → (List.Vector ℕ n →. ℕ) → Prop + | zero {n} : Code.eval (Code.zero n) (fun _ => 0) + | one {n} : Code.eval (Code.one n) (fun _ => 1) + | add {n} (i j : Fin n) : Code.eval (Code.add i j) (fun v => ↑(v.get i + v.get j)) + | mul {n} (i j : Fin n) : Code.eval (Code.mul i j) (fun v => ↑(v.get i * v.get j)) + | proj {n} (i : Fin n) : Code.eval (Code.proj i) (fun v => v.get i) + | equal {n} (i j : Fin n) : Code.eval (Code.equal i j) (fun v => isEqNat (v.get i) (v.get j)) + | lt {n} (i j : Fin n) : Code.eval (Code.lt i j) (fun v => isLtNat (v.get i) (v.get j)) + | + comp {m n} (c : Code n) (d : Fin n → Code m) (f : List.Vector ℕ n →. ℕ) + (g : Fin n → (List.Vector ℕ m →. ℕ)) : + Code.eval c f → + (∀ i, Code.eval (d i) (g i)) → + Code.eval (c.comp d) (fun v => (List.Vector.mOfFn fun i => g i v) >>= f) + | + rfind {n} (c : Code (n + 1)) (f : List.Vector ℕ (n + 1) → ℕ) : + Code.eval c f → Code.eval c.rfind (fun v => Nat.rfind fun n => Part.some (f (n ::ᵥ v) = 0)) + +lemma exists_code : ∀ {n : ℕ} {f : List.Vector ℕ n →. ℕ}, ArithPart₁ f → ∃ c : Code n, c.eval f + | n, _, ArithPart₁.zero => ⟨Code.zero n, Code.eval.zero⟩ + | n, _, ArithPart₁.one => ⟨Code.one n, Code.eval.one⟩ + | _, _, ArithPart₁.add i j => ⟨Code.add i j, Code.eval.add i j⟩ + | _, _, ArithPart₁.mul i j => ⟨Code.mul i j, Code.eval.mul i j⟩ + | _, _, ArithPart₁.proj i => ⟨Code.proj i, Code.eval.proj i⟩ + | _, _, ArithPart₁.equal i j => ⟨Code.equal i j, Code.eval.equal i j⟩ + | _, _, ArithPart₁.lt i j => ⟨Code.lt i j, Code.eval.lt i j⟩ + | _, _, @ArithPart₁.comp _ _ f g hf hg => + by + rcases exists_code hf with ⟨cf, hcf⟩ + choose cg hcg using fun i => exists_code (hg i) + exact ⟨cf.comp cg, Code.eval.comp cf cg f g hcf hcg⟩ + | _, _, @ArithPart₁.rfind _ f hf => + by + rcases exists_code hf with ⟨cf, hcf⟩ + exact ⟨cf.rfind, Code.eval.rfind cf f hcf⟩ + +end ArithPart₁ +end Nat + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/Vorspiel/Computability.lean b/LeanPool/PointwiseComposition/Foundation/Vorspiel/Computability.lean new file mode 100644 index 000000000..c581fd9d7 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/Vorspiel/Computability.lean @@ -0,0 +1,325 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import Mathlib.Computability.Halting +public import Mathlib.Computability.Primrec.List +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Nat.Matrix +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Part + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace Nat +namespace Partrec + +open _root_.Nat + +open _root_.Nat.Partrec + +open _root_.Part Part _root_.Primrec + +lemma projection {f : ℕ →. ℕ} (hf : Nat.Partrec f) + (unif : ∀ {m n₁ n₂ a₁ a₂ : ℕ}, a₁ ∈ f (m.pair n₁) → a₂ ∈ f (m.pair n₂) → a₁ = a₂) : + ∃ g : ℕ →. ℕ, Nat.Partrec g ∧ (∀ a m, a ∈ g m ↔ ∃ z, a ∈ f (m.pair z)) := + by + obtain ⟨cf, rfl⟩ := Code.exists_code.1 hf + let F : ℕ → ℕ → Option ℕ := fun m n ↦ + Nat.rec .none (fun x ih ↦ ih.casesOn (cf.evaln n (m.pair x)) .some) n + have : Primrec₂ F := + .to₂ <| + Primrec.nat_rec' Primrec.snd (.const Option.none) + (Primrec.option_casesOn (Primrec.snd.comp .snd) + (Code.primrec_evaln.comp <| + _root_.Primrec.pair (_root_.Primrec.pair (snd.comp .fst) (.const cf)) + (Primrec₂.natPair.comp (fst.comp fst) (fst.comp snd))) + (Primrec.option_some.comp snd).to₂).to₂ + have hF : ∀ {m n a}, a ∈ F m n ↔ ∃ x < n, a ∈ cf.evaln n (m.pair x) := + by + suffices + ∀ m n s a : ℕ, + Nat.rec Option.none (fun x ih ↦ ih.casesOn (cf.evaln s (m.pair x)) Option.some) n = + Option.some a ↔ + ∃ x < n, cf.evaln s (m.pair x) = .some a + from fun m n a ↦ this m n n a + intro m n s a + induction n generalizing a + case zero => simp + case succ n + ih => + cases hC : + @Nat.rec (fun _ ↦ Option ℕ) Option.none + (fun x ih ↦ ih.rec (cf.evaln s (m.pair x)) Option.some) n + · suffices + Code.evaln s cf (Nat.pair m n) = Option.some a ↔ + ∃ x < n + 1, Code.evaln s cf (Nat.pair m x) = Option.some a + by simpa [hC] + constructor + · intro h; exact ⟨n, by simp, h⟩ + · rintro ⟨x, hx, Hx⟩ + rcases eq_or_lt_of_le (le_of_lt_succ hx) with (rfl | hx) + · exact Hx + · exfalso; simpa using ((ih _).mpr ⟨x, hx, Hx⟩).symm.trans hC + case some + i => + suffices i = a ↔ ∃ x < n + 1, Code.evaln s cf (Nat.pair m x) = Option.some a by + simpa [hC] + constructor + · rintro rfl; rcases (ih _).mp hC with ⟨x, hx, Hx⟩ + exact ⟨x, lt_trans hx (by simp), Hx⟩ + · rintro ⟨x, _, Hx⟩ + rcases (ih _).mp hC with ⟨y, _, Hy⟩ + exact unif (Nat.Partrec.Code.evaln_sound Hy) (Nat.Partrec.Code.evaln_sound Hx) + have mono : ∀ {a m n₁ n₂ : ℕ}, n₁ ≤ n₂ → a ∈ F m n₁ → a ∈ F m n₂ := + by + intro a m n₁ n₂ hn h₁ + rcases hF.mp h₁ with ⟨x, hx, H⟩ + apply hF.mpr ⟨x, lt_of_lt_of_le hx hn, Code.evaln_mono hn H⟩ + have : Partrec (fun m ↦ rfindOpt (F m)) := Partrec.rfindOpt <| this.to_comp + exact + ⟨_, this, by + intro a m + suffices (∃ n, F m n = .some a) ↔ ∃ z, a ∈ cf.eval (m.pair z) by + simpa [Nat.rfindOpt_mono mono] + constructor + · rintro ⟨n, H⟩ + obtain ⟨x, _, H⟩ := hF.mp H + exact ⟨x, Code.evaln_sound H⟩ + · rintro ⟨x, H⟩ + obtain ⟨s, Hs⟩ := Code.evaln_complete.mp H + exact + ⟨max s x + 1, + (@hF m (max s x + 1) a).mpr + ⟨x, by simp [Nat.lt_succ_iff], + Code.evaln_mono (le_trans (Nat.le_max_left s x) (le_add_right (max s x) 1)) + Hs⟩⟩⟩ + +end Partrec +end Nat + +namespace Partrec + +open _root_.Partrec + +variable {α β γ : Type*} [Primcodable α] [Primcodable β] [Primcodable γ] + +lemma projection {f : α → β →. γ} (hf : Partrec₂ f) + (unif : ∀ {a b₁ b₂ c₁ c₂}, c₁ ∈ f a b₁ → c₂ ∈ f a b₂ → c₁ = c₂) : + ∃ g : α →. γ, Partrec g ∧ (∀ c a, c ∈ g a ↔ ∃ b, c ∈ f a b) := + by + have := + Nat.Partrec.projection (Partrec.bind_decode₂_iff.mp hf) + (by + intro m n₁ n₂ c₁ c₂; + simp only [Part.mem_bind_iff, Part.mem_ofOption, Option.mem_def, + Encodable.decode₂_eq_some, Part.mem_map_iff, Prod.exists, Encodable.encode_prod_val, + Nat.pair_eq_pair, forall_exists_index, and_imp] + rintro a b₁ rfl rfl c₁ h₁ rfl a b₂ e rfl c₂ h₂ rfl + rcases Encodable.encode_inj.mp e + rw [unif h₁ h₂]) + rcases this with ⟨g, hg, H⟩ + let g' : α →. γ := fun a ↦ (g (Encodable.encode a)).bind fun n ↦ Encodable.decode (α := γ) n + refine + ⟨g', + ((nat_iff.2 hg).comp Computable.encode).bind + (Computable.decode.ofOption.comp Computable.snd).to₂, + ?_⟩ + have H : + ∀ {c a : ℕ}, + c ∈ g a ↔ ∃ a' b, Encodable.encode a' = a ∧ ∃ c' ∈ f a' b, Encodable.encode c' = c := + by + have H : + ∀ (a m : ℕ), + a ∈ g m ↔ + ∃ z a' b, + (Encodable.encode a' = m ∧ Encodable.encode b = z) ∧ + ∃ a'' ∈ f a' b, Encodable.encode a'' = a := + by simpa [Encodable.decode₂_eq_some] using H + intro c a; constructor + · intro h; rcases (H c a).mp h with ⟨b, a, b, ⟨rfl, rfl⟩, ⟨c, H, rfl⟩⟩ + exact ⟨a, b, rfl, c, H, rfl⟩ + · rintro ⟨a, b, rfl, c, hc, rfl⟩ + exact (H _ _).mpr ⟨Encodable.encode b, a, b, ⟨rfl, rfl⟩, c, hc, rfl⟩ + intro c a + suffices (∃ c' ∈ g (Encodable.encode a), Encodable.decode c' = some c) ↔ ∃ b, c ∈ f a b by + simpa [g'] + constructor + · rintro ⟨c', h, hc⟩ + rcases H.mp h with ⟨a, b, ae, c, habc, rfl⟩; rcases by simpa using hc + rcases Encodable.encode_inj.mp ae + exact ⟨b, habc⟩ + · rintro ⟨b, habc⟩ + exact ⟨Encodable.encode c, H.mpr ⟨a, b, rfl, c, habc, rfl⟩, by simp⟩ + +end Partrec + +namespace REPred + +open _root_.REPred + +variable {α β : Type*} [Primcodable α] [Primcodable β] {p q : α → Prop} + +@[simp] +protected lemma const (p : Prop) : REPred fun _ : α ↦ p := + by + by_cases h : p + · simpa [h] using Partrec.some.dom_re + · simpa [h] using (Partrec.none (α := α) (σ := α)).dom_re + +lemma iff : REPred p ↔ ∃ f : α →. Unit, Partrec f ∧ p = fun x ↦ (f x).Dom := + ⟨fun h ↦ ⟨_, h, by ext x; simp [Part.assert]⟩, by rintro ⟨f, hf, rfl⟩; exact hf.dom_re⟩ + +lemma iff' : REPred p ↔ ∃ f : α →. Unit, Partrec f ∧ ∀ x, p x ↔ (f x).Dom := + by + constructor + · intro h + exact ⟨_, h, by intro x; simp [Part.assert]⟩ + · rintro ⟨f, hf, h⟩ + exact hf.dom_re.of_eq (by simp [h]) + +lemma and (hp : REPred p) (hq : REPred q) : REPred fun x ↦ p x ∧ q x := + by + rcases REPred.iff.mp hp with ⟨f, hf, rfl⟩ + rcases REPred.iff.mp hq with ⟨g, hg, rfl⟩ + let h : α →. Unit := fun x ↦ (f x).bind fun _ ↦ (g x).map fun _ ↦ () + have : Partrec h := + Partrec.bind hf <| + Partrec.to₂ <| Partrec.map (hg.comp Computable.fst) (Computable.const ()).to₂ + exact REPred.iff.mpr ⟨_, this, by funext x; simp [h]⟩ + +lemma or (hp : REPred p) (hq : REPred q) : REPred fun x ↦ p x ∨ q x := + by + rcases REPred.iff.mp hp with ⟨f, hf, rfl⟩ + rcases REPred.iff.mp hq with ⟨g, hg, rfl⟩ + rcases hf.merge hg (by intro a x; simp) with ⟨k, hk, h⟩ + exact REPred.iff.mpr ⟨k, hk, by funext x; simp [Part.unit_dom_iff, h]⟩ + +lemma projection {p : α × β → Prop} (hp : REPred p) : REPred fun x ↦ ∃ y, p (x, y) := + by + rcases REPred.iff.mp hp with ⟨f, hf, rfl⟩ + have : Partrec₂ fun a b ↦ f (a, b) := hf.comp <| Computable.pair .fst .snd + obtain ⟨g, hg, Hg⟩ := Partrec.projection this (by simp) + exact REPred.iff.mpr ⟨g, hg, by funext x; simp [Part.unit_dom_iff, Hg]⟩ + +protected lemma comp {f : α → β} (hf : Computable f) {p : β → Prop} (hp : REPred p) : + REPred fun x ↦ p (f x) := + by + rcases REPred.iff.mp hp with ⟨p, pp, rfl⟩ + exact REPred.iff'.mpr ⟨_, pp.comp hf, by intro x; simp⟩ + +end REPred + +namespace ComputablePred + +open _root_.ComputablePred + +variable {α β : Type*} [Primcodable α] [Primcodable β] {p q : α → Prop} + +@[simp] +protected lemma const (p : Prop) : ComputablePred fun _ : α ↦ p := + computable_iff_re_compl_re'.mpr ⟨REPred.const _, REPred.const _⟩ + +lemma and : ComputablePred p → ComputablePred q → ComputablePred fun x ↦ p x ∧ q x := + by + simp_rw [computable_iff_re_compl_re'] + rintro ⟨hp, hnp⟩ + rintro ⟨hq, hnq⟩ + refine + ⟨(PointwiseComposition.REPred.and hp) hq, + ((PointwiseComposition.REPred.or hnp) hnq).of_eq <| by grind⟩ + +lemma or : ComputablePred p → ComputablePred q → ComputablePred fun x ↦ p x ∨ q x := + by + simp_rw [computable_iff_re_compl_re'] + rintro ⟨hp, hnp⟩ + rintro ⟨hq, hnq⟩ + refine + ⟨(PointwiseComposition.REPred.or hp) hq, + ((PointwiseComposition.REPred.and hnp) hnq).of_eq <| by grind⟩ + +lemma of_graph_rePred {g : α → ℕ} (h : REPred fun p : α × ℕ ↦ p.2 = g p.1) : Computable g := + by + have hF : + Partrec₂ fun (a : α) (b : ℕ) ↦ (Part.assert (b = g a) fun _ ↦ Part.some ()).map fun _ ↦ b := + (Partrec.map h ((Computable.snd.comp Computable.fst).to₂)).to₂ + obtain ⟨k, hk, Hk⟩ := + Partrec.projection hF + (by + rintro a b₁ b₂ c₁ c₂ h₁ h₂ + simp only [Part.mem_map_iff, Part.mem_assert_iff] at h₁ h₂ + obtain ⟨-, ⟨rfl, -⟩, rfl⟩ := h₁ + obtain ⟨-, ⟨rfl, -⟩, rfl⟩ := h₂ + rfl) + refine hk.of_eq_tot fun a ↦ ?_ + exact (Hk (g a) a).mpr ⟨g a, by simp [Part.mem_map_iff, Part.mem_assert_iff]⟩ + +end ComputablePred + +namespace Nat + +open _root_.Nat + +variable {f : ℕ → ℕ} + +/-- The bounded Max construction in `Nat`. -/ +def boundedMax (f : ℕ → ℕ) (n : ℕ) : ℕ := + Nat.rec (f 0) (fun k ih ↦ max ih (f (k + 1))) n + +lemma computable_boundedMax (hf : Computable f) : Computable (boundedMax f) := + by + have h : Computable fun q : ℕ × (ℕ × ℕ) ↦ max q.2.2 (f (q.2.1 + 1)) := + Computable₂.comp Primrec.nat_max.to_comp (Computable.snd.comp Computable.snd) + (hf.comp (Computable.succ.comp (Computable.fst.comp Computable.snd))) + exact Computable.nat_rec Computable.id (Computable.const (f 0)) h.to₂ + +lemma le_boundedMax {k n : ℕ} (h : k ≤ n) : f k ≤ boundedMax f n := by + induction n with + | zero => simp_all [boundedMax] + | succ n ih => + rcases Nat.eq_or_lt_of_le h with rfl | h + · simp [boundedMax] + · exact (ih (Nat.le_of_lt_succ h)).trans (Nat.le_max_left _ _) + +end Nat + +section + +open _root_.Primrec Primrec + +theorem Primrec.nat_natToList : Primrec Nat.natToList := + by + have step : + Primrec₂ fun (_ : Unit) (l : List (List ℕ)) ↦ + (Nat.casesOn l.length (some []) fun e ↦ (l[e.unpair.2]?).map fun t ↦ e.unpair.1 :: t : + Option (List ℕ)) := + Primrec.to₂ <| + Primrec.nat_casesOn (list_length.comp <| snd.comp .id) (const (some ([] : List ℕ))) + (Primrec.to₂ <| + option_map (list_getElem?.comp (snd.comp fst) (snd.comp <| Primrec.unpair.comp snd)) + (Primrec.to₂ <| + list_cons.comp (fst.comp <| Primrec.unpair.comp <| snd.comp fst) snd)) + have main : Primrec₂ fun (_ : Unit) (n : ℕ) ↦ Nat.natToList n := + by + refine Primrec.nat_strong_rec _ step ?_ + rintro ⟨⟩ (_ | e) + · simp [Nat.natToList] + · have hlen : ((List.range (e + 1)).map Nat.natToList).length = e + 1 := by simp + have hlt : e.unpair.2 < e + 1 := Nat.lt_succ_of_le (Nat.unpair_right_le e) + simp [hlen, List.getElem?_map, hlt, Nat.natToList] + simpa using main.comp (const ()) Primrec.id + +end + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/Vorspiel/Empty.lean b/LeanPool/PointwiseComposition/Foundation/Vorspiel/Empty.lean new file mode 100644 index 000000000..b093bbd83 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/Vorspiel/Empty.lean @@ -0,0 +1,31 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import Mathlib.Data.Fintype.Basic + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace Empty + +open _root_.Empty + +lemma eq_elim {α : Sort u} (f : Empty → α) : f = elim := + funext (by rintro ⟨⟩) + +end Empty + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/Vorspiel/ExistsUnique.lean b/LeanPool/PointwiseComposition/Foundation/Vorspiel/ExistsUnique.lean new file mode 100644 index 000000000..4177917ad --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/Vorspiel/ExistsUnique.lean @@ -0,0 +1,78 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import Mathlib.Basic.IsEmpty.Basic + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace Classical + + + +variable {α : Sort*} {p : α → Prop} {r : α → α → Prop} + +/-- Choose the unique witness supplied by `h`. -/ +noncomputable def chooseUnique (h : ∃! x, p x) : α := + _root_.Classical.choose h.exists + +lemma chooseUnique_spec (h : ∃! x, p x) : p (chooseUnique h) := + _root_.Classical.choose_spec h.exists + +lemma choose_uniq (h : ∃! x, p x) (hx : p x) : x = chooseUnique h := + h.unique hx (chooseUnique_spec h) + +@[simp] +lemma chooseUnique_eq_iff_right (h : ∃! x, p x) : x = chooseUnique h ↔ p x := + ⟨by rintro rfl; exact chooseUnique_spec h, choose_uniq _⟩ + +@[simp] +lemma chooseUnique_eq_iff_left (h : ∃! x, p x) : chooseUnique h = x ↔ p x := + by + rw [eq_comm] + exact chooseUnique_eq_iff_right h + +lemma exitsUnique_extend (h : ∀ x, p x → ∃! y, r x y) (default : α) (x : α) : + ∃! y, (p x → r x y) ∧ (¬p x → y = default) := + by + by_cases hx : p x + · simpa [hx] using h _ hx + · simp [hx] + +/-- Choose the unique `r`-successor when `p x` holds, or return `default` otherwise. -/ +noncomputable def extendedChooseUnique (h : ∀ x, p x → ∃! y, r x y) (default : α) (x : α) : α := + _root_.Classical.choose (exitsUnique_extend h default x).exists + +lemma extendedChooseUnique_spec (h : ∀ x, p x → ∃! y, r x y) (default : α) (hx : p x) : + r x (extendedChooseUnique h default x) := + _root_.Classical.choose_spec (exitsUnique_extend h default x).exists |>.1 hx + +lemma extendedChooseUnique_spec_not (h : ∀ x, p x → ∃! y, r x y) (default : α) (hx : ¬p x) : + extendedChooseUnique h default x = default := + _root_.Classical.choose_spec (exitsUnique_extend h default x).exists |>.2 hx + +lemma extendedChooseUnique_uniq (h : ∀ x, p x → ∃! y, r x y) (default : α) (hpx : p x) + (hrx : r x y) : y = extendedChooseUnique h default x := + (h x hpx).unique hrx (extendedChooseUnique_spec h default hpx) + +lemma extendedChooseUnique_eq_iff (h : ∀ x, p x → ∃! y, r x y) (default : α) (hpx : p x) : + y = extendedChooseUnique h default x ↔ r x y := + ⟨by rintro rfl; exact extendedChooseUnique_spec h default hpx, + extendedChooseUnique_uniq h default hpx⟩ + +end Classical + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/Vorspiel/Fin/Basic.lean b/LeanPool/PointwiseComposition/Foundation/Vorspiel/Fin/Basic.lean new file mode 100644 index 000000000..24f3a704b --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/Vorspiel/Fin/Basic.lean @@ -0,0 +1,141 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import Mathlib.Algebra.GroupWithZero.Nat +public import Mathlib.Data.Fintype.Pigeonhole +public import Mathlib.Tactic.Cases +public import Mathlib.Tactic.TautoSet + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +lemma eq_finZeroElim {α : Sort u} (x : Fin 0 → α) : x = finZeroElim := + funext (by rintro ⟨_, _⟩; contradiction) + +@[grind .] +lemma Nat.sub_one_lt' [NeZero n] : n - 1 < n := + _root_.Nat.sub_one_lt <| NeZero.ne n + +namespace Fin + +open _root_.Fin + +variable {n : ℕ} {i : Fin n} + +lemma isEmpty_embedding_lt (hn : n > m) : IsEmpty (Fin n ↪ Fin m) := by + apply Function.Embedding.isEmpty_of_card_lt; simpa; + +@[grind .] +lemma lt_last : n < Fin.last (n + 1) := by + induction n with + | zero => simp; + | succ n ih => simp; + +@[grind <=] +lemma lt_sub_one_of_pos {a : Fin n} (hn : 0 < n) : a ≤ ⟨n - 1, by omega⟩ := by + apply Nat.le_sub_one_of_lt; omega; + +section last' + +variable [NeZero n] + +/-- The last element of `Fin n` when `n` is `NeZero`. -/ +def last' : Fin n := + ⟨n - 1, Nat.sub_one_lt'⟩ + +@[simp, grind .] +lemma lt_last' : i ≤ Fin.last' := by apply Nat.le_sub_one_of_lt; apply Fin.is_lt; + +end last' + +section + +lemma pos_of_coe_ne_zero {i : Fin (n + 1)} (h : (i : ℕ) ≠ 0) : 0 < i := + Nat.pos_of_ne_zero h + +lemma one_pos'' : (0 : Fin (n + 2)) < 1 := + pos_of_coe_ne_zero (Nat.succ_ne_zero 0) + +@[simp] +lemma two_pos : (0 : Fin (n + 3)) < 2 := + pos_of_coe_ne_zero (Nat.succ_ne_zero 1) + +@[simp] +lemma three_pos : (0 : Fin (n + 4)) < 3 := + pos_of_coe_ne_zero (Nat.succ_ne_zero 2) + +@[simp] +lemma four_pos : (0 : Fin (n + 5)) < 4 := + pos_of_coe_ne_zero (Nat.succ_ne_zero 3) + +@[simp] +lemma five_pos : (0 : Fin (n + 6)) < 5 := + pos_of_coe_ne_zero (Nat.succ_ne_zero 4) + +end + +lemma forall_fin_iff_zero_and_forall_succ {P : Fin (k + 1) → Prop} : + (∀ i, P i) ↔ P 0 ∧ ∀ i : Fin k, P i.succ := + ⟨fun h ↦ ⟨h 0, fun i ↦ h i.succ⟩, by + rintro ⟨hz, hs⟩ i + refine Fin.cases ?_ (fun i => ?_) i + · exact hz + · exact hs i⟩ + +lemma exists_fin_iff_zero_or_exists_succ {P : Fin (k + 1) → Prop} : + (∃ i, P i) ↔ P 0 ∨ ∃ i : Fin k, P i.succ := + ⟨by + rintro ⟨i, hi⟩ + cases i using Fin.cases + · left; exact hi + · right; exact ⟨_, hi⟩, by + rintro (hz | ⟨i, h⟩) + · exact ⟨0, hz⟩ + · exact ⟨_, h⟩⟩ + +lemma funext_two {α : Type*} {f g : Fin (k + 2) → α} (h0 : f 0 = g 0) + (h1 : f (Fin.succ 0) = g (Fin.succ 0)) (hs : ∀ i : Fin k, f i.succ.succ = g i.succ.succ) : + f = g := by + funext i + refine Fin.cases ?_ (fun i => ?_) i + · exact h0 + · refine Fin.cases ?_ (fun i => ?_) i + · exact h1 + · exact hs i + +/-- The add Cast construction in `Fin`. -/ +@[inline] +def addCast (m) : Fin n → Fin (m + n) := + castLE <| Nat.le_add_left n m + +@[simp] +lemma addCast_val (i : Fin n) : (addCast m i : ℕ) = i := + rfl + +namespace Fin1 + +variable {n : Fin 1} + +lemma eq_one : n = 0 := by cases n; omega; + +@[simp] +lemma not_lt_zero : ¬0 < n := by simp [eq_one]; + +end Fin1 + +end Fin + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/Vorspiel/Fin/Matrix.lean b/LeanPool/PointwiseComposition/Foundation/Vorspiel/Fin/Matrix.lean new file mode 100644 index 000000000..87743053e --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/Vorspiel/Fin/Matrix.lean @@ -0,0 +1,66 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Matrix + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace Fin + +open _root_.Fin + +lemma forall_le_vec_iff_forall_le_forall_vec [LE α] {P : (Fin (k + 1) → α) → Prop} + {f : Fin (k + 1) → α} : (∀ v ≤ f, P v) ↔ ∀ x ≤ f 0, ∀ v ≤ (f ·.succ), P (x :> v) := + by + constructor + · intro h x hx v hv + refine h (x :> v) ?_ + intro i; refine Fin.cases ?_ (fun i => ?_) i + · exact hx + · exact hv i + · intro h v hv + simpa using h (v 0) (hv 0) (v ·.succ) (hv ·.succ) + +lemma forall_vec_iff_forall_forall_vec {P : (Fin (k + 1) → α) → Prop} : + (∀ v : Fin (k + 1) → α, P v) ↔ ∀ x, ∀ v : Fin k → α, P (x :> v) := + by + constructor + · intro h x v; exact h _ + · intro h v; simpa using h (v 0) (v ·.succ) + +lemma exists_vec_iff_exists_exists_vec {P : (Fin (k + 1) → α) → Prop} : + (∃ v : Fin (k + 1) → α, P v) ↔ ∃ x, ∃ v : Fin k → α, P (x :> v) := + by + constructor + · rintro ⟨v, h⟩; exact ⟨v 0, (v ·.succ), by simpa using h⟩ + · rintro ⟨x, v, h⟩; exact ⟨_, h⟩ + +lemma exists_le_vec_iff_exists_le_exists_vec [LE α] {P : (Fin (k + 1) → α) → Prop} + {f : Fin (k + 1) → α} : (∃ v ≤ f, P v) ↔ ∃ x ≤ f 0, ∃ v ≤ (f ·.succ), P (x :> v) := + by + constructor + · rintro ⟨w, hw, h⟩ + exact ⟨w 0, hw 0, (w ·.succ), fun i ↦ hw i.succ, by simpa using h⟩ + · rintro ⟨x, hx, v, hv, h⟩ + refine ⟨x :> v, ?_, h⟩ + intro i; refine Fin.cases ?_ (fun i => ?_) i + · exact hx + · exact hv i + +end Fin + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/Vorspiel/Finset/Basic.lean b/LeanPool/PointwiseComposition/Foundation/Vorspiel/Finset/Basic.lean new file mode 100644 index 000000000..6af08bd3f --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/Vorspiel/Finset/Basic.lean @@ -0,0 +1,106 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import Mathlib.Data.Fin.VecNotation +public import Mathlib.Data.Finset.Preimage +public import Mathlib.Data.Finset.Sort +public import Mathlib.Data.Fintype.Sigma +public import Mathlib.Data.Fintype.Vector +public import Mathlib.Data.Set.Finite.Range + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace Finset + +open _root_.Finset + +variable {α : Type*} {a b : α} {s : Finset α} + +@[grind =] +lemma doubleton_subset [DecidableEq α] : ({ a, b } : Finset α) ⊆ s ↔ a ∈ s ∧ b ∈ s := by + constructor; · intro h; have ⟨ha, hb⟩ := Finset.insert_subset_iff.mp h; tauto; + · rintro ⟨ha, hb⟩; apply Finset.insert_subset_iff.mpr; constructor; · assumption; + · simpa; + /- + Thanks to @plp127 + + https://leanprover.zulipchat.com/#narrow/channel/217875-Is-there-code-for-X.3F/topic/ascending.2Fdecending.20lemmata.20related.20.60Set.60.20and.20.60Finset.60/near/539367015 + -/ + +lemma no_ssubset_descending_chain {f : ℕ → Finset α} : ¬(∀ i, ∃ j > i, f j ⊂ f i) := + by + intro h + have n := 0 + induction hf : f n using WellFoundedLT.fix generalizing n with subst hf + | _ _ ih + obtain ⟨m, -, hy⟩ := h n + exact ih (f m) hy m rfl + +section + +/-- The range Of Finite construction in `Finset`. -/ +noncomputable def rangeOfFinite {ι : Sort v} [Finite ι] (f : ι → α) : Finset α := + Set.Finite.toFinset (s := Set.range f) (Set.finite_range f) + +lemma mem_rangeOfFinite_iff {ι : Sort v} [Finite ι] {f : ι → α} {a : α} : + a ∈ rangeOfFinite f ↔ ∃ i : ι, f i = a := by simp [rangeOfFinite] + +/-- The image Of Finset construction in `Finset`. -/ +noncomputable def imageOfFinset [DecidableEq β] (s : Finset α) (f : (a : α) → a ∈ s → β) : + Finset β := + Finset.biUnion s (rangeOfFinite <| f ·) + +lemma mem_imageOfFinset_iff [DecidableEq β] {s : Finset α} {f : (a : α) → a ∈ s → β} {b : β} : + b ∈ imageOfFinset s f ↔ ∃ (a : α) (ha : a ∈ s), f a ha = b := by + simp [imageOfFinset, mem_rangeOfFinite_iff] + +@[simp] +lemma mem_imageOfFinset [DecidableEq β] {s : Finset α} (f : (a : α) → a ∈ s → β) (a : α) + (ha : a ∈ s) : f a ha ∈ imageOfFinset s f := by + simpa [mem_imageOfFinset_iff] using ⟨a, ha, rfl⟩ + +lemma erase_union [DecidableEq α] {a : α} {s t : Finset α} : + (s ∪ t).erase a = (s.erase a) ∪ (t.erase a) := by ext; simp [and_or_left] + +lemma equiv_univ {α α'} [Fintype α] [Fintype α'] [DecidableEq α'] (e : α ≃ α') : + (Finset.univ : Finset α).image e = Finset.univ := by ext x; simp + +@[simp] +lemma sup_univ_equiv {α α'} [Fintype α] [Fintype α'] [SemilatticeSup β] [OrderBot β] (f : α → β) + (e : α' ≃ α) : Finset.sup Finset.univ (fun i => f (e i)) = Finset.sup Finset.univ f := by + classical simpa [Function.comp] using! Eq.symm <| Finset.sup_image Finset.univ e f + +lemma sup_univ_cast {α : Type _} [SemilatticeSup α] [OrderBot α] {n} (f : Fin n → α) (n') + {h : n' = n} : + Finset.sup Finset.univ (fun (i : Fin n') => f (i.cast h)) = Finset.sup Finset.univ f := by + rcases h with rfl; simp + +end + +lemma biUnion_eq_empty [DecidableEq β] {s : Finset α} {f : α → Finset β} : + s.biUnion f = ∅ ↔ ∀ i ∈ s, f i = ∅ := by + constructor + · intro h a ha; ext b + have := by simpa using congrFun (congrArg Membership.mem h) b + simpa using this a ha + · intro h; ext b + suffices ∀ x ∈ s, b ∉ f x by simpa + intro a ha; simpa using congrFun (congrArg Membership.mem (h a ha)) b + +end Finset + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/Vorspiel/Finset/Card.lean b/LeanPool/PointwiseComposition/Foundation/Vorspiel/Finset/Card.lean new file mode 100644 index 000000000..9b4ffbf5f --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/Vorspiel/Finset/Card.lean @@ -0,0 +1,44 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import Mathlib.Algebra.Order.BigOperators.Group.Finset +public import Mathlib.Algebra.Order.Ring.Nat + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace Finset + +open _root_.Finset + +variable {α} {s t : Finset α} + +lemma ssubset_of_subset_lt_card (h_subset : s ⊆ t) (h_card_le : s.card < t.card) : s ⊂ t := + by + constructor; · assumption; + · by_contra hC; have : t = s := Finset.eq_iff_card_le_of_subset hC |>.mp (by omega); + subst this; simp at h_card_le; + +lemma eq_card_of_eq (h : s = t) : s.card = t.card := by tauto; + +lemma sum_le_card {n} {f : α → ℕ} (hf : ∀ a ∈ s, f a ≤ n) : (∑ a ∈ s, f a) ≤ s.card * n := + calc + _ ≤ (∑ x ∈ s, n) := by apply Finset.sum_le_sum hf + _ = s.card * n := by simp_all; + +end Finset + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/Vorspiel/Function.lean b/LeanPool/PointwiseComposition/Foundation/Vorspiel/Function.lean new file mode 100644 index 000000000..27510f3af --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/Vorspiel/Function.lean @@ -0,0 +1,37 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import Mathlib.Data.Fintype.Basic + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace Function + +open _root_.Function + +variable {α : Type u} {β : Type v} + +/-- The fun Eq On construction in `Function`. -/ +def funEqOn (φ : α → Prop) (f g : α → β) : Prop := + ∀ a, φ a → f a = g a + +lemma funEqOn.of_subset {φ ψ : α → Prop} {f g : α → β} (e : funEqOn φ f g) + (h : ∀ a, ψ a → φ a) : funEqOn ψ f g := by intro a ha; exact e a (h a ha) + +end Function + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/Vorspiel/Graph.lean b/LeanPool/PointwiseComposition/Foundation/Vorspiel/Graph.lean new file mode 100644 index 000000000..535eb96b2 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/Vorspiel/Graph.lean @@ -0,0 +1,75 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import Mathlib.Logic.Function.Defs + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace Function + +open _root_.Function + +variable {k} {σ α β γ δ ε : Sort*} + +/-- The Graphᵥ construction in `Function`. -/ +def Graphᵥ (f : (Fin k → α) → α) : (Fin (k + 1) → α) → Prop := fun v ↦ v 0 = f (v ·.succ) + +/-- The Graph construction in `Function`. -/ +def Graph (f : α → σ) : σ → α → Prop := fun y x ↦ y = f x + +/-- The Graph₂ construction in `Function`. -/ +def Graph₂ (f : α → β → σ) : σ → α → β → Prop := fun y x₁ x₂ ↦ y = f x₁ x₂ + +/-- The Graph₃ construction in `Function`. -/ +def Graph₃ (f : α → β → γ → σ) : σ → α → β → γ → Prop := fun y x₁ x₂ x₃ ↦ y = f x₁ x₂ x₃ + +/-- The Graph₄ construction in `Function`. -/ +def Graph₄ (f : α → β → γ → δ → σ) : σ → α → β → γ → δ → Prop := fun y x₁ x₂ x₃ x₄ ↦ + y = f x₁ x₂ x₃ x₄ + +/-- The Graph₅ construction in `Function`. -/ +def Graph₅ (f : α → β → γ → δ → ε → σ) : σ → α → β → γ → δ → ε → Prop := fun y x₁ x₂ x₃ x₄ x₅ ↦ + y = f x₁ x₂ x₃ x₄ x₅ + +lemma Graph.eq {f : α → σ} {y x} (h : Graph f y x) : f x = y := + h.symm + +lemma Graph.iff_left (f : α → σ) {y x} : f x = y ↔ Graph f y x := by simp [Graph, eq_comm] + +lemma Graph.iff_right (f : α → σ) {y x} : y = f x ↔ Graph f y x := by simp [Graph] + +lemma Graph₂.eq {f : α → β → σ} {y x₁ x₂} (h : Graph₂ f y x₁ x₂) : f x₁ x₂ = y := + h.symm + +lemma Graph₂.iff_left (f : α → β → σ) {y x₁ x₂} : f x₁ x₂ = y ↔ Graph₂ f y x₁ x₂ := by + simp [Graph₂, eq_comm] + +lemma Graph₂.iff_right (f : α → β → σ) {y x₁ x₂} : y = f x₁ x₂ ↔ Graph₂ f y x₁ x₂ := by + simp [Graph₂] + +lemma Graph₃.eq {f : α → β → γ → σ} {y x₁ x₂ x₃} (h : Graph₃ f y x₁ x₂ x₃) : f x₁ x₂ x₃ = y := + h.symm + +lemma Graph₃.iff_left (f : α → β → γ → σ) {y x₁ x₂ x₃} : f x₁ x₂ x₃ = y ↔ Graph₃ f y x₁ x₂ x₃ := + by simp [Graph₃, eq_comm] + +lemma Graph₃.iff_right (f : α → β → γ → σ) {y x₁ x₂ x₃} : + y = f x₁ x₂ x₃ ↔ Graph₃ f y x₁ x₂ x₃ := by simp [Graph₃] + +end Function + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/Vorspiel/IsEmpty.lean b/LeanPool/PointwiseComposition/Foundation/Vorspiel/IsEmpty.lean new file mode 100644 index 000000000..bfccacc5b --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/Vorspiel/IsEmpty.lean @@ -0,0 +1,34 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import Mathlib.Basic.IsEmpty.Basic + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace IsEmpty + +variable {o : Sort u} (h : IsEmpty o) + +lemma eq_elim' {α : Sort*} (f : o → α) : f = h.elim' := + funext h.elim + +lemma eq_elim {α : Sort*} (f : o → α) : f = h.elim := + funext h.elim + +end IsEmpty + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/Vorspiel/List/Basic.lean b/LeanPool/PointwiseComposition/Foundation/Vorspiel/List/Basic.lean new file mode 100644 index 000000000..cec3153bc --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/Vorspiel/List/Basic.lean @@ -0,0 +1,361 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. +public import Mathlib.Data.Fintype.Sigma +public import Mathlib.Data.Fintype.Vector +public import Mathlib.Data.List.GetD +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Matrix + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +/-- Compatibility shim: mathlib v4.31 removed the named `Finset.toSet` that used to back the +`Finset → Set` coercion (the coercion is now an inline lambda). Re-introduce the name as a +reducible alias for the coercion so existing `.toSet` call-sites keep elaborating and the +`Finset.coe_*` simp lemmas continue to fire through it. -/ +@[reducible] +def _root_.PointwiseComposition.Finset.toSet {α : Type*} (s : Finset α) : Set α := + (s : Set α) + +namespace List + +open _root_.List + +variable {l : List α} + +variable {α : Type u} {β : Type v} + +lemma getI_map_range [Inhabited α] (f : ℕ → α) (h : i < n) : + ((List.range n).map f).getI i = f i := by + simpa [h] using List.getI_eq_getElem ((List.range n).map f) (n := i) (by simpa using h) + +/-- The subset Set construction in `List`. -/ +def subsetSet (l : List α) (s : Set α) [DecidablePred s] : Bool := + l.foldr (fun a ih => s a && ih) true + +/-- The upper construction in `List`. -/ +def upper : List ℕ → ℕ + | [] => 0 + | n :: ns => max (n + 1) (PointwiseComposition.List.upper ns) + +@[simp] +lemma upper_nil : upper [] = 0 := + rfl + +@[simp] +lemma upper_cons (n : ℕ) (ns : List ℕ) : + upper (n :: ns) = max (n + 1) (PointwiseComposition.List.upper ns) := + rfl + +lemma lt_upper (l : List ℕ) {n} (h : n ∈ l) : n < (PointwiseComposition.List.upper l) := by + induction l generalizing n with + | nil => simp at h + | cons a l ih => + rcases _root_.List.mem_cons.mp h with rfl | h + · exact Nat.lt_of_lt_of_le (Nat.lt_succ_self _) (le_max_left _ _) + · exact Nat.lt_of_lt_of_le (ih h) (le_max_right _ _) + +section finset + +variable [DecidableEq α] [DecidableEq β] + +lemma toFinset_map {f : α → β} (l : List α) : (l.map f).toFinset = Finset.image f l.toFinset := + by induction l <;> simp [*] + +lemma toFinset_mono {l l' : List α} (h : l ⊆ l') : l.toFinset ⊆ l'.toFinset := by + intro a; + simp only [mem_toFinset]; intro ha; exact h ha + +end finset + +section sup + +variable [SemilatticeSup α] [OrderBot α] + +/-- The sup construction in `List`. -/ +def sup : List α → α + | [] => ⊥ + | a :: as => a ⊔ (PointwiseComposition.List.sup as) + +@[simp] +lemma sup_nil : (PointwiseComposition.List.sup ([] : List α)) = ⊥ := + rfl + +@[simp] +lemma sup_cons (a : α) (as : List α) : + (PointwiseComposition.List.sup (a :: as)) = a ⊔ (PointwiseComposition.List.sup as) := + rfl + +lemma le_sup {a} {l : List α} : a ∈ l → a ≤ (PointwiseComposition.List.sup l) := by + induction l with + | nil => simp + | cons b l ih => + intro h + rcases _root_.List.mem_cons.mp h with rfl | h + · simp + · exact le_sup_of_le_right (ih h) + +lemma sup_ofFn (f : Fin n → α) : + (PointwiseComposition.List.sup (ofFn f)) = Finset.sup Finset.univ f := by + induction n with + | zero => simp + | succ n + ih => + have h₁ : + (Finset.univ : Finset (Fin (n + 1))) = + insert 0 ((Finset.univ : Finset (Fin n)).image Fin.succ) := + by ext i; simp + have h₂ : Finset.sup Finset.univ (fun i ↦ f (Fin.succ i)) = Finset.sup {0}ᶜ f := by + simpa [Function.comp] using! + Eq.symm <| Finset.sup_image (Finset.univ : Finset (Fin n)) Fin.succ f + calc + (PointwiseComposition.List.sup (ofFn f)) = + (f 0 ⊔ Finset.univ.sup fun i : Fin _ ↦ f i.succ) := + by simp [ih] + _ = f 0 ⊔ Finset.sup {0}ᶜ f := by rw [h₂] + _ = Finset.univ.sup f := by rw [h₁, Finset.sup_insert]; simp + +end sup + +lemma ofFn_get_eq_map_cast {n} (g : α → β) (as : List α) {h} : + ofFn (fun i => g (as.get (i.cast h)) : Fin n → β) = as.map g := + by + ext i b; simp + by_cases hi : i < n + · simp [hi, List.getElem?_eq_getElem (h ▸ hi)] + · simp [hi, List.getElem?_eq_none (le_of_not_gt <| h ▸ hi)] + +variable {m : Type _ → Type _} {α : Type _} {β : Type _} [Monad m] + +lemma append_subset_append {l₁ l₂ l : List α} (h : l₁ ⊆ l₂) : l₁ ++ l ⊆ l₂ ++ l := + List.append_subset.mpr ⟨List.subset_append_of_subset_left _ h, subset_append_right l₂ l⟩ + +lemma subset_of_eq {l₁ l₂ : List α} (e : l₁ = l₂) : l₁ ⊆ l₂ := by simp [e] + +section remove + +/-- The remove construction in `List`. -/ +def remove [DecidableEq α] (a : α) : List α → List α := + List.filter (· ≠ a) + +variable [DecidableEq α] + +@[simp] +lemma remove_nil (a : α) : (PointwiseComposition.List.remove · []) a = [] := by + simp [List.remove] + +@[simp] +lemma eq_remove_cons {l : List α} : + (PointwiseComposition.List.remove · (ψ :: l)) ψ = + (PointwiseComposition.List.remove · l) ψ := + by induction l <;> simp_all [List.remove]; + +@[simp] +lemma remove_singleton_of_ne {φ ψ : α} (h : φ ≠ ψ) : + (PointwiseComposition.List.remove · [φ]) ψ = [φ] := by simp_all [List.remove]; + +lemma mem_remove_iff {l : List α} : + b ∈ (PointwiseComposition.List.remove · l) a ↔ b ∈ l ∧ b ≠ a := by simp [List.remove] + +lemma mem_of_mem_remove {a b : α} {l : List α} + (h : b ∈ (PointwiseComposition.List.remove · l) a) : b ∈ l := by + rw [mem_remove_iff] at h; exact h.1 + +lemma remove_cons_self (l : List α) (a) : + (PointwiseComposition.List.remove · (a :: l)) a = + (PointwiseComposition.List.remove · l) a := + by simp [remove] + +lemma remove_cons_of_ne (l : List α) {a b} (ne : a ≠ b) : + (PointwiseComposition.List.remove · (a :: l)) b = + a :: (PointwiseComposition.List.remove · l) b := + by simp_all [remove]; + +@[simp] +lemma remove_subset (a) (l : List α) : (PointwiseComposition.List.remove · l) a ⊆ l := + by + simp only [subset_def, mem_remove_iff, ne_eq, and_imp] + intros; simp [*] + +@[simp] +lemma subset_cons_remove (a) (l : List α) : l ⊆ a :: (PointwiseComposition.List.remove · l) a := + by + simp only [subset_def, mem_cons, mem_remove_iff, ne_eq] + intro b; tauto + +lemma remove_subset_remove (a) {l₁ l₂ : List α} (h : l₁ ⊆ l₂) : + (PointwiseComposition.List.remove · l₁) a ⊆ (PointwiseComposition.List.remove · l₂) a := + by + simp only [subset_def, mem_remove_iff, ne_eq, and_imp] + intros + simpa [*] using h (by assumption) + +lemma remove_cons_subset_cons_remove (a b) (l : List α) : + (PointwiseComposition.List.remove · (a :: l)) b ⊆ + a :: (PointwiseComposition.List.remove · l) b := + by + intro x + simp only [mem_remove_iff, mem_cons, ne_eq, and_imp] + rintro (rfl | hx) nex <;> simp [*] + +lemma remove_map_subset_map_remove [DecidableEq β] (f : α → β) (l : List α) (a) : + (PointwiseComposition.List.remove · (l.map f)) (f a) ⊆ + ((PointwiseComposition.List.remove · l) a).map f := + by + simp only [subset_def, mem_remove_iff, mem_map, ne_eq, and_imp, forall_exists_index, + forall_apply_eq_imp_iff₂] + intro b hb neb; exact ⟨b, ⟨hb, by rintro rfl; exact neb rfl⟩, rfl⟩ + +end remove + +@[elab_as_elim] +lemma induction_with_singleton {motive : List F → Prop} (hnil : motive []) + (hsingle : ∀ a, motive [a]) (hcons : ∀ a as, as ≠ [] → motive as → motive (a :: as)) : + ∀ as, motive as := by + intro as; + induction as with + | nil => + exact hnil; + | cons a as ih => + cases as with + | nil => + exact hsingle a; + | cons b bs => + exact hcons a (b :: bs) (by simp) ih; + +/-- The induction with singleton' construction in `List`. -/ +@[elab_as_elim] +def inductionWithSingleton' {motive : List α → Sort*} (hnil : motive []) + (hsingle : ∀ a, motive [a]) (hcons : ∀ a b as, motive (b :: as) → motive (a :: b :: as)) : + ∀ as, motive as + | [] => hnil + | [a] => hsingle a + | a :: b :: as => hcons a b as (inductionWithSingleton' hnil hsingle hcons (b :: as)) + +instance Nodup.finite [Finite α] : Finite { l : List α // l.Nodup } := + by + have : Fintype α := Fintype.ofFinite α + let N := Fintype.card α + 1 + have : Fintype ((i : Fin N) × _root_.List.Vector α i) := _root_.Sigma.instFintype + let f : { l : List α // l.Nodup } → ((i : Fin N) × _root_.List.Vector α i) := fun l ↦ + ⟨⟨l.val.length, Nat.lt_add_one_of_le <| l.prop.length_le_card⟩, l, by simp⟩ + have : Function.Injective f := by + intro ⟨l₁, hl₁⟩ ⟨l₂, hl₂⟩ H + simpa [f] using congrArg (fun p ↦ p.2.val) H + exact Finite.of_injective f this + +section suffix + +lemma suffix_of_cons_suffix {l₁ l₂ : List α} {a} : a :: l₁ <:+ l₂ → l₁ <:+ l₂ := by + rintro ⟨l₂, rfl⟩; exact ⟨l₂ ++ [a], by simp⟩ + +lemma suffix_cons_of {l₁ l₂ : List α} {a} : l₁ <:+ l₂ → l₁ <:+ a :: l₂ := fun h ↦ + suffix_cons_iff.mpr <| Or.inr h + +lemma exists_of_not_suffix (l₁ l₂ : List α) : + ¬l₁ <:+ l₂ → ∃ l a, a :: l <:+ l₁ ∧ l <:+ l₂ ∧ ¬a :: l <:+ l₂ := + match l₁ with + | [] => by simp + | a :: l₁ => by + intro h + by_cases h₁₂ : l₁ <:+ l₂ + · exact ⟨l₁, a, by simp_all⟩ + · rcases exists_of_not_suffix l₁ l₂ h₁₂ with ⟨l, b, hb, hll₂, nh⟩ + exact ⟨l, b, suffix_cons_of hb, hll₂, nh⟩ + +lemma IsSuffix.eq_or_cons_suffix : l₁ <:+ l₂ → l₁ = l₂ ∨ ∃ a, a :: l₁ <:+ l₂ := + by + rintro ⟨l, rfl⟩ + rcases eq_nil_or_concat' l with (rfl | ⟨l, a, rfl⟩) + · simp + · right; exact ⟨a, l, by simp⟩ + +lemma suffix_trichotomy {l₁ l₂ : List α} (h₁₂ : ¬l₁ <:+ l₂) (h₂₁ : ¬l₂ <:+ l₁) : + ∃ l a b, a ≠ b ∧ a :: l <:+ l₁ ∧ b :: l <:+ l₂ := + by + rcases exists_of_not_suffix _ _ h₁₂ with ⟨l, a, ha, hkl, _⟩ + have : ∃ b, b :: l <:+ l₂ := + by + rcases (PointwiseComposition.List.IsSuffix.eq_or_cons_suffix hkl) with (rfl | h) + · have : l <:+ l₁ := suffix_of_cons_suffix ha + contradiction + exact h + rcases this with ⟨b, hb⟩ + exact ⟨l, a, b, by rintro rfl; contradiction, ha, hb⟩ + +end suffix + +namespace Vector + +open _root_.List.Vector + +variable {α : Type*} + +lemma get_mk_eq_get {n} (l : List α) (h : l.length = n) (i : Fin n) : + List.Vector.get (⟨l, h⟩ : List.Vector α n) i = l.get (i.cast h.symm) := + rfl + +lemma get_one {α : Type*} {n} (v : _root_.List.Vector α (n + 2)) : v.get 1 = v.tail.head := by + have : v.tail.get ⟨0, by omega⟩ = v.get 1 := Vector.get_tail_succ v 0; simp [← this]; + +lemma ofFn_vecCons (a : α) (v : Fin n → α) : + _root_.List.Vector.ofFn (a :> v) = a ::ᵥ _root_.List.Vector.ofFn v := by + ext i; + cases i using Fin.cases <;> simp + +lemma cons_get (a : α) (v : List.Vector α k) : (a ::ᵥ v).get = a :> v.get := by + ext i; + cases i using Fin.cases <;> simp + +end Vector + +lemma exists_of_not_nil (hl : l ≠ []) : ∃ a, a ∈ l := by + match l with + | [] => tauto; + | a :: l => use a; simp only [mem_cons, true_or]; + +lemma iff_nil_forall : (l = []) ↔ (∀ a ∈ l, a ∈ []) := + by + constructor; · intro h; subst h; tauto; + · contrapose!; rintro h; obtain ⟨a, ha⟩ := exists_of_not_nil h; use a; tauto; + +/-- getElem version of `List.nodup_iff_getElem?_ne_getElem?` -/ +lemma nodup_iff_get_ne_get : l.Nodup ↔ ∀ i j : Fin l.length, i < j → l[i] ≠ l[j] := + by + apply Iff.trans nodup_iff_getElem?_ne_getElem?; constructor; + · rintro h ⟨i, _⟩ ⟨j, hj⟩ hij; have := h i j (by omega) hj; simp_all; + · rintro h i j hij hj; rw [getElem?_eq_getElem, getElem?_eq_getElem]; + simpa [Option.some.injEq] using h ⟨i, by omega⟩ ⟨j, by omega⟩ hij; + +lemma Nodup.infinite_of_infinite : Infinite { l : List α // l.Nodup } → Infinite α := by + contrapose!; intro _; exact List.Nodup.finite; + +lemma exists_of_range (h : a ∈ List.map f (List.range n)) : ∃ i < n, a = f i := + by + obtain ⟨i, ⟨hi, rfl⟩⟩ := List.exists_of_mem_map h; use i; constructor; · simpa using hi; + · simp; + +lemma single_suffix_uniq {l : List α} (ha : [a] <:+ l) (hb : [b] <:+ l) : a = b := + by + rcases ha with ⟨la, rfl⟩ + rcases hb with ⟨lb, e⟩ + exact + Eq.symm + (List.concat_inj.mp <| by { simpa using e + }).2 + +end List + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/Vorspiel/Matrix.lean b/LeanPool/PointwiseComposition/Foundation/Vorspiel/Matrix.lean new file mode 100644 index 000000000..32213ac57 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/Vorspiel/Matrix.lean @@ -0,0 +1,468 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. +public import Mathlib.Tactic.FinCases +public import Mathlib.Data.Fin.VecNotation +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Nat.Basic +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Fin.Basic + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace Matrix + +open _root_.Matrix + +open _root_.Fin + +section + +variable {n : ℕ} {α : Type u} + +/-- The «term :> » construction in `Matrix`. -/ +infixr:70 " :> " => vecCons + +@[simp] +lemma vecCons_zero : (a :> s) 0 = a := by simp + +lemma vecCons_succ (i : Fin n) : (a :> s) (Fin.succ i) = s i := by simp + +@[simp] +lemma vecCons_last (a : C) (s : Fin (n + 1) → C) : + (a :> s) (Fin.last (n + 1)) = s (Fin.last n) := + vecCons_succ (Fin.last n) + +/-- The vec Cons Last construction in `Matrix`. -/ +def vecConsLast {n : ℕ} (t : Fin n → α) (h : α) : Fin n.succ → α := + Fin.lastCases h t + +@[simp] +lemma cons_app_one {n : ℕ} (a : α) (s : Fin n.succ → α) : (a :> s) 1 = s 0 := + rfl + +@[simp] +lemma cons_app_two {n : ℕ} (a : α) (s : Fin n.succ.succ → α) : (a :> s) 2 = s 1 := + rfl + +@[simp] +lemma cons_app_three {n : ℕ} (a : α) (s : Fin n.succ.succ.succ → α) : (a :> s) 3 = s 2 := + rfl + +@[simp] +lemma cons_app_four {n : ℕ} (a : α) (s : Fin n.succ.succ.succ.succ → α) : (a :> s) 4 = s 3 := + rfl + +@[simp] +lemma cons_app_five {n : ℕ} (a : α) (s : Fin n.succ.succ.succ.succ.succ → α) : + (a :> s) 5 = s 4 := + rfl + +@[simp] +lemma cons_app_six {n : ℕ} (a : α) (s : Fin n.succ.succ.succ.succ.succ.succ → α) : + (a :> s) 6 = s 5 := + rfl + +@[simp] +lemma cons_app_seven {n : ℕ} (a : α) (s : Fin n.succ.succ.succ.succ.succ.succ.succ → α) : + (a :> s) 7 = s 6 := + rfl + +@[simp] +lemma cons_app_eight {n : ℕ} (a : α) (s : Fin n.succ.succ.succ.succ.succ.succ.succ.succ → α) : + (a :> s) 8 = s 7 := + rfl + +section delab + +open _root_.Lean Lean PrettyPrinter Delaborator SubExpr + +/-- The unexpand Vec Empty construction in `Matrix`. -/ +@[app_unexpander Matrix.vecEmpty] +meta def unexpandVecEmpty : Unexpander + | `($(_)) => `(![]) + +/-- The unexpand Vec Cons construction in `Matrix`. -/ +@[app_unexpander Matrix.vecCons] +meta def unexpandVecCons : Unexpander + | `($(_) $a ![]) => `(![$a]) + | `($(_) $a ![$as,*]) => `(![$a, $as,*]) + | _ => throw () + + + +end delab + +/-- The «term <: » construction in `Matrix`. -/ +infixl:70 " <: " => vecConsLast + +@[simp] +lemma rightConcat_last : (s <: a) (Fin.last n) = a := by simp [vecConsLast] + +@[simp] +lemma rightConcat_castSucc (i : Fin n) : (s <: a) (Fin.castSucc i) = s i := by + simp [vecConsLast] + +@[simp] +lemma rightConcat_zero (a : α) (s : Fin n.succ → α) : (s <: a) 0 = s 0 := + rightConcat_castSucc 0 + +@[simp] +lemma zero_succ_eq_id {n} : (0 : Fin (n + 1)) :> Fin.succ = id := + funext <| Fin.cases (by simp) (by simp) + +@[simp] +lemma zero_cons_succ_eq_self (f : Fin (n + 1) → α) : + (f 0 :> (f ·.succ) : Fin (n + 1) → α) = f := by funext x; cases x using Fin.cases <;> simp + +lemma eq_vecCons (s : Fin (n + 1) → C) : s 0 :> s ∘ Fin.succ = s := + funext <| Fin.cases (by simp) (by simp) + +lemma eq_vecCons' (s : Fin (n + 1) → C) : s 0 :> (s ·.succ) = s := + funext <| Fin.cases (by simp) (by simp) + +lemma vecCons_ext (a₁ a₂ : α) (s₁ s₂ : Fin n → α) : a₁ :> s₁ = a₂ :> s₂ ↔ a₁ = a₂ ∧ s₁ = s₂ := + by + constructor + · intro h + exact ⟨congrFun h 0, funext fun i => by simpa using congrFun h (Fin.castSucc i + 1)⟩ + · rintro ⟨rfl, rfl⟩ + rfl + +lemma vecCons_assoc (a b : α) (s : Fin n → α) : a :> (s <: b) = (a :> s) <: b := + by + funext x; refine Fin.cases ?_ (fun x => ?_) x + · simp + · cases x using Fin.lastCases + · simp + case cast i => simp; simp only [rightConcat_castSucc, Fin.succ_castSucc i, cons_val_succ] + +/-- The dec Vec construction in `Matrix`. -/ +def decVec {α : Type _} : + {n : ℕ} → (v w : Fin n → α) → (∀ i, Decidable (v i = w i)) → Decidable (v = w) + | 0, _, _, _ => by simpa [Matrix.empty_eq] using isTrue trivial + | n + 1, v, w, d => by + rw [← eq_vecCons v, ← eq_vecCons w, vecCons_ext] + haveI : Decidable (v ∘ Fin.succ = w ∘ Fin.succ) := decVec _ _ (by intros i; simpa using d _) + refine instDecidableAnd + +lemma comp_vecCons (f : α → β) (a : α) (s : Fin n → α) : + (fun x ↦ f <| (a :> s) x) = f a :> f ∘ s := + funext (fun i => Fin.cases (by simp) (by simp) i) + +lemma comp_vecCons' (f : α → β) (a : α) (s : Fin n → α) : + (fun x ↦ f <| (a :> s) x) = f a :> fun i ↦ f (s i) := + comp_vecCons f a s + +lemma comp_vecCons'' (f : α → β) (a : α) (s : Fin n → α) : f ∘ (a :> s) = f a :> f ∘ s := + comp_vecCons f a s + +lemma comp_vecCons₂' (g : β → γ) (f : α → β) (a : α) (s : Fin n → α) : + (fun x ↦ g <| f <| (a :> s) x) = (g (f a) :> fun i ↦ g <| f <| s i) := + by + funext x + cases x using Fin.cases <;> simp + +@[simp] +lemma comp₀ : f ∘ (![] : Fin 0 → α) = ![] := by simp [Matrix.empty_eq] + +@[simp] +lemma comp₁ (a : α) : f ∘ ![a] = ![f a] := by simp [comp_vecCons''] + +@[simp] +lemma comp₂ (a₁ a₂ : α) : f ∘ ![a₁, a₂] = ![f a₁, f a₂] := by simp [comp_vecCons''] + +@[simp] +lemma comp₃ (a₁ a₂ a₃ : α) : f ∘ ![a₁, a₂, a₃] = ![f a₁, f a₂, f a₃] := by simp [comp_vecCons''] + +@[simp] +lemma comp₄ (a₁ a₂ a₃ a₄ : α) : f ∘ ![a₁, a₂, a₃, a₄] = ![f a₁, f a₂, f a₃, f a₄] := by + simp [comp_vecCons''] + +lemma comp_vecConsLast (f : α → β) (a : α) (s : Fin n → α) : + (fun x => f <| (s <: a) x) = f ∘ s <: f a := + funext (fun i => Fin.lastCases (by simp) (by simp) i) + +@[simp] +lemma vecHead_comp (f : α → β) (v : Fin (n + 1) → α) : vecHead (f ∘ v) = f (vecHead v) := by + simp [vecHead] + +@[simp] +lemma vecTail_comp (f : α → β) (v : Fin (n + 1) → α) : vecTail (f ∘ v) = f ∘ (vecTail v) := by + simp [vecTail, Function.comp_assoc] + +lemma vecConsLast_vecEmpty {s : Fin 0 → α} (a : α) : s <: a = ![a] := + funext + (fun x => by + have : 0 = Fin.last 0 := by rfl + refine Fin.cases ?_ (fun i => ?_) x + · rw [this, rightConcat_last, cons_val_fin_one] + have := i.isLt; contradiction) + +lemma constant_eq_singleton {a : α} : (fun _ ↦ a) = ![a] := by funext x; simp + +lemma fun_eq_vec_one (v : Fin 1 → α) : v = ![v 0] := + by + funext x + fin_cases x; rfl + +lemma constant_eq_vec₂ {a : α} : (fun _ ↦ a) = ![a, a] := by + funext x; + cases x using Fin.cases <;> simp + +lemma fun_eq_vec_two (v : Fin 2 → α) : v = ![v 0, v 1] := + by + funext x + fin_cases x <;> rfl + +lemma fun_eq_vec_three (v : Fin 3 → α) : v = ![v 0, v 1, v 2] := + by + funext x + fin_cases x <;> rfl + +lemma fun_eq_vec_four (v : Fin 4 → α) : v = ![v 0, v 1, v 2, v 3] := + by + funext x + fin_cases x <;> rfl + +lemma fun_eq_vec_four' (f : α → β) (v : Fin 4 → α) : + f ∘ v = ![f (v 0), f (v 1), f (v 2), f (v 3)] := by rw [fun_eq_vec_four v]; simp + +lemma injective_vecCons {f : Fin n → α} (h : Function.Injective f) {a} (ha : ∀ i, a ≠ f i) : + Function.Injective (a :> f) := + by + have : ∀ i, f i ≠ a := fun i => (ha i).symm + intro i j; cases i using Fin.cases <;> cases j using Fin.cases + · simp + · simp [*] + · simp [*] + · simpa using @h _ _ + +@[simp] +lemma vecCons_empty_eq_singleton (v : Fin 0 → α) (x : α) : x :> v = ![x] := + by + ext i + rcases Fin.fin_one_eq_zero i + simp + +@[simp] +lemma vecConsLast_empty_eq_singleton (v : Fin 0 → α) (x : α) : v <: x = ![x] := + by + ext i + rcases Fin.fin_one_eq_zero i + simp [vecConsLast] + rfl + +end + +variable {α : Type _} + +/-- The to List construction in `Matrix`. -/ +def toList : {n : ℕ} → (Fin n → α) → List α + | 0, _ => [] + | _ + 1, v => v 0 :: toList (v ∘ Fin.succ) + +@[simp] +lemma toList_zero (v : Fin 0 → α) : toList v = [] := + rfl + +@[simp] +lemma toList_succ (v : Fin (n + 1) → α) : toList v = v 0 :: toList (v ∘ Fin.succ) := + rfl + +@[simp] +lemma toList_length (v : Fin n → α) : (toList v).length = n := by induction n <;> simp [*] + +@[simp] +lemma mem_toList_iff {v : Fin n → α} {a} : a ∈ toList v ↔ ∃ i, v i = a := + by + induction n + · simp [*] + · suffices (a = v 0 ∨ ∃ i : Fin _, v i.succ = a) ↔ ∃ i, v i = a by simp [*] + constructor + · rintro (rfl | ⟨i, rfl⟩) <;> simp + · rintro ⟨i, rfl⟩; cases i using Fin.cases <;> simp + +variable {m : Type u → Type v} [Monad m] {α : Type w} {β : Type u} + +/-- The get M construction in `Matrix`. -/ +def getM : {n : ℕ} → {β : Fin n → Type u} → ((i : Fin n) → m (β i)) → m ((i : Fin n) → β i) + | 0, _, _ => pure finZeroElim + | _ + 1, _, f => Fin.cases <$> f 0 <*> getM (f ·.succ) + +lemma getM_pure [LawfulMonad m] {n} {β : Fin n → Type u} (v : (i : Fin n) → β i) : + getM (fun i => (pure (v i) : m (β i))) = pure v := by + induction n with + | zero => unfold getM; congr; funext x; exact x.elim0 + | succ n ih => + simp only [getM, map_pure, ih, seq_pure] + exact congr_arg _ (funext <| Fin.cases rfl fun i ↦ rfl) + +@[simp] +lemma getM_some {n} {β : Fin n → Type u} (v : (i : Fin n) → β i) : + getM (fun i => (some (v i) : Option (β i))) = some v := + getM_pure v + +/-- The appendr construction in `Matrix`. -/ +def appendr {n m} (v : Fin n → α) (w : Fin m → α) : Fin (m + n) → α := + Matrix.vecAppend (add_comm m n) v w + +@[simp] +lemma appendr_nil {m} (w : Fin m → α) : appendr ![] w = w := by funext i; simp [appendr] + +@[simp] +lemma appendr_cons {m n} (x : α) (v : Fin n → α) (w : Fin m → α) : + appendr (x :> v) w = x :> appendr v w := by + funext i; + simp [appendr] + -- Renamed from `Matrix.forall_iff` to `Matrix.vecForall_iff` to avoid clashing with + -- Mathlib's `Matrix.forall_iff` (Mathlib.Data.Matrix.Reflection), which otherwise makes + -- Foundation unimportable alongside that module. + +lemma vecForall_iff {n : ℕ} (φ : (Fin (n + 1) → α) → Prop) : + (∀ v, φ v) ↔ (∀ a, ∀ v, φ (a :> v)) := + ⟨fun h a v ↦ h (a :> v), fun h v ↦ by simpa [eq_vecCons v] using h (v 0) (v ∘ Fin.succ)⟩ + -- Renamed from `Matrix.exists_iff` to `Matrix.vecExists_iff`; see `vecForall_iff` above. + +lemma vecExists_iff {n : ℕ} (φ : (Fin (n + 1) → α) → Prop) : + (∃ v, φ v) ↔ (∃ a, ∃ v, φ (a :> v)) := + ⟨by rintro ⟨v, hv⟩; exact ⟨v 0, v ∘ Fin.succ, by simpa [eq_vecCons] using hv⟩, by + rintro ⟨a, v, hv⟩; exact ⟨_, hv⟩⟩ + +/-- The foldr construction in `Matrix`. -/ +def foldr (f : α → β → β) (init : β) : {k : ℕ} → (Fin k → α) → β + | 0, _ => init + | _ + 1, v => + f (vecHead v) + (Matrix.foldr f init (vecTail v)) + -- Renamed from `Matrix.map` to `Matrix.vecMap` to avoid clashing with Mathlib's + -- `Matrix.map`: both auto-generate `Matrix.map.eq_1`, which makes Foundation + -- unimportable alongside Mathlib matrix/analysis theory (e.g. Bochner integration). + +/-- The vec Map construction in `Matrix`. -/ +def vecMap (f : α → β) : (Fin k → α) → (Fin k → β) := fun v ↦ f ∘ v + +section vecMap + +/-- The «term ↗» construction in `Matrix`. -/ +postfix:max "↗" => vecMap + +variable (f : α → β) + +@[simp] +lemma vecMap_nil (v : Fin 0 → α) : f↗ v = ![] := + empty_eq (f↗ v) + +lemma vecMap_cons (a : α) (v : Fin k → α) : f↗ (a :> v) = f a :> f↗ v := + by + ext i + cases i using Fin.cases <;> simp [vecMap] + +@[simp] +lemma vecMap_cons' (v : Fin (k + 1) → α) : f↗ v = f (vecHead v) :> f↗ (vecTail v) := + by + ext i + cases i using Fin.cases <;> + { simp [vecMap]; rfl + } + +@[simp] +lemma vecMap_app (v : Fin k → α) (i : Fin k) : (f↗ v) i = f (v i) := + rfl + +lemma vecMap_vecMap_comp (g : β → γ) (f : α → β) (v : Fin k → α) : g↗ (f↗ v) = (g ∘ f)↗ v := by + ext x; simp + +lemma vecMap_vecMap_comp' (g : β → γ) (f : α → β) (v : Fin k → α) : + g↗ (f↗ v) = (fun x ↦ g (f x))↗ v := by ext x; simp + +end vecMap + +section foldr + +variable (f : α → β → β) (init : β) + +@[simp] +lemma foldr_zero (v : Fin 0 → α) : foldr f init v = init := + rfl + +@[simp] +lemma foldr_succ (v : Fin (k + 1) → α) : + foldr f init v = f (vecHead v) (foldr f init (vecTail v)) := + rfl + +end foldr + +/-- The foldl construction in `Matrix`. -/ +def foldl (f : α → β → α) : (init : α) → {k : ℕ} → (Fin k → β) → α + | a, 0, _ => a + | a, _ + 1, v => Matrix.foldl f (f a (vecHead v)) (vecTail v) + +section foldl + +variable (f : α → β → α) (init : α) + +@[simp] +lemma foldl_zero (v : Fin 0 → β) : foldl f init v = init := + rfl + +@[simp] +lemma foldl_succ (v : Fin (k + 1) → β) : + foldl f init v = foldl f (f init (vecHead v)) (vecTail v) := + rfl + +end foldl + +lemma eq_iff_eq_vecHead_of_eq_vecTail {v₁ v₂ : Fin (n + 1) → α} : + Matrix.vecHead v₁ = Matrix.vecHead v₂ ∧ Matrix.vecTail v₁ = Matrix.vecTail v₂ ↔ v₁ = v₂ := + by + constructor + · rintro ⟨h, t⟩ + ext i; cases i using Fin.cases + · exact h + · exact congr_fun t _ + · rintro rfl; simp + +section vecToNat + +/-- The vec To Nat construction in `Matrix`. -/ +def vecToNat (v : Fin n → ℕ) : ℕ := + foldr (fun x ih ↦ Nat.pair x ih + 1) 0 v + +@[simp] +lemma vecToNat_empty (v : Fin 0 → ℕ) : vecToNat v = 0 := by rfl + +@[simp] +lemma encode_succ {n} (x : ℕ) (v : Fin n → ℕ) : + vecToNat (x :> v) = Nat.pair x (vecToNat v) + 1 := by simp [vecToNat] + +end vecToNat + +section + +variable {m : ℕ} + +@[simp] +lemma appeendr_addCast (u : Fin m → α) (v : Fin n → α) (i : Fin m) : + appendr u v ((Fin.addCast n i)) = u i := by simp [appendr, vecAppend_eq_ite] + +@[simp] +lemma appeendr_addNat (u : Fin m → α) (v : Fin n → α) (i : Fin n) : + appendr u v (i.addNat m) = v i := by simp [appendr, vecAppend_eq_ite] + +end + +end Matrix + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/Vorspiel/Multiset.lean b/LeanPool/PointwiseComposition/Foundation/Vorspiel/Multiset.lean new file mode 100644 index 000000000..280d6c752 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/Vorspiel/Multiset.lean @@ -0,0 +1,231 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import Mathlib.Data.Multiset.AddSub +public import Mathlib.Data.Multiset.Basic +public import Mathlib.Tactic.Abel +public import Mathlib.Algebra.Order.Group.Multiset + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace Multiset + +open _root_.Multiset + +/-- Function to avoid reducing `{a} + s` to `a ::ₘ s` -/ +def atom (a : α) : Multiset α := + { a } + +/-- `⦃x, y, z, ...⦄` notation for `kpair` -/ +syntax "⦃" term,* "⦄" : term + +macro_rules + | `(⦃$terms:term,*, $term:term⦄) => `(⦃$terms,*⦄ + atom $term) + | `(⦃$term:term⦄) => `(atom $term) + | `(⦃⦄) => `(0) + +/-- The pair Unexpander construction in `Multiset`. -/ +@[app_unexpander atom] +meta def pairUnexpander : Lean.PrettyPrinter.Unexpander + | `($_ $term) => `(⦃$term⦄) + | _ => throw () + + + +lemma atom_eq_singleton (a : α) : ⦃a⦄ = { a } := + rfl + +lemma add_atom_eq_cons (a : α) (s : Multiset α) : s + ⦃a⦄ = a ::ₘ s := by + rw [atom_eq_singleton, add_comm]; simp + +@[simp] +lemma mem_atom_iff {a b : α} : a ∈ ⦃b⦄ ↔ a = b := by simp [atom_eq_singleton] + +@[simp] +lemma atom_le_iff {a : α} {s : Multiset α} : ⦃a⦄ ≤ s ↔ a ∈ s := by simp [atom_eq_singleton] + +@[simp] +lemma atom_subset_iff {a : α} {s : Multiset α} : ⦃a⦄ ⊆ s ↔ a ∈ s := by simp [atom_eq_singleton] + +@[simp] +lemma map_atom (f : α → β) (a : α) : ⦃a⦄.map f = ⦃f a⦄ := by simp [atom_eq_singleton] + +/-- Universal membership over a sum splits into the two summands. This is a routine +property of multiset membership. -/ +lemma forall_mem_add {p : α → Prop} {s t : Multiset α} : + (∀ a ∈ s + t, p a) ↔ (∀ a ∈ s, p a) ∧ ∀ a ∈ t, p a := by + simp only [mem_add, or_imp, forall_and] + +/-- Universal membership over an atom reduces to its unique member. This is a routine +property of multiset membership. -/ +lemma forall_mem_atom {p : α → Prop} {a : α} : (∀ b ∈ ⦃a⦄, p b) ↔ p a := by + simp only [mem_atom_iff, forall_eq] + +/-- After filtering out `a`, adjoining `f a` recovers every mapped member. +This is a routine technical property of multiset membership. -/ +lemma add_map_subset_map_filter_add_atom [DecidableEq α] (s : Multiset α) (t : Multiset β) + (f : α → β) (a : α) : t + s.map f ⊆ (s.filter (· ≠ a)).map f + ⦃f a⦄ + t := + by + intro b hb + rcases mem_add.mp hb with hb | hb + · exact mem_add.mpr (Or.inr hb) + · obtain ⟨c, hc, rfl⟩ := mem_map.mp hb + by_cases h : c = a + · subst c + exact mem_add.mpr <| Or.inl <| mem_add.mpr <| Or.inr <| by simp + · exact + mem_add.mpr <| + Or.inl <| mem_add.mpr <| Or.inl <| mem_map.mpr ⟨c, mem_filter.mpr ⟨hc, h⟩, rfl⟩ + +lemma map_subset_iff {s₁ s₂ : Multiset α} (f : α → β) (hf : Function.Injective f) : + map f s₁ ⊆ map f s₂ ↔ s₁ ⊆ s₂ := by + constructor + · intro h a ha + have : f a ∈ map f s₁ := by simp; grind + have : ∃ a' ∈ s₂, f a' = f a := by simpa using h this + obtain ⟨a', ha', heq⟩ := this + rcases hf heq + assumption + · exact map_subset_map + +/-- Data and laws for Traversal in `Multiset`. -/ +inductive Traversal {α : Type*} : Multiset α → Type _ where + | zero : Traversal 0 + | succ (a : α) : Traversal s → Traversal (s + ⦃a⦄) + +namespace Traversal + +/-- The cast construction in `Multiset.Traversal`. -/ +def cast {s t : Multiset α} (h : s = t) : Traversal s → Traversal t := fun t ↦ h ▸ t + +/-- The atom construction in `Multiset.Traversal`. -/ +def atom (a : α) : Traversal ⦃a⦄ := + zero.succ a + +/-- The add construction in `Multiset.Traversal`. -/ +def add (t₁ : Traversal s₁) (t₂ : Traversal s₂) : Traversal (s₁ + s₂) := + match t₂ with + | zero => t₁.cast (by simp) + | succ a t => (add t₁ t).succ a |>.cast (by abel) + +/-- The to List construction in `Multiset.Traversal`. -/ +def toList {s : Multiset α} : Traversal s → List α + | zero => [] + | succ a t => a :: t.toList + +lemma toList_cast {s t : Multiset α} (h : s = t) (u : Traversal s) : + (u.cast h).toList = u.toList := by + cases h + rfl + +@[simp] +lemma coe_toList {s : Multiset α} (t : Traversal s) : (t.toList : Multiset α) = s := + match t with + | zero => rfl + | succ a t => by simp [toList, coe_toList t, add_atom_eq_cons, ← Multiset.cons_coe] + +/-- The of List construction in `Multiset.Traversal`. -/ +def ofList : (l : List α) → Traversal (l : Multiset α) + | [] => zero + | a :: t => (ofList t).succ a |>.cast (by simp [add_atom_eq_cons, ← Multiset.cons_coe]) + +lemma toList_ofList (l : List α) : (ofList l).toList = l := by + induction l with + | nil => rfl + | cons a l ih => + change (cast _ (succ a (ofList l))).toList = _ + rw [toList_cast] + exact congrArg (List.cons a) ih + +private lemma cast_cast {s t u : Multiset α} (d : Traversal s) (h : s = t) (h' : t = u) : + (d.cast h).cast h' = d.cast (h.trans h') := by cases h; cases h'; rfl; + +private lemma cast_succ {s t : Multiset α} (d : Traversal s) (a : α) (h : s = t) : + (d.succ a).cast (congrArg (· + ⦃a⦄) h) = (d.cast h).succ a := by + cases h; rfl; + -- Unfold traversal indices when transporting the list reconstruction. + +lemma ofList_toList {s : Multiset α} (t : Traversal s) : (ofList t.toList).cast (by simp) = t := + by + induction t with + | zero => rfl + | succ a t ih => + simp only [toList, ofList] + exact + (cast_cast (succ a (ofList t.toList)) _ _).trans + ((cast_succ (ofList t.toList) a t.coe_toList).trans (congrArg (succ a) ih)) + +/-- The equiv construction in `Multiset.Traversal`. -/ +def equiv {s : Multiset α} : Traversal s ≃ { l : List α // (l : Multiset α) = s } + where + toFun t := ⟨t.toList, by simp⟩ + invFun l := ofList l.1 |>.cast (by simp [l.2]) + left_inv t := ofList_toList t + right_inv + s := by + apply Subtype.ext + simp [toList_cast, toList_ofList] + +/-- Construct a traversal after applying a function to every element. -/ +def map (f : α → β) {s : Multiset α} (t : Traversal s) : Traversal (s.map f) := + (ofList (t.toList.map f)).cast + (by simpa only [Multiset.map_coe] using congrArg (Multiset.map f) t.coe_toList) + +/-- Construct a traversal of the elements satisfying a decidable predicate. -/ +def filter (p : α → Prop) [DecidablePred p] {s : Multiset α} (t : Traversal s) : + Traversal (s.filter p) := + (ofList (t.toList.filter p)).cast + (by simpa only [Multiset.filter_coe] using congrArg (Multiset.filter p) t.coe_toList) + +/-- Construct a traversal after removing one occurrence of an element. -/ +def erase [DecidableEq α] (a : α) {s : Multiset α} (t : Traversal s) : Traversal (s.erase a) := + (ofList (t.toList.erase a)).cast + (by simpa only [Multiset.coe_erase] using congrArg (fun u ↦ u.erase a) t.coe_toList) + +/-- Remove the distinguished occurrence from a traversal of an adjoined atom. -/ +def remove [DecidableEq α] {a : α} {s : Multiset α} (t : Traversal (s + ⦃a⦄)) : Traversal s := + (erase a t).cast + (by + rw [atom_eq_singleton, erase_add_right_pos s (mem_singleton_self a)] + rw [erase_singleton, add_zero]) + +/-- Constructively extract a preimage from a mapped traversal. -/ +def getPreimage [DecidableEq β] {f : α → β} {s : Multiset α} (t : Traversal s) {b : β} + (h : b ∈ s.map f) : { a : α // a ∈ s ∧ f a = b } := + by + have hex : ∃ a ∈ t.toList, f a = b := + by + have h' : b ∈ Multiset.map f (t.toList : Multiset α) := + by + rw [t.coe_toList] + exact h + obtain ⟨a, ha, hab⟩ := mem_map.mp h' + exact ⟨a, ha, hab⟩ + let w : { a : α // a ∈ t.toList ∧ f a = b } := List.chooseX (fun a ↦ f a = b) t.toList hex + have hs : w.1 ∈ s := by + have hc := t.coe_toList + exact Eq.mp (congrArg (fun m : Multiset α => w.1 ∈ m) hc) w.2.1 + exact ⟨w.1, hs, w.2.2⟩ + +noncomputable instance inhabited {s : Multiset α} : Inhabited (Traversal s) := + ⟨ofList (s.toList) |>.cast (by simp)⟩ + +end Traversal + +end Multiset + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/Vorspiel/Nat/Basic.lean b/LeanPool/PointwiseComposition/Foundation/Vorspiel/Nat/Basic.lean new file mode 100644 index 000000000..380c7717a --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/Vorspiel/Nat/Basic.lean @@ -0,0 +1,96 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import Mathlib.Data.Nat.Bits +public import Mathlib.Order.Lattice.Nat +public import Mathlib.Data.Nat.Pairing +public import Mathlib.Tactic.Cases + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace Nat + +open _root_.Nat + +variable {α : ℕ → Sort u} + +/-- The cases construction in `Nat`. -/ +def cases (hzero : α 0) (hsucc : ∀ n, α (n + 1)) : ∀ n, α n + | 0 => hzero + | n + 1 => hsucc n + +/-- The «term :>ₙ » construction in `Nat`. -/ +infixr:70 " :>ₙ " => cases + +@[simp] +lemma cases_zero (hzero : α 0) (hsucc : ∀ n, α (n + 1)) : (hzero :>ₙ hsucc) 0 = hzero := + rfl + +@[simp] +lemma cases_succ (hzero : α 0) (hsucc : ∀ n, α (n + 1)) (n : ℕ) : + (hzero :>ₙ hsucc) (n + 1) = hsucc n := + rfl + +@[simp] +lemma ne_step_max (n m : ℕ) : n ≠ max n m + 1 := + _root_.ne_of_lt <| Nat.lt_succ_of_le <| by simp + +@[simp] +lemma ne_step_max' (n m : ℕ) : n ≠ max m n + 1 := + _root_.ne_of_lt <| Nat.lt_succ_of_le <| by simp + +lemma rec_eq {α : Sort*} (a : α) (f₁ f₂ : ℕ → α → α) (n : ℕ) + (H : ∀ m < n, ∀ a, f₁ m a = f₂ m a) : (n.rec a f₁ : α) = n.rec a f₂ := by + induction n with + | zero => rfl + | succ n + ih => + have hrec : (n.rec a f₁ : α) = n.rec a f₂ := ih (fun m hm a => H m (Nat.lt_succ_of_lt hm) a) + change f₁ n (n.rec a f₁) = f₂ n (n.rec a f₂) + rw [hrec] + exact H n (Nat.lt_succ_self n) _ + +lemma least_number (P : ℕ → Prop) (hP : ∃ x, P x) : ∃ x, P x ∧ ∀ z < x, ¬P z := + by + rcases hP with ⟨n, hn⟩ + induction n using Nat.strongRec + rename_i n ih + by_cases H : ∃ m < n, P m + · rcases H with ⟨m, hm, hPm⟩ + exact ih m hm hPm + · exact ⟨n, hn, by simpa using H⟩ + +/-- The to Fin construction in `Nat`. -/ +def toFin (n : ℕ) : ℕ → Option (Fin n) := fun x => if hx : x < n then some ⟨x, hx⟩ else none + +@[grind =>] +lemma zero_lt_of_not_zero {n : ℕ} (hn : n ≠ 0) : 0 < n := by omega; + +lemma one_le_of_bodd {n : ℕ} (h : n.bodd = true) : 1 ≤ n := by induction n <;> simp at h ⊢ + +lemma pair_le_pair_of_le {a₁ a₂ b₁ b₂ : ℕ} (ha : a₁ ≤ a₂) (hb : b₁ ≤ b₂) : + a₁.pair b₁ ≤ a₂.pair b₂ := + by + rcases lt_or_eq_of_le ha with (ha | rfl) <;> rcases lt_or_eq_of_le hb with (hb | rfl) + · exact le_of_lt (lt_trans (Nat.pair_lt_pair_left b₁ ha) (Nat.pair_lt_pair_right a₂ hb)) + · exact le_of_lt (Nat.pair_lt_pair_left b₁ ha) + · exact le_of_lt (Nat.pair_lt_pair_right a₁ hb) + · rfl + +end Nat + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/Vorspiel/Nat/Matrix.lean b/LeanPool/PointwiseComposition/Foundation/Vorspiel/Nat/Matrix.lean new file mode 100644 index 000000000..eaa866589 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/Vorspiel/Nat/Matrix.lean @@ -0,0 +1,113 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import Mathlib.Data.List.OfFn +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Matrix + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace Nat + +open _root_.Nat + +open _root_.Matrix Matrix + +/-- The nat To Vec construction in `Nat`. -/ +def natToVec : ℕ → (n : ℕ) → Option (Fin n → ℕ) + | 0, 0 => some Matrix.vecEmpty + | e + 1, n + 1 => Nat.natToVec e.unpair.2 n |>.map (e.unpair.1 :> ·) + | _, _ => none + +variable {n : ℕ} + +@[simp] +lemma natToVec_vecToNat (v : Fin n → ℕ) : + (PointwiseComposition.Nat.natToVec (vecToNat v)) n = some v := + by + induction n + · simp [*, Nat.natToVec, vecToNat, Matrix.empty_eq] + case succ _ + ih => + suffices v 0 :> v ∘ Fin.succ = v + by + simp only [vecToNat, foldr_succ, natToVec, unpair_pair, Option.map_eq_some_iff] + use vecTail v + simpa using! ih (vecTail v) + exact funext (fun i ↦ i.cases (by simp) (by simp)) + +lemma lt_of_eq_natToVec {e : ℕ} {v : Fin n → ℕ} + (h : (PointwiseComposition.Nat.natToVec e) n = some v) (i : Fin n) : v i < e := by + induction n generalizing e with + | zero => exact i.elim0 + | succ n ih => + rcases e with _ | e + · simp [natToVec] at h + · simp only [natToVec, Option.map_eq_some_iff] at h + rcases h with ⟨v, hnv, rfl⟩ + refine Fin.cases ?_ (fun i => ?_) i + · simp [Nat.lt_succ_iff, unpair_left_le] + · simp only [cons_val_succ] + exact lt_trans (ih hnv i) (Nat.lt_succ_iff.mpr <| unpair_right_le e) + +/-- List form of `Nat.natToVec`: the same decoding, with the length out of the type. -/ +def natToList : ℕ → List ℕ + | 0 => [] + | e + 1 => e.unpair.1 :: natToList e.unpair.2 +decreasing_by exact Nat.lt_succ_of_le (Nat.unpair_right_le e) + +lemma natToVec_eq_some_iff {e k : ℕ} {v : Fin k → ℕ} : + (PointwiseComposition.Nat.natToVec e) k = some v ↔ natToList e = List.ofFn v := by + induction k generalizing e with + | zero => + cases e with + | zero => simp [natToVec, natToList, Matrix.empty_eq] + | succ e => simp [natToVec, natToList] + | succ k ih => + cases e with + | zero => simp [natToVec, natToList] + | succ e => + rw [natToVec, natToList, List.ofFn_succ] + constructor + · rintro h + rw [Option.map_eq_some_iff] at h + obtain ⟨w, hw, rfl⟩ := h + rw [ih.mp hw] + simp + · rintro h + rw [List.cons.injEq] at h + obtain ⟨h0, hl⟩ := h + refine Option.map_eq_some_iff.mpr ⟨fun i ↦ v i.succ, ih.mpr hl, ?_⟩ + exact funext fun i ↦ i.cases (by simp [h0]) (by simp) + +/-- `natToVec` succeeds exactly when the length-free decoding has the expected length. -/ +lemma natToVec_eq_none_of_length {e k : ℕ} (h : (natToList e).length ≠ k) : + (PointwiseComposition.Nat.natToVec e) k = none := + by + rcases hv : (PointwiseComposition.Nat.natToVec e) k with _ | v + · rfl + · exact absurd (by rw [natToVec_eq_some_iff.mp hv]; simp) h + +lemma natToVec_isSome_of_length {e k : ℕ} (h : (natToList e).length = k) : + ∃ v : Fin k → ℕ, (PointwiseComposition.Nat.natToVec e) k = some v := + by + subst h + refine ⟨fun i ↦ (natToList e).get i, natToVec_eq_some_iff.mpr ?_⟩ + exact (List.ofFn_get _).symm + +end Nat + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/Vorspiel/NotationClass.lean b/LeanPool/PointwiseComposition/Foundation/Vorspiel/NotationClass.lean new file mode 100644 index 000000000..ba5dcdd86 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/Vorspiel/NotationClass.lean @@ -0,0 +1,203 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import Mathlib.Tactic.TypeStar +public import Mathlib.Data.Nat.Basic + +/-! Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +/-! +# Supplemental notation classes +-/ + +@[expose] public section + +namespace FFL + +/-! ## Heterogeneous notation classes -/ + +/-- Data and laws for HTilde in `FFL`. -/ +class HTilde (α : Type*) (β : outParam Type*) where + /-- The h Tilde construction in `FFL.HTilde`. -/ + hTilde : α → β + +/-- The «term∼ » construction in `FFL`. -/ +prefix:75 "∼" => HTilde.hTilde +macro_rules + | `(∼$x) => `(unop% HTilde.hTilde $x) + +/-- Data and laws for HArrow in `FFL`. -/ +class HArrow (α β : Type*) (γ : outParam Type*) where + /-- The h Arrow construction in `FFL.HArrow`. -/ + hArrow : α → β → γ + +/-- The «term ⇒ₗ » construction in `FFL`. -/ +infixr:60 " ⇒ₗ " => HArrow.hArrow +macro_rules | `($x ⇒ₗ $y) => `(binop% HArrow.hArrow $x $y) + + + +/-- Data and laws for HWedge in `FFL`. -/ +class HWedge (α β : Type*) (γ : outParam Type*) where + /-- The h Wedge construction in `FFL.HWedge`. -/ + hWedge : α → β → γ + +/-- The «term ⋏ » construction in `FFL`. -/ +infixr:69 " ⋏ " => HWedge.hWedge +macro_rules | `($x ⋏ $y) => `(binop% HWedge.hWedge $x $y) + + + +/-- Data and laws for HVee in `FFL`. -/ +class HVee (α β : Type*) (γ : outParam Type*) where + /-- The h Vee construction in `FFL.HVee`. -/ + hVee : α → β → γ + +/-- The «term ⋎ » construction in `FFL`. -/ +infixr:68 " ⋎ " => HVee.hVee +macro_rules | `($x ⋎ $y) => `(binop% HVee.hVee $x $y) + + + +attribute [match_pattern] HTilde.hTilde HArrow.hArrow HWedge.hWedge HVee.hVee + +/-! ## Homogeneous notation classes -/ + +/-- Data and laws for Tilde in `FFL`. -/ +class Tilde (α : Type*) where + /-- The tilde construction in `FFL.Tilde`. -/ + tilde : α → α + +/-- Data and laws for Arrow in `FFL`. -/ +class Arrow (α : Type*) where + /-- The arrow construction in `FFL.Arrow`. -/ + arrow : α → α → α + +/-- Data and laws for Wedge in `FFL`. -/ +class Wedge (α : Type*) where + /-- The wedge construction in `FFL.Wedge`. -/ + wedge : α → α → α + +/-- Data and laws for Vee in `FFL`. -/ +class Vee (α : Type*) where + /-- The vee construction in `FFL.Vee`. -/ + vee : α → α → α + +attribute [match_pattern] Tilde.tilde Arrow.arrow Wedge.wedge Vee.vee + +@[default_instance] +instance Tilde.instHTilde [Tilde α] : HTilde α α := + ⟨Tilde.tilde⟩ + +@[default_instance] +instance Arrow.instHArrow [Arrow α] : HArrow α α α := + ⟨Arrow.arrow⟩ + +@[default_instance] +instance Wedge.instHWedge [Wedge α] : HWedge α α α := + ⟨Wedge.wedge⟩ + +@[default_instance] +instance Vee.instHVee [Vee α] : HVee α α α := + ⟨Vee.vee⟩ + +/-- Data and laws for Box in `FFL`. -/ +class Box (α : Type*) where + /-- The box construction in `FFL.Box`. -/ + box : α → α + +/-- The «term□ » construction in `FFL`. -/ +prefix:76 "□" => Box.box + +/-- Data and laws for Dia in `FFL`. -/ +class Dia (α : Type*) where + /-- The dia construction in `FFL.Dia`. -/ + dia : α → α + +/-- The «term◇ » construction in `FFL`. -/ +prefix:76 "◇" => Dia.dia + +/-- Data and laws for Rhd in `FFL`. -/ +class Rhd (α : Type*) where + /-- The rhd construction in `FFL.Rhd`. -/ + rhd : α → α → α + +/-- The «term ▷ » construction in `FFL`. -/ +infixl:70 " ▷ " => Rhd.rhd + +attribute [match_pattern] Box.box Dia.dia Rhd.rhd + +/-- Data and laws for Exp in `FFL`. -/ +class Exp (α : Type*) where + /-- The exp construction in `FFL.Exp`. -/ + exp : α → α + +/-- Data and laws for Superexp in `FFL`. -/ +class Superexp (α : Type*) where + /-- The superexp construction in `FFL.Superexp`. -/ + superexp : α → α + +/-- Data and laws for Smash in `FFL`. -/ +class Smash (α : Type*) where + /-- The smash construction in `FFL.Smash`. -/ + smash : α → α → α + +/-- The «term ⊛ » construction in `FFL`. -/ +infix:80 " ⊛ " => Smash.smash + +/-- Data and laws for Length in `FFL`. -/ +class Length (α : Type*) where + /-- The length construction in `FFL.Length`. -/ + length : α → α + +/-- The «term‖ ‖» construction in `FFL`. -/ +notation "‖" x "‖" => Length.length x + +/-- Coding objects into syntactic objects (e.g. natural numbers, first-order terms) -/ +class GödelQuote (α β : Sort*) where + /-- The quote construction in `FFL.GödelQuote`. -/ + quote : α → β + +/-- The «term⌜ ⌝» construction in `FFL`. -/ +notation:max "⌜" x "⌝" => GödelQuote.quote x + +/-- Data and laws for Sigma Symbol in `FFL`. -/ +class SigmaSymbol (α : Type*) where + /-- The sigma construction in `FFL.SigmaSymbol`. -/ + sigma : α + +/-- Data and laws for Pi Symbol in `FFL`. -/ +class PiSymbol (α : Type*) where + /-- The pi construction in `FFL.PiSymbol`. -/ + pi : α + +/-- Data and laws for Delta Symbol in `FFL`. -/ +class DeltaSymbol (α : Type*) where + /-- The delta construction in `FFL.DeltaSymbol`. -/ + delta : α + +/-- The «termΣ» construction in `FFL`. -/ +notation "Σ" => SigmaSymbol.sigma + +/-- The «termΠ» construction in `FFL`. -/ +notation "Π" => PiSymbol.pi + +/-- The «term∆» construction in `FFL`. -/ +notation "∆" => DeltaSymbol.delta + +attribute [match_pattern] SigmaSymbol.sigma PiSymbol.pi DeltaSymbol.delta + +end FFL + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/Vorspiel/Option.lean b/LeanPool/PointwiseComposition/Foundation/Vorspiel/Option.lean new file mode 100644 index 000000000..69bf1d1ed --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/Vorspiel/Option.lean @@ -0,0 +1,68 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import Mathlib.Data.Option.Basic + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace Option + +open _root_.Option + +variable {α : Type u} + +/-- The lifted subset relation on optional values. -/ +inductive IsSubsetOf : Option α → Option α → Prop + | none : IsSubsetOf none o + | some (a : α) : IsSubsetOf (some a) (some a) + +instance instHasSubsetOptionModel : HasSubset (Option α) := + ⟨IsSubsetOf⟩ + +@[simp] +lemma none_subset (o : Option α) : none ⊆ o := + IsSubsetOf.none + +@[simp] +lemma some_subset_some_self (a : α) : some a ⊆ some a := + IsSubsetOf.some a + +@[simp] +lemma subset_none_iff (o : Option α) : o ⊆ none ↔ o = none := + by + cases o + · simp + · simp only [reduceCtorEq, iff_false]; rintro ⟨⟩ + +@[simp] +lemma some_subset_some {a b : α} : some a ⊆ some b ↔ a = b := + by + constructor + · rintro ⟨⟩; rfl + · rintro rfl; exact IsSubsetOf.some a + +lemma subset_iff (o₁ o₂ : Option α) : o₁ ⊆ o₂ ↔ ∀ a, a ∈ o₁ → a ∈ o₂ := + by + cases o₁ + · simp + · cases o₂ + · simp + · simp; grind + +end Option + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/Vorspiel/Order/Dense.lean b/LeanPool/PointwiseComposition/Foundation/Vorspiel/Order/Dense.lean new file mode 100644 index 000000000..6ce5ad35e --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/Vorspiel/Order/Dense.lean @@ -0,0 +1,229 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import Mathlib.Order.PFilter +public import Mathlib.Data.Set.Countable + +/-! Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace Nat + +open _root_.Nat +lemma monotone_of_succ_monotone {r : ℕ → ℕ → Prop} (rfx : Std.Refl r) (tr : IsTrans ℕ r) + (succ : ∀ n, r n (n + 1)) : n ≤ m → r n m := + by + revert n m + suffices ∀ n d, r n (n + d) by + intro n m hnm + have := this n (m - n) + grind + intro n d + induction d + case zero => simp [rfx.refl n] + case succ d ih => simpa using! tr.trans _ _ _ ih (succ (n + d)) + +end Nat + +namespace DirectedOn + +variable {α : Type*} {r : α → α → Prop} + +private lemma vector_le (tr : IsTrans α r) {s : Set α} (hs : s.Nonempty) (h : DirectedOn r s) + (v : Fin n → α) (hv : ∀ i, v i ∈ s) : ∃ z ∈ s, ∀ i, r (v i) z := + match n with + | 0 => by rcases hs with ⟨x, hx⟩; exact ⟨x, hx, fun i ↦ IsEmpty.elim inferInstance i⟩ + | n + 1 => + by + have : ∃ z ∈ s, ∀ i : Fin n, r (v i.succ) z := + vector_le tr hs h (n := n) (fun i ↦ v i.succ) fun i ↦ hv i.succ + rcases this with ⟨x, hx, hr⟩ + have : ∃ z ∈ s, r x z ∧ r (v 0) z := h x hx (v 0) (hv 0) + rcases this with ⟨z, hz, hrxz, hrz⟩ + refine ⟨z, hz, ?_⟩ + intro i + cases i using Fin.cases + case zero => assumption + case succ i => exact tr.trans _ _ _ (hr i) hrxz + +lemma fintype_colimit {ι : Type*} [Finite ι] (tr : IsTrans α r) {s : Set α} (hs : s.Nonempty) + (h : DirectedOn r s) (v : ι → α) (hv : ∀ i, v i ∈ s) : ∃ z ∈ s, ∀ i, r (v i) z := by + classical + let : Fintype ι := Fintype.ofFinite ι + let f : Fin (Fintype.card ι) → α := fun x ↦ v ((Fintype.equivFin ι).symm x) + rcases DirectedOn.vector_le tr hs h f (by intro; simp [f, hv]) with ⟨z, hzs, hz⟩ + exact ⟨z, hzs, fun i ↦ by simpa [f] using hz ((Fintype.equivFin ι) i)⟩ + +end DirectedOn + +namespace Order + +open _root_.Order +variable {α : Type*} [Preorder α] + +/-! ### Compatibility and incompatibility -/ + +/-- The Is Compatible Pair construction in `Order`. -/ +def IsCompatiblePair (a b : α) : Prop := + ∃ c, c ≤ a ∧ c ≤ b + +/-- The «term ‖ » construction in `Order`. -/ +scoped infix:50 " ‖ " => IsCompatiblePair + +@[simp, refl] +protected lemma IsCompatiblePair.refl (a : α) : a ‖ a := + ⟨a, by simp⟩ + +@[symm] +protected lemma IsCompatiblePair.symm_iff {a b : α} : a ‖ b ↔ b ‖ a := + by + constructor + · rintro ⟨c, hca, hcb⟩; exact ⟨c, hcb, hca⟩ + · rintro ⟨c, hcb, hca⟩; exact ⟨c, hca, hcb⟩ + +alias ⟨IsCompatiblePair.symm, _⟩ := IsCompatiblePair.symm_iff + +@[grind <-] +lemma IsCompatiblePair.of_le {a b : α} (h : a ≤ b) : a ‖ b := + ⟨a, by simp [h]⟩ + +/-- The Is Incompatible Pair construction in `Order`. -/ +def IsIncompatiblePair (a b : α) : Prop := + ¬(a ‖ b) + +/-- The «term ⟂ » construction in `Order`. -/ +scoped infix:50 " ⟂ " => IsIncompatiblePair + +lemma isIncompatiblePair_iff {a b : α} : a ⟂ b ↔ ∀ c ≤ a, ¬c ≤ b := by + simp [IsIncompatiblePair, IsCompatiblePair] + +@[simp] +lemma IsIncompatiblePair.antirefl (a : α) : ¬(a ⟂ a) := by simp [IsIncompatiblePair] + +lemma IsIncompatiblePair.symm_iff {a b : α} : a ⟂ b ↔ b ⟂ a := by + contrapose; simpa [IsIncompatiblePair] using IsCompatiblePair.symm_iff + +alias ⟨IsIncompatiblePair.symm, _⟩ := IsIncompatiblePair.symm_iff + +lemma IsIncompatiblePair.lower {a a' b b' : α} (h : a ⟂ b) (ha'a : a' ≤ a) (hb'b : b' ≤ b) : + a' ⟂ b' := by + rintro ⟨c, hca, hcb⟩ + exact h ⟨c, le_trans hca ha'a, le_trans hcb hb'b⟩ + +@[simp, grind =] +lemma not_isCompatiblePair_iff_isIncompatiblePair {a b : α} : ¬(a ‖ b) ↔ a ⟂ b := by rfl + +@[simp, grind =] +lemma not_isIncompatiblePair_iff_isCompatiblePair {a b : α} : ¬(a ⟂ b) ↔ a ‖ b := by + simp [IsIncompatiblePair, IsCompatiblePair] + +/-! ### Density -/ + +/-- The Is Dense construction in `Order`. -/ +def IsDense (s : Set α) : Prop := + ∀ p, ∃ q ≤ p, q ∈ s + +/-- The Is Dense Below construction in `Order`. -/ +def IsDenseBelow (s : Set α) (a : α) : Prop := + ∀ p ≤ a, ∃ q ≤ p, q ∈ s + +variable (α) + +/-- Data and laws for Dense Set in `Order`. -/ +@[ext] +structure DenseSet where + /-- The set construction in `Order.DenseSet`. -/ + set : Set α + is_dense : IsDense set + +variable {α} + +namespace DenseSet + +instance : SetLike (DenseSet α) α where + coe s := s.set + coe_injective s t e := by ext; simp_all + +/-- The choose construction in `Order.DenseSet`. -/ +noncomputable def choose (d : DenseSet α) (a : α) : α := + (d.is_dense a).choose + +@[simp] +lemma choose_le (d : DenseSet α) (a : α) : d.choose a ≤ a := + (d.is_dense a).choose_spec.1 + +@[simp] +lemma choose_mem (d : DenseSet α) (a : α) : d.choose a ∈ d := + (d.is_dense a).choose_spec.2 + +end DenseSet + +namespace PFilter + +open _root_.Order.PFilter + +/-- The of Descending Chain construction in `Order.PFilter`. -/ +def ofDescendingChain (s : ℕ → α) (hs : ∀ i j, i ≤ j → s i ≥ s j) : PFilter α := + IsPFilter.toPFilter <| + Order.IsPFilter.of_def (F := {x | ∃ i, s i ≤ x}) ⟨s 0, 0, by rfl⟩ + (by + rintro x₁ ⟨i₁, h₁⟩ x₂ ⟨i₂, h₂⟩ + wlog hi : i₁ ≤ i₂ + · have z : i₂ ≤ i₁ := by exact Nat.le_of_not_ge hi + rcases this s hs x₂ i₂ h₂ x₁ i₁ h₁ (Nat.le_of_not_ge hi) with ⟨z, hz⟩ + exact ⟨z, hz.1, hz.2.2, hz.2.1⟩ + exact ⟨s i₂, ⟨i₂, by rfl⟩, le_trans (hs i₁ i₂ hi) h₁, by simp [h₂]⟩) + (by + rintro x y hxy ⟨i, hix⟩ + exact ⟨i, le_trans hix hxy⟩) + +@[simp] +lemma mem_descendingChain_iff (s : ℕ → α) (hs : ∀ i j, i ≤ j → s i ≥ s j) : + x ∈ ofDescendingChain s hs ↔ ∃ i, s i ≤ x := by rfl + +/-- Data and laws for Is Generic in `Order.PFilter`. -/ +class IsGeneric (F : PFilter α) (𝓓 : Set (DenseSet α)) where + isGeneric : ∀ d ∈ 𝓓, ∃ a ∈ F, a ∈ d + +@[simp] +instance IsGeneric.empty (F : PFilter α) : IsGeneric F ∅ := + ⟨by simp⟩ + +theorem exists_genericFilter_of_countable (𝓓 : Set (DenseSet α)) (ctb : Set.Countable 𝓓) + (a : α) : ∃ G : PFilter α, IsGeneric G 𝓓 ∧ a ∈ G := + by + by_cases emp : 𝓓.Nonempty + case neg => exact ⟨principal a, by simp [Set.not_nonempty_iff_eq_empty.mp emp], by simp⟩ + have : ∃ D : ℕ → 𝓓, Function.Surjective D := ctb.exists_surjective emp + rcases this with ⟨D, hD⟩ + let s (n : ℕ) : α := n.rec a fun i ↦ (D i).val.choose + have hs : ∀ i j, i ≤ j → s i ≥ s j := fun i j hij ↦ + Nat.monotone_of_succ_monotone (r := fun i j ↦ s i ≥ s j) ⟨fun _ ↦ le_refl _⟩ + ⟨fun _ _ _ ↦ ge_trans⟩ (by simp [s]) hij + refine ⟨ofDescendingChain s hs, ⟨?_⟩, ?_⟩ + · intro d hd + rcases show ∃ i, D i = ⟨d, hd⟩ from hD ⟨d, hd⟩ with ⟨i, hi⟩ + refine ⟨s (i + 1), ?_, ?_⟩ + · simp only [mem_descendingChain_iff] + exact ⟨i + 1, by rfl⟩ + · simp [s, hi] + · suffices ∃ i, s i ≤ a by simpa + refine ⟨0, by simp [s]⟩ + +end PFilter + +end Order + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/Vorspiel/Part.lean b/LeanPool/PointwiseComposition/Foundation/Vorspiel/Part.lean new file mode 100644 index 000000000..9b2fcdb04 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/Vorspiel/Part.lean @@ -0,0 +1,49 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import Mathlib.Data.Vector.Basic +public import Mathlib.Data.PFun + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace Part + +open _root_.Part + +@[simp] +lemma mem_vector_mOfFn {n : ℕ} {w : List.Vector α n} {v : Fin n → Part α} : + w ∈ List.Vector.mOfFn v ↔ ∀ i, w.get i ∈ v i := by + induction n with + | zero => simp [List.Vector.mOfFn, List.Vector.eq_nil] + | succ n + ih => + suffices + (∃ a ∈ v 0, ∃ u, (∀ i : Fin n, u.get i ∈ v i.succ) ∧ w = a ::ᵥ u) ↔ + ∀ i : Fin (n + 1), w.get i ∈ v i + by simpa [List.Vector.mOfFn, ih] + constructor + · rintro ⟨a, ha, u, hu, rfl⟩ i + cases i using Fin.cases <;> simp [ha, hu] + · intro h + exact ⟨w.head, by simpa using h 0, w.tail, fun i => by simpa using h i.succ, by simp⟩ + +lemma unit_dom_iff (x : Part Unit) : x.Dom ↔ () ∈ x := by + simp [dom_iff_mem, show ∀ x : Unit, x = () by intro x; rfl] + +end Part + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/Vorspiel/Quotient.lean b/LeanPool/PointwiseComposition/Foundation/Vorspiel/Quotient.lean new file mode 100644 index 000000000..279853c17 --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/Vorspiel/Quotient.lean @@ -0,0 +1,77 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +-- Ported and adapted for Lean Pool from the upstream revision recorded in the project card. + +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Fin.Matrix + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace Quotient + +open _root_.Matrix Matrix + +variable {α : Type u} [s : Setoid α] {β : Sort v} + +@[elab_as_elim] +lemma inductionOnVec {φ : (Fin n → Quotient s) → Prop} (v : Fin n → Quotient s) + (h : ∀ v : Fin n → α, φ (fun i => Quotient.mk s (v i))) : φ v := + Quotient.induction_on_pi v h + +/-- The lift Vec construction in `Quotient`. -/ +def liftVec : + ∀ {n} (f : (Fin n → α) → β), + (∀ v₁ v₂ : Fin n → α, (∀ n, v₁ n ≈ v₂ n) → f v₁ = f v₂) → (Fin n → Quotient s) → β + | 0, f, _, _ => f ![] + | n + 1, f, h, v => + let ih : α → (Fin n → Quotient s) → β := fun a v => + liftVec (n := n) (fun v => f (a :> v)) + (fun v₁ v₂ hv => + h (a :> v₁) (a :> v₂) (Fin.cases (by simp [cons_val_zero, Setoid.refl]) hv)) + v + Quot.liftOn (vecHead v) (ih · (vecTail v)) + (fun a b hab => + by + have : ∀ v, f (a :> v) = f (b :> v) := fun v ↦ + h _ _ (Fin.cases hab (by simp [cons_val_succ, Setoid.refl])) + simp [this, ih]) + +@[simp] +lemma liftVec_zero (f : (Fin 0 → α) → β) (h) (v : Fin 0 → Quotient s) : liftVec f h v = f ![] := + rfl + +lemma liftVec_mk {n} (f : (Fin n → α) → β) (h) (v : Fin n → α) : + liftVec f h (Quotient.mk s ∘ v) = f v := by + induction n with + | zero => simp [liftVec, empty_eq] + | succ n ih => + simp [liftVec] + simpa using! + ih (fun v' => f (vecHead v :> v')) + (fun v₁ v₂ hv => h (vecHead v :> v₁) (vecHead v :> v₂) (Fin.cases (refl _) hv)) + (vecTail v) + +@[simp] +lemma liftVec_mk₁ (f : (Fin 1 → α) → β) (h) (a : α) : liftVec f h ![Quotient.mk s a] = f ![a] := + liftVec_mk f h ![a] + +@[simp] +lemma liftVec_mk₂ (f : (Fin 2 → α) → β) (h) (a₁ a₂ : α) : + liftVec f h ![Quotient.mk s a₁, Quotient.mk s a₂] = f ![a₁, a₂] := + liftVec_mk f h ![a₁, a₂] + +end Quotient + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Foundation/Vorspiel/String.lean b/LeanPool/PointwiseComposition/Foundation/Vorspiel/String.lean new file mode 100644 index 000000000..ad346e0bc --- /dev/null +++ b/LeanPool/PointwiseComposition/Foundation/Vorspiel/String.lean @@ -0,0 +1,27 @@ +/- +Copyright (c) 2026 Formalized Formal Logic contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Formalized Formal Logic contributors +-/ + +module + +/-! +Supporting results for pointwise provable equality. -/ + +namespace PointwiseComposition + +@[expose] public section + +namespace String + +/-- The vec To Str construction in `String`. -/ +def vecToStr : ∀ {n}, (Fin n → String) → String + | 0, _ => "" + | n + 1, s => if n = 0 then s 0 else s 0 ++ ", " ++ @vecToStr n (fun i => s (Fin.succ i)) + +end String + +end + +end PointwiseComposition diff --git a/LeanPool/PointwiseComposition/Imports.lean b/LeanPool/PointwiseComposition/Imports.lean new file mode 100644 index 000000000..4885e614b --- /dev/null +++ b/LeanPool/PointwiseComposition/Imports.lean @@ -0,0 +1,244 @@ +/- +Copyright (c) 2026 Lean Pool contributors. All rights reserved. +Released under Apache 2.0 license as described in the file LICENSE. +Authors: Lean Pool contributors +-/ +module -- shake: keep-all --deprecated_module: ignore + +-- Generated project imports; run `lake exe mk_all`. +public import LeanPool.PointwiseComposition +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.Arithmetic +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.Basic +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.BetaCoding +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.Conditional +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.EncodedList +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.EncodedListEvaluation +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.Evaluation +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.EvaluationCongruence +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.FoundationCompat +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.Minimization +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.NumeralEvaluation +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.Pairing +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.PartialRecursive +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.PartialRecursiveEvaluation +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.Recursion +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.ArithmeticCode.RecursionEvaluation +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.Cell +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.CellCongruence +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.CellEvaluation +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.Certificate +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.CompositionDispatch +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.CompositionPersistence +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.History +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.HistoryEvaluation +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.PairPersistence +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.PersistenceInduction +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.PrimitiveRecursionPersistence +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.PrimitiveRecursionStructuralBridges +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.TableLookup +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.Evaluator.TableLookupEvaluation +public import LeanPool.PointwiseComposition.CategoricalRiceShapiro.PartialRecursive.CanonicalComposition +public import LeanPool.PointwiseComposition.FailureOfComposition.ArithmeticCodeCompiler +public import LeanPool.PointwiseComposition.FailureOfComposition.ArithmeticFormulaAtoms +public import LeanPool.PointwiseComposition.FailureOfComposition.ArithmeticProgramOperations +public import LeanPool.PointwiseComposition.FailureOfComposition.AxiomEnumeration +public import LeanPool.PointwiseComposition.FailureOfComposition.BoundedSemidecision +public import LeanPool.PointwiseComposition.FailureOfComposition.CompositionClosure +public import LeanPool.PointwiseComposition.FailureOfComposition.ComputationSearchIndices +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteAdequacy +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteConstructorGraphs +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteDiagonal +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteEmptyGraph +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteEvaluatorGraph +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteGeneratedCongruence +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteGodel +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteGodelRE +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteIndexObstruction +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteMinimizationGraph +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcretePersistence +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcretePiOneCharacterization +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteRecursionGraph +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteWeakTotality +public import LeanPool.PointwiseComposition.FailureOfComposition.ConcreteWitnessGraphs +public import LeanPool.PointwiseComposition.FailureOfComposition.CraigPresentation +public import LeanPool.PointwiseComposition.FailureOfComposition.GeneratedClassification +public import LeanPool.PointwiseComposition.FailureOfComposition.GeneratedCollapse +public import LeanPool.PointwiseComposition.FailureOfComposition.GeneratedExtensionality +public import LeanPool.PointwiseComposition.FailureOfComposition.GeneratedGraphDefinitions +public import LeanPool.PointwiseComposition.FailureOfComposition.GeneratedIndexClassification +public import LeanPool.PointwiseComposition.FailureOfComposition.GeneratedIndexQuotient +public import LeanPool.PointwiseComposition.FailureOfComposition.GeneratedIndexTransport +public import LeanPool.PointwiseComposition.FailureOfComposition.GeneratedQuotient +public import LeanPool.PointwiseComposition.FailureOfComposition.GeneratedSoundness +public import LeanPool.PointwiseComposition.FailureOfComposition.GeneratedWitnessGraphs +public import LeanPool.PointwiseComposition.FailureOfComposition.GeneratedWitnessPointwise +public import LeanPool.PointwiseComposition.FailureOfComposition.GodelGraph +public import LeanPool.PointwiseComposition.FailureOfComposition.GraphQuotient +public import LeanPool.PointwiseComposition.FailureOfComposition.HistoryObstruction +public import LeanPool.PointwiseComposition.FailureOfComposition.HistoryWitnesses +public import LeanPool.PointwiseComposition.FailureOfComposition.KleeneNormalForm +public import LeanPool.PointwiseComposition.FailureOfComposition.ManuscriptObstruction +public import LeanPool.PointwiseComposition.FailureOfComposition.MinimizationPersistence +public import LeanPool.PointwiseComposition.FailureOfComposition.PartialRecursiveQuotient +public import LeanPool.PointwiseComposition.FailureOfComposition.PiOneCharacterization +public import LeanPool.PointwiseComposition.FailureOfComposition.PiOneCongruence +public import LeanPool.PointwiseComposition.FailureOfComposition.PiOneDefinitions +public import LeanPool.PointwiseComposition.FailureOfComposition.PiOneExtensionality +public import LeanPool.PointwiseComposition.FailureOfComposition.PiOneIndexCharacterization +public import LeanPool.PointwiseComposition.FailureOfComposition.PiOneNecessity +public import LeanPool.PointwiseComposition.FailureOfComposition.ProductiveDivergence +public import LeanPool.PointwiseComposition.FailureOfComposition.ProductiveGraph +public import LeanPool.PointwiseComposition.FailureOfComposition.Productiveness +public import LeanPool.PointwiseComposition.FailureOfComposition.ProgramGraph +public import LeanPool.PointwiseComposition.FailureOfComposition.ProgramIndices +public import LeanPool.PointwiseComposition.FailureOfComposition.ProofSearchTemplate +public import LeanPool.PointwiseComposition.FailureOfComposition.QuotientComposition +public import LeanPool.PointwiseComposition.FailureOfComposition.QuotientObstruction +public import LeanPool.PointwiseComposition.FailureOfComposition.RangeAssignment +public import LeanPool.PointwiseComposition.FailureOfComposition.RangeGodel +public import LeanPool.PointwiseComposition.FailureOfComposition.RangeProductive +public import LeanPool.PointwiseComposition.FailureOfComposition.RangeWitness +public import LeanPool.PointwiseComposition.FailureOfComposition.SigmaOneGraphWitness +public import LeanPool.PointwiseComposition.FailureOfComposition.SigmaOneRealization +public import LeanPool.PointwiseComposition.FailureOfComposition.SigmaOneSearch +public import LeanPool.PointwiseComposition.FailureOfComposition.SigmaOneSemidecisionCore +public import LeanPool.PointwiseComposition.FailureOfComposition.TheoryEnumerability +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Basic +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Basic.Hierarchy +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Basic.Misc +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Basic.Model +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Basic.Monotone +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Basic.StrictHierarchy +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.DerivabilityCondition.D1 +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.DerivabilityCondition.D2 +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.DerivabilityCondition.D3 +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.DerivabilityCondition.EquationalTheory +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.DerivabilityCondition.PeanoMinus +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.FixedPoint +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.CraigTrick +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Formula.Basic +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Formula.Coding +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Formula.Functions +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Formula.Iteration +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Formula.Typed +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Language +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Proof.Basic +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Proof.Coding +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Proof.Typed +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Term.Basic +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Term.Coding +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Term.Functions +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Term.Typed +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Bootstrapping.Syntax.Theory +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.BoundedCollection +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Definability +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Definability.Absoluteness +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Definability.BoundedDefinable +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Definability.Definable +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Definability.Hierarchy +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Exponential +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Exponential.Bit +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Exponential.Exp +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Exponential.Log +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Exponential.PPow2 +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Exponential.Pow2 +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.HFS +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.HFS.Basic +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.HFS.Coding +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.HFS.Fixpoint +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.HFS.PRF +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.HFS.Seq +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.HFS.Vec +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.IOpen.Basic +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.ISigma1.Prenex +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Induction +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.LE +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.PeanoMinus.Basic +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.PeanoMinus.Functions +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Prenex +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Q.Basic +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.R0.Basic +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.R0.Representation +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.Schemata +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Arithmetic.TA.Basic +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Incompleteness.Consistency +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Incompleteness.Definability +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Incompleteness.First +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Incompleteness.ProvabilityAbstraction.Basic +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Incompleteness.RosserProvability +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Incompleteness.Second +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Incompleteness.StandardProvability +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Incompleteness.WitnessComparison +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.LJ.Basic +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.LJ.GoedelGentzen +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.LJ.Head +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.LK.Basic +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.LK.Completeness +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.LK.Completeness.CanonicalModel +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.LK.Completeness.CountableSublanguage +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.LK.Completeness.CounterModel +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.LK.CutFree +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.LK.Eq +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.LK.Hauptsatz +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.LK.Simplified +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.LK.Soundness +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Syntax.Classical.BinderNotation +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Syntax.Classical.BinderSemantics +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Syntax.Classical.Coding +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Syntax.Classical.Eq +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Syntax.Classical.Formula +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Syntax.Classical.Operator +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Syntax.Classical.Padding +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Syntax.Classical.PrimrecCoding +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Syntax.Classical.Rew +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Syntax.Intuitionistic.Formula +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Syntax.Intuitionistic.Rew +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Tarski.AesopInit +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Tarski.Basic +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Tarski.Definability +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Tarski.Elementary +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Tarski.Eq +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Tarski.Model +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Tarski.Operator +public import LeanPool.PointwiseComposition.Foundation.FirstOrder.Tarski.Ultraproduct +public import LeanPool.PointwiseComposition.Foundation.Logic.Calculus +public import LeanPool.PointwiseComposition.Foundation.Logic.Entailment +public import LeanPool.PointwiseComposition.Foundation.Logic.ForcingRelation +public import LeanPool.PointwiseComposition.Foundation.Logic.LogicSymbol +public import LeanPool.PointwiseComposition.Foundation.Logic.Semantics +public import LeanPool.PointwiseComposition.Foundation.Meta.ClProver +public import LeanPool.PointwiseComposition.Foundation.Meta.ClProverTheorems +public import LeanPool.PointwiseComposition.Foundation.Meta.Lit +public import LeanPool.PointwiseComposition.Foundation.Meta.Qq +public import LeanPool.PointwiseComposition.Foundation.Meta.TwoSided +public import LeanPool.PointwiseComposition.Foundation.Propositional.Entailment.Cl +public import LeanPool.PointwiseComposition.Foundation.Propositional.Entailment.Int +public import LeanPool.PointwiseComposition.Foundation.Propositional.Entailment.Minimal +public import LeanPool.PointwiseComposition.Foundation.Syntax.Predicate.Language +public import LeanPool.PointwiseComposition.Foundation.Syntax.Predicate.Quantifier +public import LeanPool.PointwiseComposition.Foundation.Syntax.Predicate.Rew +public import LeanPool.PointwiseComposition.Foundation.Syntax.Predicate.Term +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.AdjunctiveSet +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Arithmetic +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Computability +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Empty +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.ExistsUnique +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Fin.Basic +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Fin.Matrix +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Finset.Basic +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Finset.Card +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Function +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Graph +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.IsEmpty +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.List.Basic +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Matrix +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Multiset +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Nat.Basic +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Nat.Matrix +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.NotationClass +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Option +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Order.Dense +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Part +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.Quotient +public import LeanPool.PointwiseComposition.Foundation.Vorspiel.String diff --git a/LeanPool/projects/pointwise-provable-composition.yaml b/LeanPool/projects/pointwise-provable-composition.yaml new file mode 100644 index 000000000..d4eb3042b --- /dev/null +++ b/LeanPool/projects/pointwise-provable-composition.yaml @@ -0,0 +1,72 @@ +slug: pointwise-provable-composition +title: Pointwise provable equality and the failure of composition +summary: For every consistent recursively enumerable extension of Peano arithmetic, pointwise provable + equality of unary programs fails to respect composition. Separate productive-set and Goedel incompleteness + proofs establish the obstruction. For consistent extensions, compatibility is equivalent to Pi-one + completeness. For every extension, the generated composition congruence is extensional equality + in the Sigma-one sound case and universal otherwise. The development also proves weak-totality + and range obstructions and identifies the sound generated quotient with actual unary partial recursive + functions. Its coherent dependency closure preserves the concrete evaluator, arithmetization, first-order + syntax, semantics and provability infrastructure. Main-result proofs were produced by AI agents + under Florian Lengyel's direction; the Foundation dependency includes substantial human formalization + by the Formalized Formal Logic contributors. +branch: mathematical logic +entry_module: LeanPool.PointwiseComposition +authors: +- Florian Lengyel +contributors: +- Shogo Saitou +- Mashu Noguchi +- Formalized Formal Logic contributors +source: + title: Pointwise provable equality and the failure of composition + authors: + - Florian Lengyel + arxiv: '2609.25556' + url: https://github.com/flengyel/FailureOfComposition + github_repo: flengyel/FailureOfComposition + commit: 506d1f1494d6c05b0ba304edf5fe0bfa6c32864b + announcement: https://arxiv.org/abs/2609.25556 + announcement_date: '2026-09-22T01:43:45Z' + dependency_url: https://github.com/flengyel/foundation + dependency_commit: 01f617fbe240a84aaf1c45b31b9d65e0a2e21c1d + dependency_license: Apache-2.0 + completion_record: https://github.com/flengyel/FailureOfComposition/blob/506d1f1494d6c05b0ba304edf5fe0bfa6c32864b/Lean/FailureOfComposition/Porting/STYLE_CLEANUP_VALIDATION.json + completion_date: '2026-09-25T13:45:25.762222Z' + verified_source_commit: dea04886088894fa919b54249b4e97ad59d56d54 +license: Apache-2.0 +status: verified +provenance: mix +main_declarations: +- PointwiseComposition.no_quotient_of_enumerable_axioms +main_results: +- declaration: PointwiseComposition.no_quotient_of_enumerable_axioms + informal: For every consistent extension T of Peano arithmetic with recursively enumerable axiom + codes, no binary operation on the pointwise-provability quotient of actual natural-number program + indices respects their actual composition. +- declaration: PointwiseComposition.FailureOfComposition.ConcreteIndices.no_index_quotient_of_re_axioms + informal: For every consistent extension T of Peano arithmetic with recursively enumerable axiom + codes, no binary operation on the pointwise-provability quotient of actual natural-number program + indices respects their actual composition. +- declaration: PointwiseComposition.FailureOfComposition.ConcreteIndices.pi_one_characterization + informal: For every consistent extension of Peano arithmetic, right compatibility, composition + congruence, completeness for true Pi-one sentences, and agreement with extensional equality of + partial functions are equivalent. +- declaration: PointwiseComposition.FailureOfComposition.ConcreteIndices.generated_congruence_classification + informal: For every extension of Peano arithmetic, with no consistency or enumerability hypothesis, + the least composition congruence containing pointwise provable equality is extensional equality + if the theory is Sigma-one sound and the universal relation otherwise. +- declaration: PointwiseComposition.FailureOfComposition.ConcreteIndices.generatedQuotientPartialRecursiveEquiv + informal: For every Sigma-one sound extension of Peano arithmetic, the generated quotient is a + monoid isomorphic to actual unary partial recursive functions with partial-function composition. +tags: +- computability +- provability +- first-order-arithmetic +- quotient-congruences +- mathematical-logic +msc: +- 03D75 +- 03F40 +- 08A30 +- 18B10 From afc65812781d9ebe367b691e5d0eca1f100059c4 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Mon, 19 Oct 2026 17:02:25 +0000 Subject: [PATCH 2/5] Share evaluator decoder and constructor helpers --- .../Evaluator/CompositionDispatch.lean | 12 +- .../Evaluator/PairPersistence.lean | 159 +----------- .../PrimitiveRecursionPersistence.lean | 8 +- .../ConcreteConstructorGraphs.lean | 238 +----------------- .../ConcreteRecursionGraph.lean | 40 --- .../MinimizationPersistence.lean | 81 +----- 6 files changed, 25 insertions(+), 513 deletions(-) diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/CompositionDispatch.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/CompositionDispatch.lean index c87c55894..6a0a47228 100644 --- a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/CompositionDispatch.lean +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/CompositionDispatch.lean @@ -390,12 +390,12 @@ private theorem bodd_toNat_eq_mod_two (n : ℕ) : n.bodd.toNat = n % 2 := by rw [Nat.mod_two_of_bodd] /-- The production tag decoder, written with remainders. -/ -private theorem partrecCodeTag_eq (q : ℕ) : +theorem partrecCodeTag_eq (q : ℕ) : partrecCodeTag q = if q < 4 then q else 4 + 2 * ((q - 4) % 2) + Nat.div2 (q - 4) % 2 := by simp only [partrecCodeTag, bodd_toNat_eq_mod_two] /-- The constructor number of a standard index, read inside a model. -/ -private theorem eval_codePartrecTag_natCast [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) +theorem eval_codePartrecTag_natCast [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) (v : Fin r → M) (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : Semiformula.Evalb (((partrecCodeTag q : ℕ) : M) :> v) (code (codePartrecTag d)) := by @@ -453,7 +453,7 @@ private theorem eval_codePartrecTag_natCast [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] { exact eval_codeIfPos_of _ _ _ (0 : M) (((q : ℕ)) : M) _ _ v hlt0 hd hbig (Or.inr ⟨rfl, rfl⟩) /-- The payload of a standard compound index, read inside a model. -/ -private theorem eval_codePartrecPayload_natCast [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) +theorem eval_codePartrecPayload_natCast [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) (v : Fin r → M) (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : Semiformula.Evalb (((partrecCodePayload q : ℕ) : M) :> v) (code (codePartrecPayload d)) := by @@ -464,20 +464,20 @@ private theorem eval_codePartrecPayload_natCast [M↓[ℒₒᵣ] ⊧* 𝐏𝐀 eval_codeDiv2_natCast _ _ v (eval_codeDiv2_natCast _ (q - 4) v hrr) /-- The first subcode of a standard index, read inside a model. -/ -private theorem eval_codePartrecPayload₁_natCast [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) +theorem eval_codePartrecPayload₁_natCast [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) (v : Fin r → M) (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : Semiformula.Evalb (((partrecCodePayload₁ q : ℕ) : M) :> v) (code (codePartrecPayload₁ d)) := eval_codeUnpair₁_natCast (codePartrecPayload d) _ v (eval_codePartrecPayload_natCast d q v hd) /-- The second subcode of a standard index, read inside a model. -/ -private theorem eval_codePartrecPayload₂_natCast [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) +theorem eval_codePartrecPayload₂_natCast [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) (v : Fin r → M) (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : Semiformula.Evalb (((partrecCodePayload₂ q : ℕ) : M) :> v) (code (codePartrecPayload₂ d)) := eval_codeUnpair₂_natCast (codePartrecPayload d) _ v (eval_codePartrecPayload_natCast d q v hd) /-- A successful evaluator cell whose constructor number is `4` is the value of the pairing branch. Adapted from the accepted external tag-4 probe. -/ -private theorem cell_pair_branch [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (dtable dn : Code r) (v : Fin r → M) +theorem cell_pair_branch [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (dtable dn : Code r) (v : Fin r → M) (z k tag : M) (hk : Semiformula.Evalb (k :> v) (code (codeUnpair₁ (codeListLength dtable)))) (hkpos : 0 < k) (htag : diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/PairPersistence.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/PairPersistence.lean index 2821d39b2..ca1506c3e 100644 --- a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/PairPersistence.lean +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/PairPersistence.lean @@ -30,9 +30,10 @@ The proof decomposes a successful source cell into certificates for the two payload subcodes at stage `s`, applies the induction hypothesis once to each, rebuilds the two table lookups at stage `t` with `eval_prefix_lookup_succ_of_codeHistoryEvaluator`, and reconstructs the target -cell with `eval_codeEvaluatorCell_succ_of_pair_component_lookups`. The private -helpers relate `partrecCodeTag` to its remainder form, bound both payloads -strictly below `q`, and read the decoders inside a model. The fuel and the +cell with `eval_codeEvaluatorCell_succ_of_pair_component_lookups`. The shared +helpers bound both payloads strictly below `q` and decompose the pairing branch. +The shared decoder readings and dispatcher branch theorem come from +`Evaluator.CompositionDispatch`. The fuel and the program index that the cell reads are supplied by the generic public readings `eval_codeEvaluatorCell_fuel` and `eval_codeEvaluatorCell_index` of `Evaluator.HistoryEvaluation`. @@ -56,24 +57,13 @@ namespace Evaluator variable {M : Type*} [ORingStructure M] -/-! -### Decoder bridge and ranking, over `ℕ` -/ - -/-- Production's tag decoder, written with remainders. `bodd.toNat` and `% 2` -are related by `Nat.mod_two_of_bodd`, not assumed definitionally equal. -/ -private theorem tagFour_tag_remainders (q : ℕ) : - partrecCodeTag q = if q < 4 then q else 4 + 2 * ((q - 4) % 2) + Nat.div2 (q - 4) % 2 := - by - have hb : ∀ n : ℕ, n.bodd.toNat = n % 2 := fun n => by rw [Nat.mod_two_of_bodd] - simp only [partrecCodeTag, hb] - /-- Both subcodes of a standard constructor-`4` index lie strictly below it. -/ -private theorem tagFour_payloads_lt (q : ℕ) (hq : partrecCodeTag q = 4) : +theorem tagFour_payloads_lt (q : ℕ) (hq : partrecCodeTag q = 4) : partrecCodePayload₁ q < q ∧ partrecCodePayload₂ q < q := by have h4 : 4 ≤ q := by rcases Nat.lt_or_ge q 4 with hlt | hge - · rw [tagFour_tag_remainders, ite_eq_left hlt] at hq + · rw [partrecCodeTag_eq, ite_eq_left hlt] at hq omega · exact hge have hdd : partrecCodePayload q ≤ q - 4 := @@ -86,140 +76,13 @@ private theorem tagFour_payloads_lt (q : ℕ) (hq : partrecCodeTag q = 4) : Nat.unpair_right_le (partrecCodePayload q) omega -/-! -### Decoder readings inside a model -/ - -/-- The constructor number of a standard index, read inside a model. -/ -private theorem tagFour_read_tag [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) (v : Fin r → M) - (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : - Semiformula.Evalb (((partrecCodeTag q : ℕ) : M) :> v) (code (codePartrecTag d)) := - by - have h4 : Semiformula.Evalb (((4 : ℕ) : M) :> v) (code (codeConst (n := r) 4)) := - eval_codeConst 4 v - have h2 : Semiformula.Evalb (((2 : ℕ) : M) :> v) (code (codeConst (n := r) 2)) := - eval_codeConst 2 v - have hrr := eval_codeSub_natCast d (codeConst 4) q 4 v hd (by simpa using h4) - have hbodd0 := eval_codeBodd_natCast (codeSub d (codeConst 4)) (q - 4) v hrr - have hbodd1 := - eval_codeBodd_natCast (codeDiv2 (codeSub d (codeConst 4))) (Nat.div2 (q - 4)) v - (eval_codeDiv2_natCast _ (q - 4) v hrr) - have hmul : - Semiformula.Evalb ((((2 * ((q - 4) % 2) : ℕ)) : M) :> v) - (code (codeMul (codeConst 2) (codeBodd (codeSub d (codeConst 4))))) := - by - refine (eval_codeMul_iff _ _ _ v).mpr ⟨_, _, h2, hbodd0, ?_⟩ - push_cast - norm_num - have hadd1 : - Semiformula.Evalb ((((4 + 2 * ((q - 4) % 2) : ℕ)) : M) :> v) - (code - (codeAdd (codeConst 4) (codeMul (codeConst 2) (codeBodd (codeSub d (codeConst 4)))))) := - by - refine (eval_codeAdd_iff _ _ _ v).mpr ⟨_, _, h4, hmul, ?_⟩ - push_cast - norm_num - have hbig : - Semiformula.Evalb ((((4 + 2 * ((q - 4) % 2) + Nat.div2 (q - 4) % 2 : ℕ)) : M) :> v) - (code - (codeAdd - (codeAdd (codeConst 4) (codeMul (codeConst 2) (codeBodd (codeSub d (codeConst 4))))) - (codeBodd (codeDiv2 (codeSub d (codeConst 4)))))) := - by - refine (eval_codeAdd_iff _ _ _ v).mpr ⟨_, _, hadd1, hbodd1, ?_⟩ - push_cast - norm_num - rw [tagFour_tag_remainders] - simp only [codePartrecTag] - by_cases hq : q < 4 - · have hlt1 : Semiformula.Evalb ((1 : M) :> v) (code (codeLt d (codeConst 4))) := - by - refine (eval_codeLt_iff _ _ _ v).mpr ⟨_, _, hd, by simpa using h4, Or.inl ⟨?_, rfl⟩⟩ - exact_mod_cast hq - rw [ite_eq_left hq] - exact - eval_codeIfPos_of _ _ _ (1 : M) (((q : ℕ)) : M) _ _ v hlt1 hd hbig - (Or.inl ⟨_root_.zero_lt_one, rfl⟩) - · have hlt0 : Semiformula.Evalb ((0 : M) :> v) (code (codeLt d (codeConst 4))) := - by - refine (eval_codeLt_iff _ _ _ v).mpr ⟨_, _, hd, by simpa using h4, Or.inr ⟨?_, rfl⟩⟩ - intro hc - exact hq (by exact_mod_cast hc) - rw [ite_eq_right hq] - exact eval_codeIfPos_of _ _ _ (0 : M) (((q : ℕ)) : M) _ _ v hlt0 hd hbig (Or.inr ⟨rfl, rfl⟩) - -/-- The payload of a standard index, read inside a model. -/ -private theorem tagFour_read_payload [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) - (v : Fin r → M) (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : - Semiformula.Evalb (((partrecCodePayload q : ℕ) : M) :> v) (code (codePartrecPayload d)) := - by - have h4 : Semiformula.Evalb (((4 : ℕ) : M) :> v) (code (codeConst (n := r) 4)) := - eval_codeConst 4 v - have hrr := eval_codeSub_natCast d (codeConst 4) q 4 v hd (by simpa using h4) - simpa only [codePartrecPayload, partrecCodePayload] using - eval_codeDiv2_natCast _ _ v (eval_codeDiv2_natCast _ (q - 4) v hrr) - -/-- The first subcode of a standard index, read inside a model. -/ -private theorem tagFour_read_payload₁ [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) - (v : Fin r → M) (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : - Semiformula.Evalb (((partrecCodePayload₁ q : ℕ) : M) :> v) (code (codePartrecPayload₁ d)) := - eval_codeUnpair₁_natCast (codePartrecPayload d) _ v (tagFour_read_payload d q v hd) - -/-- The second subcode of a standard index, read inside a model. -/ -private theorem tagFour_read_payload₂ [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) - (v : Fin r → M) (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : - Semiformula.Evalb (((partrecCodePayload₂ q : ℕ) : M) :> v) (code (codePartrecPayload₂ d)) := - eval_codeUnpair₂_natCast (codePartrecPayload d) _ v (tagFour_read_payload d q v hd) - -/-! -### The pairing branch of the dispatcher -/ - -/-- A successful evaluator cell whose constructor number is `4` is the value of -its pairing branch. -/ -private theorem tagFour_pair_branch [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (dtable dn : Code r) - (v : Fin r → M) (z k tag : M) - (hk : Semiformula.Evalb (k :> v) (code (codeUnpair₁ (codeListLength dtable)))) - (hkpos : 0 < k) - (htag : - Semiformula.Evalb (tag :> v) - (code (codePartrecTag (codeUnpair₂ (codeListLength dtable))))) - (h4 : tag = ((4 : ℕ) : M)) - (hcell : Semiformula.Evalb (z :> v) (code (codeEvaluatorCell dtable dn))) : - Semiformula.Evalb (z :> v) - (code - (codePairEvaluatorCell dtable (codeUnpair₁ (codeListLength dtable)) - (codePartrecPayload₁ (codeUnpair₂ (codeListLength dtable))) - (codePartrecPayload₂ (codeUnpair₂ (codeListLength dtable))) dn)) := - by - have hval : - ∀ (m : ℕ) (x : M), - Semiformula.Evalb (x :> v) (code (codeConst (n := r) m)) → x = ((m : ℕ) : M) := - fun m x hx => eval_unique hx (eval_codeConst m v) - simp only [codeEvaluatorCell] at hcell - obtain ⟨f0, hf0, hc0⟩ := eval_codeIfPos_cases _ _ _ z v hcell - have hf0k : f0 = k := eval_unique hf0 hk - rcases hc0 with ⟨-, hbig⟩ | ⟨h0, -⟩ - swap - · exact absurd (hf0k ▸ h0 : k = 0) (ne_of_gt hkpos) - obtain ⟨e4, he4, hcase4⟩ := eval_codeIfPos_cases _ _ _ z v hbig - rw [eval_codeEq_iff] at he4 - obtain ⟨x, w, hx, hw, hxw⟩ := he4 - have hxt : x = tag := eval_unique hx htag - have hw4 : w = ((4 : ℕ) : M) := hval 4 w hw - have he41 : e4 = 1 := by - rcases hxw with ⟨-, h1⟩ | ⟨hne, -⟩ - · exact h1 - · exact absurd (by rw [hxt, hw4]; exact h4) hne - rcases hcase4 with ⟨-, hpair⟩ | ⟨h0, -⟩ - · exact hpair - · exact absurd (he41 ▸ h0 : (1 : M) = 0) _root_.one_ne_zero - /-! ### Forward decomposition of a source tag-4 cell -/ /-- A successful source cell at a standard constructor-`4` index yields a history success for each subcode at the same stage, and the Cantor pair of the two outputs. -/ -private theorem tagFour_source_subcode_histories [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] +theorem tagFour_source_subcode_histories [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] (q : ℕ) (hq : partrecCodeTag q = 4) (s u y : M) (hs : 0 < s) (hcell : Semiformula.Evalb ((y + 1) :> ![s, ((q : ℕ) : M), u]) @@ -237,10 +100,10 @@ private theorem tagFour_source_subcode_histories [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] Semiformula.Evalb (((4 : ℕ) : M) :> ![s, ((q : ℕ) : M), u]) (code (codePartrecTag (codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell)))) := by - have h := tagFour_read_tag _ q ![s, ((q : ℕ) : M), u] hidx + have h := eval_codePartrecTag_natCast _ q ![s, ((q : ℕ) : M), u] hidx rwa [hq] at h have hbranch := - tagFour_pair_branch codeEvaluatorHistoryBeforeCell (Code.proj (2 : Fin 3)) + cell_pair_branch codeEvaluatorHistoryBeforeCell (Code.proj (2 : Fin 3)) ![s, ((q : ℕ) : M), u] (y + 1) s (((4 : ℕ) : M)) hk hs htag rfl hcell obtain ⟨a, b, hla, hlb, hy⟩ := (eval_codePairEvaluatorCell_succ_iff codeEvaluatorHistoryBeforeCell @@ -249,8 +112,8 @@ private theorem tagFour_source_subcode_histories [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] (codePartrecPayload₂ (codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell))) (Code.proj (2 : Fin 3)) y ![s, ((q : ℕ) : M), u]).mp hbranch - have hp1 := tagFour_read_payload₁ _ q ![s, ((q : ℕ) : M), u] hidx - have hp2 := tagFour_read_payload₂ _ q ![s, ((q : ℕ) : M), u] hidx + have hp1 := eval_codePartrecPayload₁_natCast _ q ![s, ((q : ℕ) : M), u] hidx + have hp2 := eval_codePartrecPayload₂_natCast _ q ![s, ((q : ℕ) : M), u] hidx have hq1 := eval_iff_codeConst_of_eval _ (partrecCodePayload₁ q) ![s, ((q : ℕ) : M), u] hp1 have hq2 := eval_iff_codeConst_of_eval _ (partrecCodePayload₂ q) ![s, ((q : ℕ) : M), u] hp2 have hlaC := diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/PrimitiveRecursionPersistence.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/PrimitiveRecursionPersistence.lean index 753373288..43ac429f7 100644 --- a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/PrimitiveRecursionPersistence.lean +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/PrimitiveRecursionPersistence.lean @@ -134,13 +134,13 @@ variable {M : Type*} [ORingStructure M] /-- A standard tag-6 index, cast into the model, is the canonical primitive-recursion index of its decoded payloads. -/ -private theorem tagSix_canonical_cast [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] (q : ℕ) (hq : partrecCodeTag q = 6) : +theorem tagSix_canonical_cast [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] (q : ℕ) (hq : partrecCodeTag q = 6) : ((q : ℕ) : M) = ((canonicalPartrecPrecIndex (partrecCodePayload₁ q) (partrecCodePayload₂ q) : ℕ) : M) := by conv_lhs => rw [partrecCode_eq_canonicalPartrecPrecIndex_of_tag_six q hq] /-- The constructor number `6`, read at a standard tag-6 index. -/ -private theorem tagSix_read_tag [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) +theorem tagSix_read_tag [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) (hq : partrecCodeTag q = 6) (v : Fin r → M) (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : Semiformula.Evalb ((6 : M) :> v) (code (codePartrecTag d)) := @@ -151,7 +151,7 @@ private theorem tagSix_read_tag [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d (partrecCodePayload₂ q) v hd /-- The base payload, read at a standard tag-6 index. -/ -private theorem tagSix_read_payload₁ [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) +theorem tagSix_read_payload₁ [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) (hq : partrecCodeTag q = 6) (v : Fin r → M) (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : Semiformula.Evalb (((partrecCodePayload₁ q : ℕ) : M) :> v) (code (codePartrecPayload₁ d)) := @@ -162,7 +162,7 @@ private theorem tagSix_read_payload₁ [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : (partrecCodePayload₂ q) v hd /-- The step payload, read at a standard tag-6 index. -/ -private theorem tagSix_read_payload₂ [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) +theorem tagSix_read_payload₂ [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) (hq : partrecCodeTag q = 6) (v : Fin r → M) (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : Semiformula.Evalb (((partrecCodePayload₂ q : ℕ) : M) :> v) (code (codePartrecPayload₂ d)) := diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteConstructorGraphs.lean b/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteConstructorGraphs.lean index e62c9a7b7..8273558cf 100644 --- a/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteConstructorGraphs.lean +++ b/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteConstructorGraphs.lean @@ -16,8 +16,8 @@ namespace PointwiseComposition /-! Constructor equations for the concrete evaluator over arbitrary models of PA. -The local decoder and forward pairing helpers are reproduced from production -PairPersistence; the new public results remove fuel and synchronize component +Shared decoder and forward pairing helpers come from production +PairPersistence; the public results remove fuel and synchronize component computations using unconditional persistence. -/ @@ -38,240 +38,6 @@ namespace ConcreteEvaluator variable {M : Type*} [ORingStructure M] -/-! -### Decoder bridge and ranking, over `ℕ` -/ - -/-- Production's tag decoder, written with remainders. `bodd.toNat` and `% 2` -are related by `Nat.mod_two_of_bodd`, not assumed definitionally equal. -/ -private theorem tagFour_tag_remainders (q : ℕ) : - partrecCodeTag q = if q < 4 then q else 4 + 2 * ((q - 4) % 2) + Nat.div2 (q - 4) % 2 := - by - have hb : ∀ n : ℕ, n.bodd.toNat = n % 2 := fun n => by rw [Nat.mod_two_of_bodd] - simp only [partrecCodeTag, hb] - -/-- Both subcodes of a standard constructor-`4` index lie strictly below it. -/ -private theorem tagFour_payloads_lt (q : ℕ) (hq : partrecCodeTag q = 4) : - partrecCodePayload₁ q < q ∧ partrecCodePayload₂ q < q := - by - have h4 : 4 ≤ q := by - rcases Nat.lt_or_ge q 4 with hlt | hge - · rw [tagFour_tag_remainders, ite_eq_left hlt] at hq - omega - · exact hge - have hdd : partrecCodePayload q ≤ q - 4 := - by - simp only [partrecCodePayload, Nat.div2_val] - exact le_trans (Nat.div_le_self ((q - 4) / 2) 2) (Nat.div_le_self (q - 4) 2) - have h1 : partrecCodePayload₁ q ≤ partrecCodePayload q := - Nat.unpair_left_le (partrecCodePayload q) - have h2 : partrecCodePayload₂ q ≤ partrecCodePayload q := - Nat.unpair_right_le (partrecCodePayload q) - omega - -/-! -### Decoder readings inside a model -/ - -/-- The constructor number of a standard index, read inside a model. -/ -private theorem tagFour_read_tag [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) (v : Fin r → M) - (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : - Semiformula.Evalb (((partrecCodeTag q : ℕ) : M) :> v) (code (codePartrecTag d)) := - by - have h4 : Semiformula.Evalb (((4 : ℕ) : M) :> v) (code (codeConst (n := r) 4)) := - eval_codeConst 4 v - have h2 : Semiformula.Evalb (((2 : ℕ) : M) :> v) (code (codeConst (n := r) 2)) := - eval_codeConst 2 v - have hrr := eval_codeSub_natCast d (codeConst 4) q 4 v hd (by simpa using h4) - have hbodd0 := eval_codeBodd_natCast (codeSub d (codeConst 4)) (q - 4) v hrr - have hbodd1 := - eval_codeBodd_natCast (codeDiv2 (codeSub d (codeConst 4))) (Nat.div2 (q - 4)) v - (eval_codeDiv2_natCast _ (q - 4) v hrr) - have hmul : - Semiformula.Evalb ((((2 * ((q - 4) % 2) : ℕ)) : M) :> v) - (code (codeMul (codeConst 2) (codeBodd (codeSub d (codeConst 4))))) := - by - refine (eval_codeMul_iff _ _ _ v).mpr ⟨_, _, h2, hbodd0, ?_⟩ - push_cast - norm_num - have hadd1 : - Semiformula.Evalb ((((4 + 2 * ((q - 4) % 2) : ℕ)) : M) :> v) - (code - (codeAdd (codeConst 4) (codeMul (codeConst 2) (codeBodd (codeSub d (codeConst 4)))))) := - by - refine (eval_codeAdd_iff _ _ _ v).mpr ⟨_, _, h4, hmul, ?_⟩ - push_cast - norm_num - have hbig : - Semiformula.Evalb ((((4 + 2 * ((q - 4) % 2) + Nat.div2 (q - 4) % 2 : ℕ)) : M) :> v) - (code - (codeAdd - (codeAdd (codeConst 4) (codeMul (codeConst 2) (codeBodd (codeSub d (codeConst 4))))) - (codeBodd (codeDiv2 (codeSub d (codeConst 4)))))) := - by - refine (eval_codeAdd_iff _ _ _ v).mpr ⟨_, _, hadd1, hbodd1, ?_⟩ - push_cast - norm_num - rw [tagFour_tag_remainders] - simp only [codePartrecTag] - by_cases hq : q < 4 - · have hlt1 : Semiformula.Evalb ((1 : M) :> v) (code (codeLt d (codeConst 4))) := - by - refine (eval_codeLt_iff _ _ _ v).mpr ⟨_, _, hd, by simpa using h4, Or.inl ⟨?_, rfl⟩⟩ - exact_mod_cast hq - rw [ite_eq_left hq] - exact - eval_codeIfPos_of _ _ _ (1 : M) (((q : ℕ)) : M) _ _ v hlt1 hd hbig - (Or.inl ⟨_root_.zero_lt_one, rfl⟩) - · have hlt0 : Semiformula.Evalb ((0 : M) :> v) (code (codeLt d (codeConst 4))) := - by - refine (eval_codeLt_iff _ _ _ v).mpr ⟨_, _, hd, by simpa using h4, Or.inr ⟨?_, rfl⟩⟩ - intro hc - exact hq (by exact_mod_cast hc) - rw [ite_eq_right hq] - exact eval_codeIfPos_of _ _ _ (0 : M) (((q : ℕ)) : M) _ _ v hlt0 hd hbig (Or.inr ⟨rfl, rfl⟩) - -/-- The payload of a standard index, read inside a model. -/ -private theorem tagFour_read_payload [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) - (v : Fin r → M) (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : - Semiformula.Evalb (((partrecCodePayload q : ℕ) : M) :> v) (code (codePartrecPayload d)) := - by - have h4 : Semiformula.Evalb (((4 : ℕ) : M) :> v) (code (codeConst (n := r) 4)) := - eval_codeConst 4 v - have hrr := eval_codeSub_natCast d (codeConst 4) q 4 v hd (by simpa using h4) - simpa only [codePartrecPayload, partrecCodePayload] using - eval_codeDiv2_natCast _ _ v (eval_codeDiv2_natCast _ (q - 4) v hrr) - -/-- The first subcode of a standard index, read inside a model. -/ -private theorem tagFour_read_payload₁ [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) - (v : Fin r → M) (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : - Semiformula.Evalb (((partrecCodePayload₁ q : ℕ) : M) :> v) (code (codePartrecPayload₁ d)) := - eval_codeUnpair₁_natCast (codePartrecPayload d) _ v (tagFour_read_payload d q v hd) - -/-- The second subcode of a standard index, read inside a model. -/ -private theorem tagFour_read_payload₂ [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) - (v : Fin r → M) (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : - Semiformula.Evalb (((partrecCodePayload₂ q : ℕ) : M) :> v) (code (codePartrecPayload₂ d)) := - eval_codeUnpair₂_natCast (codePartrecPayload d) _ v (tagFour_read_payload d q v hd) - -/-! -### The pairing branch of the dispatcher -/ - -/-- A successful evaluator cell whose constructor number is `4` is the value of -its pairing branch. -/ -private theorem tagFour_pair_branch [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (dtable dn : Code r) - (v : Fin r → M) (z k tag : M) - (hk : Semiformula.Evalb (k :> v) (code (codeUnpair₁ (codeListLength dtable)))) - (hkpos : 0 < k) - (htag : - Semiformula.Evalb (tag :> v) - (code (codePartrecTag (codeUnpair₂ (codeListLength dtable))))) - (h4 : tag = ((4 : ℕ) : M)) - (hcell : Semiformula.Evalb (z :> v) (code (codeEvaluatorCell dtable dn))) : - Semiformula.Evalb (z :> v) - (code - (codePairEvaluatorCell dtable (codeUnpair₁ (codeListLength dtable)) - (codePartrecPayload₁ (codeUnpair₂ (codeListLength dtable))) - (codePartrecPayload₂ (codeUnpair₂ (codeListLength dtable))) dn)) := - by - have hval : - ∀ (m : ℕ) (x : M), - Semiformula.Evalb (x :> v) (code (codeConst (n := r) m)) → x = ((m : ℕ) : M) := - fun m x hx => eval_unique hx (eval_codeConst m v) - simp only [codeEvaluatorCell] at hcell - obtain ⟨f0, hf0, hc0⟩ := eval_codeIfPos_cases _ _ _ z v hcell - have hf0k : f0 = k := eval_unique hf0 hk - rcases hc0 with ⟨-, hbig⟩ | ⟨h0, -⟩ - swap - · exact absurd (hf0k ▸ h0 : k = 0) (ne_of_gt hkpos) - obtain ⟨e4, he4, hcase4⟩ := eval_codeIfPos_cases _ _ _ z v hbig - rw [eval_codeEq_iff] at he4 - obtain ⟨x, w, hx, hw, hxw⟩ := he4 - have hxt : x = tag := eval_unique hx htag - have hw4 : w = ((4 : ℕ) : M) := hval 4 w hw - have he41 : e4 = 1 := by - rcases hxw with ⟨-, h1⟩ | ⟨hne, -⟩ - · exact h1 - · exact absurd (by rw [hxt, hw4]; exact h4) hne - rcases hcase4 with ⟨-, hpair⟩ | ⟨h0, -⟩ - · exact hpair - · exact absurd (he41 ▸ h0 : (1 : M) = 0) _root_.one_ne_zero - -/-! -### Forward decomposition of a source tag-4 cell -/ - -/-- A successful source cell at a standard constructor-`4` index yields a -history success for each subcode at the same stage, and the Cantor pair of the -two outputs. -/ -private theorem tagFour_source_subcode_histories [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] - [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] (q : ℕ) (hq : partrecCodeTag q = 4) (s u y : M) (hs : 0 < s) - (hcell : - Semiformula.Evalb ((y + 1) :> ![s, ((q : ℕ) : M), u]) - (code (codeEvaluatorCell codeEvaluatorHistoryBeforeCell (Code.proj (2 : Fin 3))))) : - ∃ a b : M, - Semiformula.Evalb ![a + 1, s, ((partrecCodePayload₁ q : ℕ) : M), u] - (code codeHistoryEvaluator) ∧ - Semiformula.Evalb ![b + 1, s, ((partrecCodePayload₂ q : ℕ) : M), u] - (code codeHistoryEvaluator) ∧ - y = FFL.FirstOrder.Arithmetic.pair a b := - by - have hk := eval_codeEvaluatorCell_fuel s ((q : ℕ) : M) u - have hidx := eval_codeEvaluatorCell_index s ((q : ℕ) : M) u - have htag : - Semiformula.Evalb (((4 : ℕ) : M) :> ![s, ((q : ℕ) : M), u]) - (code (codePartrecTag (codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell)))) := - by - have h := tagFour_read_tag _ q ![s, ((q : ℕ) : M), u] hidx - rwa [hq] at h - have hbranch := - tagFour_pair_branch codeEvaluatorHistoryBeforeCell (Code.proj (2 : Fin 3)) - ![s, ((q : ℕ) : M), u] (y + 1) s (((4 : ℕ) : M)) hk hs htag rfl hcell - obtain ⟨a, b, hla, hlb, hy⟩ := - (eval_codePairEvaluatorCell_succ_iff codeEvaluatorHistoryBeforeCell - (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell)) - (codePartrecPayload₁ (codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell))) - (codePartrecPayload₂ (codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell))) - (Code.proj (2 : Fin 3)) y ![s, ((q : ℕ) : M), u]).mp - hbranch - have hp1 := tagFour_read_payload₁ _ q ![s, ((q : ℕ) : M), u] hidx - have hp2 := tagFour_read_payload₂ _ q ![s, ((q : ℕ) : M), u] hidx - have hq1 := eval_iff_codeConst_of_eval _ (partrecCodePayload₁ q) ![s, ((q : ℕ) : M), u] hp1 - have hq2 := eval_iff_codeConst_of_eval _ (partrecCodePayload₂ q) ![s, ((q : ℕ) : M), u] hp2 - have hlaC := - (eval_codeTableLookup_query_congr codeEvaluatorHistoryBeforeCell - (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell)) - (codePartrecPayload₁ (codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell))) - (codeConst (n := 3) (partrecCodePayload₁ q)) (Code.proj (2 : Fin 3)) (a + 1) - ![s, ((q : ℕ) : M), u] hq1).mp - hla - have hlbC := - (eval_codeTableLookup_congr_at (codeLift codeEvaluatorHistoryBeforeCell) - (codeLift (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell))) - (codeLift - (codePartrecPayload₂ (codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell)))) - (codeLift (Code.proj (2 : Fin 3))) codeEvaluatorHistoryBeforeCell - (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell)) - (codeConst (n := 3) (partrecCodePayload₂ q)) (Code.proj (2 : Fin 3)) (b + 1) - (a :> ![s, ((q : ℕ) : M), u]) ![s, ((q : ℕ) : M), u] - (fun z => eval_codeLift_iff _ z a _) (fun z => eval_codeLift_iff _ z a _) - (fun z => (eval_codeLift_iff _ z a _).trans (hq2 z)) - (fun z => eval_codeLift_iff _ z a _)).mp - hlb - have hlt := tagFour_payloads_lt q hq - have hpre1 : - FFL.FirstOrder.Arithmetic.pair s ((partrecCodePayload₁ q : ℕ) : M) < - FFL.FirstOrder.Arithmetic.pair s ((q : ℕ) : M) := - FFL.FirstOrder.Arithmetic.pair_lt_pair_right s (by exact_mod_cast hlt.1) - have hpre2 : - FFL.FirstOrder.Arithmetic.pair s ((partrecCodePayload₂ q : ℕ) : M) < - FFL.FirstOrder.Arithmetic.pair s ((q : ℕ) : M) := - FFL.FirstOrder.Arithmetic.pair_lt_pair_right s (by exact_mod_cast hlt.2) - exact - ⟨a, b, - eval_codeHistoryEvaluator_succ_of_prefix_lookup s ((q : ℕ) : M) u a - (partrecCodePayload₁ q) hpre1 hlaC, - eval_codeHistoryEvaluator_succ_of_prefix_lookup s ((q : ℕ) : M) u b - (partrecCodePayload₂ q) hpre2 hlbC, - hy⟩ - /-- At a common stage, pairing computes the pair of its component outputs. -/ theorem evalnCertificateFormula_tag_four_iff [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (q : ℕ) (hq : partrecCodeTag q = 4) (s u y : M) : diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteRecursionGraph.lean b/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteRecursionGraph.lean index 00c3b83b8..8076fd010 100644 --- a/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteRecursionGraph.lean +++ b/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteRecursionGraph.lean @@ -35,46 +35,6 @@ namespace ConcreteEvaluator variable {M : Type*} [ORingStructure M] -/-- A standard tag-6 index, cast into the model, is the canonical -primitive-recursion index of its decoded payloads. -/ -private theorem tagSix_canonical_cast [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] (q : ℕ) (hq : partrecCodeTag q = 6) : - ((q : ℕ) : M) = - ((canonicalPartrecPrecIndex (partrecCodePayload₁ q) (partrecCodePayload₂ q) : ℕ) : M) := - by conv_lhs => rw [partrecCode_eq_canonicalPartrecPrecIndex_of_tag_six q hq] - -/-- The constructor number `6`, read at a standard tag-6 index. -/ -private theorem tagSix_read_tag [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) - (hq : partrecCodeTag q = 6) (v : Fin r → M) - (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : - Semiformula.Evalb ((6 : M) :> v) (code (codePartrecTag d)) := - by - rw [tagSix_canonical_cast (M := M) q hq] at hd - exact - eval_codePartrecTag_canonicalPartrecPrecIndex d (partrecCodePayload₁ q) - (partrecCodePayload₂ q) v hd - -/-- The base payload, read at a standard tag-6 index. -/ -private theorem tagSix_read_payload₁ [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) - (hq : partrecCodeTag q = 6) (v : Fin r → M) - (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : - Semiformula.Evalb (((partrecCodePayload₁ q : ℕ) : M) :> v) (code (codePartrecPayload₁ d)) := - by - rw [tagSix_canonical_cast (M := M) q hq] at hd - exact - eval_codePartrecPayload₁_canonicalPartrecPrecIndex d (partrecCodePayload₁ q) - (partrecCodePayload₂ q) v hd - -/-- The step payload, read at a standard tag-6 index. -/ -private theorem tagSix_read_payload₂ [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) - (hq : partrecCodeTag q = 6) (v : Fin r → M) - (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : - Semiformula.Evalb (((partrecCodePayload₂ q : ℕ) : M) :> v) (code (codePartrecPayload₂ d)) := - by - rw [tagSix_canonical_cast (M := M) q hq] at hd - exact - eval_codePartrecPayload₂_canonicalPartrecPrecIndex d (partrecCodePayload₁ q) - (partrecCodePayload₂ q) v hd - /-! ### The constructor-6 branch of the eager dispatcher -/ diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/MinimizationPersistence.lean b/LeanPool/PointwiseComposition/FailureOfComposition/MinimizationPersistence.lean index 297d274a3..3eb98c8a2 100644 --- a/LeanPool/PointwiseComposition/FailureOfComposition/MinimizationPersistence.lean +++ b/LeanPool/PointwiseComposition/FailureOfComposition/MinimizationPersistence.lean @@ -37,83 +37,6 @@ namespace Evaluator variable {M : Type*} [ORingStructure M] -private theorem bodd_toNat_eq_mod_two (n : ℕ) : n.bodd.toNat = n % 2 := by - rw [Nat.mod_two_of_bodd] - -/-- The production tag decoder, written with remainders. -/ -private theorem partrecCodeTag_eq (q : ℕ) : - partrecCodeTag q = if q < 4 then q else 4 + 2 * ((q - 4) % 2) + Nat.div2 (q - 4) % 2 := by - simp only [partrecCodeTag, bodd_toNat_eq_mod_two] - -/-- The constructor number of a standard index, read inside a model. -/ -private theorem read_tag [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) (v : Fin r → M) - (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : - Semiformula.Evalb (((partrecCodeTag q : ℕ) : M) :> v) (code (codePartrecTag d)) := - by - have h4 : Semiformula.Evalb (((4 : ℕ) : M) :> v) (code (codeConst (n := r) 4)) := - eval_codeConst 4 v - have h2 : Semiformula.Evalb (((2 : ℕ) : M) :> v) (code (codeConst (n := r) 2)) := - eval_codeConst 2 v - have hrr := eval_codeSub_natCast d (codeConst 4) q 4 v hd (by simpa using h4) - have hbodd0 := eval_codeBodd_natCast (codeSub d (codeConst 4)) (q - 4) v hrr - have hbodd1 := - eval_codeBodd_natCast (codeDiv2 (codeSub d (codeConst 4))) (Nat.div2 (q - 4)) v - (eval_codeDiv2_natCast _ (q - 4) v hrr) - have hmul : - Semiformula.Evalb ((((2 * ((q - 4) % 2) : ℕ)) : M) :> v) - (code (codeMul (codeConst 2) (codeBodd (codeSub d (codeConst 4))))) := - by - refine (eval_codeMul_iff _ _ _ v).mpr ⟨_, _, h2, hbodd0, ?_⟩ - push_cast - norm_num - have hadd1 : - Semiformula.Evalb ((((4 + 2 * ((q - 4) % 2) : ℕ)) : M) :> v) - (code - (codeAdd (codeConst 4) (codeMul (codeConst 2) (codeBodd (codeSub d (codeConst 4)))))) := - by - refine (eval_codeAdd_iff _ _ _ v).mpr ⟨_, _, h4, hmul, ?_⟩ - push_cast - norm_num - have hbig : - Semiformula.Evalb ((((4 + 2 * ((q - 4) % 2) + Nat.div2 (q - 4) % 2 : ℕ)) : M) :> v) - (code - (codeAdd - (codeAdd (codeConst 4) (codeMul (codeConst 2) (codeBodd (codeSub d (codeConst 4))))) - (codeBodd (codeDiv2 (codeSub d (codeConst 4)))))) := - by - refine (eval_codeAdd_iff _ _ _ v).mpr ⟨_, _, hadd1, hbodd1, ?_⟩ - push_cast - norm_num - rw [partrecCodeTag_eq] - simp only [codePartrecTag] - by_cases hq : q < 4 - · have hlt1 : Semiformula.Evalb ((1 : M) :> v) (code (codeLt d (codeConst 4))) := - by - refine (eval_codeLt_iff _ _ _ v).mpr ⟨_, _, hd, by simpa using h4, Or.inl ⟨?_, rfl⟩⟩ - exact_mod_cast hq - rw [ite_eq_left hq] - exact - eval_codeIfPos_of _ _ _ (1 : M) (((q : ℕ)) : M) _ _ v hlt1 hd hbig - (Or.inl ⟨_root_.zero_lt_one, rfl⟩) - · have hlt0 : Semiformula.Evalb ((0 : M) :> v) (code (codeLt d (codeConst 4))) := - by - refine (eval_codeLt_iff _ _ _ v).mpr ⟨_, _, hd, by simpa using h4, Or.inr ⟨?_, rfl⟩⟩ - intro hc - exact hq (by exact_mod_cast hc) - rw [ite_eq_right hq] - exact eval_codeIfPos_of _ _ _ (0 : M) (((q : ℕ)) : M) _ _ v hlt0 hd hbig (Or.inr ⟨rfl, rfl⟩) - -/-- The payload of a standard compound index, read inside a model. -/ -private theorem read_payload [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) (v : Fin r → M) - (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : - Semiformula.Evalb (((partrecCodePayload q : ℕ) : M) :> v) (code (codePartrecPayload d)) := - by - have h4 : Semiformula.Evalb (((4 : ℕ) : M) :> v) (code (codeConst (n := r) 4)) := - eval_codeConst 4 v - have hrr := eval_codeSub_natCast d (codeConst 4) q 4 v hd (by simpa using h4) - simpa only [codePartrecPayload, partrecCodePayload] using - eval_codeDiv2_natCast _ _ v (eval_codeDiv2_natCast _ (q - 4) v hrr) - private theorem min_succ_pred [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : M} (hk : 0 < k) : k - 1 + 1 = k := FFL.FirstOrder.Arithmetic.sub_add_self_of_le (FFL.FirstOrder.Arithmetic.one_le_of_zero_lt k hk) @@ -298,11 +221,11 @@ theorem evalnCertificateFormula_tag_seven_iff [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M have hn : Semiformula.Evalb (u :> ![s, ((q : ℕ) : M), u]) (code min_input) := (eval_proj_iff _ _ _).mpr rfl have hi := eval_codeEvaluatorCell_index s ((q : ℕ) : M) u - have hp := read_payload min_index q ![s, ((q : ℕ) : M), u] hi + have hp := eval_codePartrecPayload_natCast min_index q ![s, ((q : ℕ) : M), u] hi have htag : Semiformula.Evalb ((7 : M) :> ![s, ((q : ℕ) : M), u]) (code (codePartrecTag min_index)) := by - have h := read_tag min_index q ![s, ((q : ℕ) : M), u] hi + have h := eval_codePartrecTag_natCast min_index q ![s, ((q : ℕ) : M), u] hi simpa only [hq, Nat.cast_ofNat] using h have hprev : s - 1 < s := by have h := lt_add_one (s - 1) From 41af0fb76917d5266637fb96a04cbea03d541c6d Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Mon, 19 Oct 2026 18:27:59 +0000 Subject: [PATCH 3/5] Share graph congruence proofs and cut-free inversion --- .../ArithmeticCode/EvaluationCongruence.lean | 124 +++++--- .../Evaluator/CellCongruence.lean | 269 ---------------- .../PrimitiveRecursionPersistence.lean | 22 +- .../ConcreteRecursionGraph.lean | 299 ------------------ .../GeneratedSoundness.lean | 15 - .../PiOneExtensionality.lean | 3 +- .../Foundation/FirstOrder/LK/CutFree.lean | 112 +++---- 7 files changed, 137 insertions(+), 707 deletions(-) diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/EvaluationCongruence.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/EvaluationCongruence.lean index ad41b8d4b..3d28e6fa9 100644 --- a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/EvaluationCongruence.lean +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/EvaluationCongruence.lean @@ -384,48 +384,55 @@ attached to remainder, unpairing or `codeBeta`; each is delta-reduced as a synta tree. No arithmetic theory is assumed. -/ /-- Two codes have the same graph, each under its own assignment. -/ -private abbrev EvalEq {k l : ℕ} (A : Code k) (v : Fin k → M) (A' : Code l) (v' : Fin l → M) : +abbrev EvalEq {k l : ℕ} (A : Code k) (v : Fin k → M) (A' : Code l) (v' : Fin l → M) : Prop := ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v') (code A') -private theorem evalEq_proj {k l : ℕ} (i : Fin k) (j : Fin l) (v : Fin k → M) (v' : Fin l → M) +/-- Projections agree when the selected assignment entries agree. -/ +theorem evalEq_proj {k l : ℕ} (i : Fin k) (j : Fin l) (v : Fin k → M) (v' : Fin l → M) (h : v i = v' j) : EvalEq (Code.proj i) v (Code.proj j) v' := by intro x rw [eval_proj_iff, eval_proj_iff, h] -private theorem evalEq_zero {k l : ℕ} (v : Fin k → M) (v' : Fin l → M) : +/-- Zero codes have the same graph under any two assignments. -/ +theorem evalEq_zero {k l : ℕ} (v : Fin k → M) (v' : Fin l → M) : EvalEq (Code.zero k) v (Code.zero l) v' := by intro x rw [eval_zero_iff, eval_zero_iff] -private theorem evalEq_codeHead {k l : ℕ} (t : M) (v : Fin k → M) (v' : Fin l → M) : +/-- Head codes agree under assignments with the same head. -/ +theorem evalEq_codeHead {k l : ℕ} (t : M) (v : Fin k → M) (v' : Fin l → M) : EvalEq (codeHead (n := k)) (t :> v) (codeHead (n := l)) (t :> v') := evalEq_proj 0 0 _ _ rfl -private theorem evalEq_codeSucc {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} +/-- Successor-code construction preserves heterogeneous graph agreement. -/ +theorem evalEq_codeSucc {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} {v' : Fin l → M} (hA : EvalEq A v A' v') : EvalEq (codeSucc A) v (codeSucc A') v' := by intro x rw [eval_codeSucc_iff, eval_codeSucc_iff] exact exists_congr fun a => and_congr (hA a) Iff.rfl -private theorem evalEq_codePos {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} +/-- Positive-test code construction preserves heterogeneous graph agreement. -/ +theorem evalEq_codePos {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} {v' : Fin l → M} (hA : EvalEq A v A' v') : EvalEq (codePos A) v (codePos A') v' := by intro x rw [eval_codePos_iff, eval_codePos_iff] exact exists_congr fun a => and_congr (hA a) Iff.rfl -private theorem evalEq_codeInv {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} +/-- Boolean-inverse code construction preserves heterogeneous graph agreement. -/ +theorem evalEq_codeInv {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} {v' : Fin l → M} (hA : EvalEq A v A' v') : EvalEq (codeInv A) v (codeInv A') v' := by intro x rw [eval_codeInv_iff, eval_codeInv_iff] exact exists_congr fun a => and_congr (hA a) Iff.rfl -private theorem evalEq_codeAdd {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} +/-- Addition-code construction preserves heterogeneous graph agreement. -/ +theorem evalEq_codeAdd {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : EvalEq (codeAdd A B) v (codeAdd A' B') v' := by @@ -433,7 +440,8 @@ private theorem evalEq_codeAdd {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : rw [eval_codeAdd_iff, eval_codeAdd_iff] exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) -private theorem evalEq_codeMul {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} +/-- Multiplication-code construction preserves heterogeneous graph agreement. -/ +theorem evalEq_codeMul {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : EvalEq (codeMul A B) v (codeMul A' B') v' := by @@ -441,7 +449,8 @@ private theorem evalEq_codeMul {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : rw [eval_codeMul_iff, eval_codeMul_iff] exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) -private theorem evalEq_codeEq {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} +/-- Equality-test code construction preserves heterogeneous graph agreement. -/ +theorem evalEq_codeEq {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : EvalEq (codeEq A B) v (codeEq A' B') v' := by @@ -449,7 +458,8 @@ private theorem evalEq_codeEq {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : F rw [eval_codeEq_iff, eval_codeEq_iff] exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) -private theorem evalEq_codeLt {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} +/-- Order-test code construction preserves heterogeneous graph agreement. -/ +theorem evalEq_codeLt {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : EvalEq (codeLt A B) v (codeLt A' B') v' := by @@ -457,7 +467,8 @@ private theorem evalEq_codeLt {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : F rw [eval_codeLt_iff, eval_codeLt_iff] exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) -private theorem evalEq_codeAnd {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} +/-- Conjunction-code construction preserves heterogeneous graph agreement. -/ +theorem evalEq_codeAnd {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : EvalEq (codeAnd A B) v (codeAnd A' B') v' := by @@ -465,7 +476,8 @@ private theorem evalEq_codeAnd {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : rw [eval_codeAnd_iff, eval_codeAnd_iff] exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) -private theorem evalEq_codeOr {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} +/-- Disjunction-code construction preserves heterogeneous graph agreement. -/ +theorem evalEq_codeOr {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : EvalEq (codeOr A B) v (codeOr A' B') v' := by @@ -474,7 +486,7 @@ private theorem evalEq_codeOr {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : F exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) /-- A lift ignores its head, so the two heads need not agree. -/ -private theorem evalEq_codeLift {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} +theorem evalEq_codeLift {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} {v' : Fin l → M} (t t' : M) (hA : EvalEq A v A' v') : EvalEq (codeLift A) (t :> v) (codeLift A') (t' :> v') := by @@ -482,32 +494,50 @@ private theorem evalEq_codeLift {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin rw [eval_codeLift_iff, eval_codeLift_iff] exact hA x -/-- The raw search, across two arities and assignments. -/ -private theorem eval_rfind_congr_at {k l : ℕ} (c : Code (k + 1)) (c' : Code (l + 1)) (z : M) - (v : Fin k → M) (v' : Fin l → M) - (h : - ∀ x t : M, - Semiformula.Evalb (x :> t :> v) (code c) ↔ Semiformula.Evalb (x :> t :> v') (code c')) : - Semiformula.Evalb (z :> v) (code (Code.rfind c)) ↔ - Semiformula.Evalb (z :> v') (code (Code.rfind c')) := +/-- One codes have the same graph under any two assignments. -/ +theorem evalEq_one {k l : ℕ} (v : Fin k → M) (v' : Fin l → M) : + EvalEq (Code.one k) v (Code.one l) v' := by intro x; rw [eval_one_iff, eval_one_iff] + +/-- Composition with a shared outer code. -/ +theorem evalEq_comp {k l m : ℕ} (c : Code m) (ds : Fin m → Code k) + (ds' : Fin m → Code l) {v : Fin k → M} {v' : Fin l → M} + (h : ∀ i, EvalEq (ds i) v (ds' i) v') : EvalEq (c.comp ds) v (c.comp ds') v' := + by + intro x + rw [eval_comp_iff, eval_comp_iff] + constructor + · rintro ⟨w, hw, hwi⟩; exact ⟨w, hw, fun i => (h i (w i)).mp (hwi i)⟩ + · rintro ⟨w, hw, hwi⟩; exact ⟨w, hw, fun i => (h i (w i)).mpr (hwi i)⟩ + +/-- Constant codes agree under assignments of any arities. -/ +theorem evalEq_codeConst {k l : ℕ} (m : ℕ) (v : Fin k → M) (v' : Fin l → M) : + EvalEq (codeConst (n := k) m) v (codeConst (n := l) m) v' := by + induction m with + | zero => exact evalEq_zero v v' + | succ m ih => exact evalEq_codeSucc ih + +/-- Minimization preserves graph agreement under every extra search input. -/ +theorem evalEq_rfind {k l : ℕ} {A : Code (k + 1)} {A' : Code (l + 1)} {v : Fin k → M} + {v' : Fin l → M} (hA : ∀ t : M, EvalEq A (t :> v) A' (t :> v')) : + EvalEq (Code.rfind A) v (Code.rfind A') v' := by + intro x rw [eval_rfind_iff, eval_rfind_iff] exact - and_congr (h 0 z) + and_congr (hA x 0) (forall_congr' fun t => - imp_congr Iff.rfl (exists_congr fun x => and_congr Iff.rfl (h x t))) + imp_congr Iff.rfl (exists_congr fun y => and_congr Iff.rfl (hA t y))) -private theorem evalEq_codeRfindPos {k l : ℕ} {A : Code (k + 1)} {A' : Code (l + 1)} +/-- Positive-test minimization preserves agreement at every extra search input. -/ +theorem evalEq_codeRfindPos {k l : ℕ} {A : Code (k + 1)} {A' : Code (l + 1)} {v : Fin k → M} {v' : Fin l → M} (hA : ∀ t : M, EvalEq A (t :> v) A' (t :> v')) : EvalEq (codeRfindPos A) v (codeRfindPos A') v' := by - intro x simp only [codeRfindPos] - refine eval_rfind_congr_at _ _ x v v' ?_ - intro y t - exact evalEq_codeInv (evalEq_codePos (hA t)) y + exact evalEq_rfind (fun t => evalEq_codeInv (evalEq_codePos (hA t))) -private theorem evalEq_codeBind {k l : ℕ} {dg : Code k} {dc : Code (k + 1)} {dg' : Code l} +/-- Code binding preserves heterogeneous graph agreement. -/ +theorem evalEq_codeBind {k l : ℕ} {dg : Code k} {dc : Code (k + 1)} {dg' : Code l} {dc' : Code (l + 1)} {v : Fin k → M} {v' : Fin l → M} (hg : EvalEq dg v dg' v') (hc : ∀ t : M, EvalEq dc (t :> v) dc' (t :> v')) : EvalEq (codeBind dg dc) v (codeBind dg' dc') v' := @@ -519,7 +549,8 @@ private theorem evalEq_codeBind {k l : ℕ} {dg : Code k} {dc : Code (k + 1)} {d /-! ### The derived constructors, across two arities and assignments -/ -private theorem evalEq_codeSub {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} +/-- Subtraction-code construction preserves heterogeneous graph agreement. -/ +theorem evalEq_codeSub {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : EvalEq (codeSub A B) v (codeSub A' B') v' := by @@ -532,7 +563,8 @@ private theorem evalEq_codeSub {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : (evalEq_codeAnd (evalEq_codeLt (evalEq_codeLift t t hA) (evalEq_codeLift t t hB)) (evalEq_codeEq (evalEq_codeHead t v v') (evalEq_zero _ _))) -private theorem evalEq_codeSqrt {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} +/-- Square-root-code construction preserves heterogeneous graph agreement. -/ +theorem evalEq_codeSqrt {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} {v' : Fin l → M} (hA : EvalEq A v A' v') : EvalEq (codeSqrt A) v (codeSqrt A') v' := by simp only [codeSqrt] @@ -548,7 +580,8 @@ private theorem evalEq_codeSqrt {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin (evalEq_codeMul (evalEq_codeSucc (evalEq_codeHead t v v')) (evalEq_codeSucc (evalEq_codeHead t v v')))) -private theorem evalEq_codeIfPos {k l : ℕ} {F G H : Code k} {F' G' H' : Code l} {v : Fin k → M} +/-- Conditional-code construction preserves heterogeneous graph agreement. -/ +theorem evalEq_codeIfPos {k l : ℕ} {F G H : Code k} {F' G' H' : Code l} {v : Fin k → M} {v' : Fin l → M} (hF : EvalEq F v F' v') (hG : EvalEq G v G' v') (hH : EvalEq H v H' v') : EvalEq (codeIfPos F G H) v (codeIfPos F' G' H') v' := by @@ -557,14 +590,16 @@ private theorem evalEq_codeIfPos {k l : ℕ} {F G H : Code k} {F' G' H' : Code l evalEq_codeAdd (evalEq_codeMul (evalEq_codePos hF) hG) (evalEq_codeMul (evalEq_codeInv hF) hH) -private theorem evalEq_codeLe {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} +/-- Non-strict order-test code construction preserves heterogeneous graph agreement. -/ +theorem evalEq_codeLe {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : EvalEq (codeLe A B) v (codeLe A' B') v' := by simp only [codeLe] exact evalEq_codeOr (evalEq_codeLt hA hB) (evalEq_codeEq hA hB) -private theorem evalEq_codeUnpair₁ {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} +/-- First-unpairing code construction preserves heterogeneous graph agreement. -/ +theorem evalEq_codeUnpair₁ {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} {v' : Fin l → M} (hA : EvalEq A v A' v') : EvalEq (codeUnpair₁ A) v (codeUnpair₁ A') v' := by simp only [codeUnpair₁] @@ -572,7 +607,8 @@ private theorem evalEq_codeUnpair₁ {k l : ℕ} {A : Code k} {A' : Code l} {v : have hdiff := evalEq_codeSub hA (evalEq_codeMul hsq hsq) exact evalEq_codeIfPos (evalEq_codeLt hdiff hsq) hdiff hsq -private theorem evalEq_codeUnpair₂ {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} +/-- Second-unpairing code construction preserves heterogeneous graph agreement. -/ +theorem evalEq_codeUnpair₂ {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} {v' : Fin l → M} (hA : EvalEq A v A' v') : EvalEq (codeUnpair₂ A) v (codeUnpair₂ A') v' := by simp only [codeUnpair₂] @@ -580,7 +616,18 @@ private theorem evalEq_codeUnpair₂ {k l : ℕ} {A : Code k} {A' : Code l} {v : have hdiff := evalEq_codeSub hA (evalEq_codeMul hsq hsq) exact evalEq_codeIfPos (evalEq_codeLt hdiff hsq) hsq (evalEq_codeSub hdiff hsq) -private theorem evalEq_codeDvd {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} +/-- Pairing-code construction preserves heterogeneous graph agreement. -/ +theorem evalEq_codePair {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : + EvalEq (codePair A B) v (codePair A' B') v' := + by + simp only [codePair] + exact + evalEq_codeIfPos (evalEq_codeLt hA hB) (evalEq_codeAdd (evalEq_codeMul hB hB) hA) + (evalEq_codeAdd (evalEq_codeAdd (evalEq_codeMul hA hA) hA) hB) + +/-- Divisibility-test code construction preserves heterogeneous graph agreement. -/ +theorem evalEq_codeDvd {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : EvalEq (codeDvd A B) v (codeDvd A' B') v' := by @@ -593,7 +640,8 @@ private theorem evalEq_codeDvd {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : (evalEq_codeLt (evalEq_codeLift t t hB) (evalEq_codeHead t v v')) · exact evalEq_codeLe (evalEq_codeHead t v v') (evalEq_codeLift t t hB) -private theorem evalEq_codeRem {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} +/-- Remainder-code construction preserves heterogeneous graph agreement. -/ +theorem evalEq_codeRem {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : EvalEq (codeRem A B) v (codeRem A' B') v' := by diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/CellCongruence.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/CellCongruence.lean index 3d26837f7..4245947e1 100644 --- a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/CellCongruence.lean +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/CellCongruence.lean @@ -43,275 +43,6 @@ open FFL FFL.FirstOrder FFL.FirstOrder.Arithmetic variable {M : Type*} [ORingStructure M] -/-- Two codes have the same graph, each under its own assignment. -/ -private abbrev EvalEq {k l : ℕ} (A : Code k) (v : Fin k → M) (A' : Code l) (v' : Fin l → M) : - Prop := - ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v') (code A') - -/-! -### Primitives -/ - -private theorem evalEq_proj {k l : ℕ} (i : Fin k) (j : Fin l) (v : Fin k → M) (v' : Fin l → M) - (h : v i = v' j) : EvalEq (Code.proj i) v (Code.proj j) v' := by - intro x; - rw [eval_proj_iff, eval_proj_iff, h] - -private theorem evalEq_zero {k l : ℕ} (v : Fin k → M) (v' : Fin l → M) : - EvalEq (Code.zero k) v (Code.zero l) v' := by intro x; rw [eval_zero_iff, eval_zero_iff] - -private theorem evalEq_one {k l : ℕ} (v : Fin k → M) (v' : Fin l → M) : - EvalEq (Code.one k) v (Code.one l) v' := by intro x; rw [eval_one_iff, eval_one_iff] - -private theorem evalEq_codeHead {k l : ℕ} (t : M) (v : Fin k → M) (v' : Fin l → M) : - EvalEq (codeHead (n := k)) (t :> v) (codeHead (n := l)) (t :> v') := - evalEq_proj 0 0 _ _ rfl - -/-- A lift ignores its head, so the two heads need not agree. -/ -private theorem evalEq_codeLift {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} - {v' : Fin l → M} (t t' : M) (hA : EvalEq A v A' v') : - EvalEq (codeLift A) (t :> v) (codeLift A') (t' :> v') := by - intro x; - rw [eval_codeLift_iff, eval_codeLift_iff]; exact hA x - -/-- Composition with a shared outer code. -/ -private theorem evalEq_comp {k l m : ℕ} (c : Code m) (ds : Fin m → Code k) - (ds' : Fin m → Code l) {v : Fin k → M} {v' : Fin l → M} - (h : ∀ i, EvalEq (ds i) v (ds' i) v') : EvalEq (c.comp ds) v (c.comp ds') v' := - by - intro x - rw [eval_comp_iff, eval_comp_iff] - constructor - · rintro ⟨w, hw, hwi⟩; exact ⟨w, hw, fun i => (h i (w i)).mp (hwi i)⟩ - · rintro ⟨w, hw, hwi⟩; exact ⟨w, hw, fun i => (h i (w i)).mpr (hwi i)⟩ - -/-! -### Arithmetic and boolean constructors -/ - -private theorem evalEq_codeSucc {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} - {v' : Fin l → M} (hA : EvalEq A v A' v') : EvalEq (codeSucc A) v (codeSucc A') v' := - by - intro x - rw [eval_codeSucc_iff, eval_codeSucc_iff] - exact exists_congr fun a => and_congr (hA a) Iff.rfl - -private theorem evalEq_codePos {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} - {v' : Fin l → M} (hA : EvalEq A v A' v') : EvalEq (codePos A) v (codePos A') v' := - by - intro x - rw [eval_codePos_iff, eval_codePos_iff] - exact exists_congr fun a => and_congr (hA a) Iff.rfl - -private theorem evalEq_codeInv {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} - {v' : Fin l → M} (hA : EvalEq A v A' v') : EvalEq (codeInv A) v (codeInv A') v' := - by - intro x - rw [eval_codeInv_iff, eval_codeInv_iff] - exact exists_congr fun a => and_congr (hA a) Iff.rfl - -private theorem evalEq_codeAdd {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} - {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : - EvalEq (codeAdd A B) v (codeAdd A' B') v' := - by - intro x - rw [eval_codeAdd_iff, eval_codeAdd_iff] - exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) - -private theorem evalEq_codeMul {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} - {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : - EvalEq (codeMul A B) v (codeMul A' B') v' := - by - intro x - rw [eval_codeMul_iff, eval_codeMul_iff] - exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) - -private theorem evalEq_codeEq {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} - {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : - EvalEq (codeEq A B) v (codeEq A' B') v' := - by - intro x - rw [eval_codeEq_iff, eval_codeEq_iff] - exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) - -private theorem evalEq_codeLt {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} - {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : - EvalEq (codeLt A B) v (codeLt A' B') v' := - by - intro x - rw [eval_codeLt_iff, eval_codeLt_iff] - exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) - -private theorem evalEq_codeAnd {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} - {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : - EvalEq (codeAnd A B) v (codeAnd A' B') v' := - by - intro x - rw [eval_codeAnd_iff, eval_codeAnd_iff] - exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) - -private theorem evalEq_codeOr {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} - {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : - EvalEq (codeOr A B) v (codeOr A' B') v' := - by - intro x - rw [eval_codeOr_iff, eval_codeOr_iff] - exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) - -private theorem evalEq_codeIfPos {k l : ℕ} {A B C : Code k} {A' B' C' : Code l} {v : Fin k → M} - {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') (hC : EvalEq C v C' v') : - EvalEq (codeIfPos A B C) v (codeIfPos A' B' C') v' := - by - simp only [codeIfPos] - exact - evalEq_codeAdd (evalEq_codeMul (evalEq_codePos hA) hB) - (evalEq_codeMul (evalEq_codeInv hA) hC) - -private theorem evalEq_codeConst {k l : ℕ} (m : ℕ) (v : Fin k → M) (v' : Fin l → M) : - EvalEq (codeConst (n := k) m) v (codeConst (n := l) m) v' := by - induction m with - | zero => exact evalEq_zero v v' - | succ m ih => exact evalEq_codeSucc ih - -/-! -### Minimization contexts -/ - -/-- `code` differs from `codeAux` by a renaming that evaluation absorbs. -/ -private theorem evalb_iff_evalf {k : ℕ} (c : Code k) (z : M) (w : Fin k → M) : - Semiformula.Evalb (z :> w) (code c) ↔ Semiformula.Evalf (M := M) (z :> w) (codeAux c) := by - simp [code, Semiformula.eval_rew, Matrix.empty_eq, Function.comp_def] - -/-- Evaluation of a search for a zero, without an arithmetic theory. -/ -private theorem eval_rfind_iff {k : ℕ} (c : Code (k + 1)) (z : M) (v : Fin k → M) : - Semiformula.Evalb (z :> v) (code (Code.rfind c)) ↔ - (Semiformula.Evalb ((0 : M) :> z :> v) (code c) ∧ - ∀ t : M, t < z → ∃ x : M, x ≠ 0 ∧ Semiformula.Evalb (x :> t :> v) (code c)) := - by - simp only [evalb_iff_evalf] - simp [codeAux, Semiformula.eval_rew, Function.comp_def, Matrix.empty_eq, Matrix.comp_vecCons'] - -private theorem evalEq_rfind {k l : ℕ} {A : Code (k + 1)} {A' : Code (l + 1)} {v : Fin k → M} - {v' : Fin l → M} (hA : ∀ t : M, EvalEq A (t :> v) A' (t :> v')) : - EvalEq (Code.rfind A) v (Code.rfind A') v' := - by - intro x - rw [eval_rfind_iff, eval_rfind_iff] - exact - and_congr (hA x 0) - (forall_congr' fun t => - imp_congr Iff.rfl (exists_congr fun y => and_congr Iff.rfl (hA t y))) - -private theorem evalEq_codeRfindPos {k l : ℕ} {A : Code (k + 1)} {A' : Code (l + 1)} - {v : Fin k → M} {v' : Fin l → M} (hA : ∀ t : M, EvalEq A (t :> v) A' (t :> v')) : - EvalEq (codeRfindPos A) v (codeRfindPos A') v' := - by - simp only [codeRfindPos] - exact evalEq_rfind (fun t => evalEq_codeInv (evalEq_codePos (hA t))) - -private theorem evalEq_codeBind {k l : ℕ} {dg : Code k} {dc : Code (k + 1)} {dg' : Code l} - {dc' : Code (l + 1)} {v : Fin k → M} {v' : Fin l → M} (hg : EvalEq dg v dg' v') - (hc : ∀ t : M, EvalEq dc (t :> v) dc' (t :> v')) : - EvalEq (codeBind dg dc) v (codeBind dg' dc') v' := - by - intro x - rw [eval_codeBind_iff, eval_codeBind_iff] - exact exists_congr fun t => and_congr (hg t) (hc t x) - -/-! -### Derived arithmetic -/ - -private theorem evalEq_codeSub {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} - {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : - EvalEq (codeSub A B) v (codeSub A' B') v' := - by - simp only [codeSub] - refine evalEq_codeRfindPos (fun t => ?_) - exact - evalEq_codeOr - (evalEq_codeEq (evalEq_codeAdd (evalEq_codeHead t v v') (evalEq_codeLift t t hB)) - (evalEq_codeLift t t hA)) - (evalEq_codeAnd (evalEq_codeLt (evalEq_codeLift t t hA) (evalEq_codeLift t t hB)) - (evalEq_codeEq (evalEq_codeHead t v v') (evalEq_zero _ _))) - -private theorem evalEq_codeSqrt {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} - {v' : Fin l → M} (hA : EvalEq A v A' v') : EvalEq (codeSqrt A) v (codeSqrt A') v' := - by - simp only [codeSqrt] - refine evalEq_codeRfindPos (fun t => ?_) - exact - evalEq_codeAnd - (evalEq_codeOr - (evalEq_codeLt (evalEq_codeMul (evalEq_codeHead t v v') (evalEq_codeHead t v v')) - (evalEq_codeLift t t hA)) - (evalEq_codeEq (evalEq_codeMul (evalEq_codeHead t v v') (evalEq_codeHead t v v')) - (evalEq_codeLift t t hA))) - (evalEq_codeLt (evalEq_codeLift t t hA) - (evalEq_codeMul (evalEq_codeSucc (evalEq_codeHead t v v')) - (evalEq_codeSucc (evalEq_codeHead t v v')))) - -private theorem evalEq_codeUnpair₁ {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} - {v' : Fin l → M} (hA : EvalEq A v A' v') : EvalEq (codeUnpair₁ A) v (codeUnpair₁ A') v' := - by - simp only [codeUnpair₁] - exact - evalEq_codeIfPos - (evalEq_codeLt - (evalEq_codeSub hA (evalEq_codeMul (evalEq_codeSqrt hA) (evalEq_codeSqrt hA))) - (evalEq_codeSqrt hA)) - (evalEq_codeSub hA (evalEq_codeMul (evalEq_codeSqrt hA) (evalEq_codeSqrt hA))) - (evalEq_codeSqrt hA) - -private theorem evalEq_codeUnpair₂ {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} - {v' : Fin l → M} (hA : EvalEq A v A' v') : EvalEq (codeUnpair₂ A) v (codeUnpair₂ A') v' := - by - simp only [codeUnpair₂] - exact - evalEq_codeIfPos - (evalEq_codeLt - (evalEq_codeSub hA (evalEq_codeMul (evalEq_codeSqrt hA) (evalEq_codeSqrt hA))) - (evalEq_codeSqrt hA)) - (evalEq_codeSqrt hA) - (evalEq_codeSub - (evalEq_codeSub hA (evalEq_codeMul (evalEq_codeSqrt hA) (evalEq_codeSqrt hA))) - (evalEq_codeSqrt hA)) - -private theorem evalEq_codePair {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} - {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : - EvalEq (codePair A B) v (codePair A' B') v' := - by - simp only [codePair] - exact - evalEq_codeIfPos (evalEq_codeLt hA hB) (evalEq_codeAdd (evalEq_codeMul hB hB) hA) - (evalEq_codeAdd (evalEq_codeAdd (evalEq_codeMul hA hA) hA) hB) - -private theorem evalEq_codeLe {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} - {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : - EvalEq (codeLe A B) v (codeLe A' B') v' := - by - simp only [codeLe] - exact evalEq_codeOr (evalEq_codeLt hA hB) (evalEq_codeEq hA hB) - -private theorem evalEq_codeDvd {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} - {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : - EvalEq (codeDvd A B) v (codeDvd A' B') v' := - by - simp only [codeDvd] - refine evalEq_codeBind (evalEq_codeRfindPos (fun t => ?_)) (fun t => ?_) - · exact - evalEq_codeOr - (evalEq_codeEq (evalEq_codeMul (evalEq_codeHead t v v') (evalEq_codeLift t t hA)) - (evalEq_codeLift t t hB)) - (evalEq_codeLt (evalEq_codeLift t t hB) (evalEq_codeHead t v v')) - · exact evalEq_codeLe (evalEq_codeHead t v v') (evalEq_codeLift t t hB) - -private theorem evalEq_codeRem {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} - {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : - EvalEq (codeRem A B) v (codeRem A' B') v' := - by - simp only [codeRem] - refine evalEq_codeRfindPos (fun t => ?_) - exact - evalEq_codeDvd (evalEq_codeLift t t hB) - (evalEq_codeSub (evalEq_codeLift t t hA) (evalEq_codeHead t v v')) - /-! ### The partial-recursive index layer -/ diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/PrimitiveRecursionPersistence.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/PrimitiveRecursionPersistence.lean index 43ac429f7..087c4cf72 100644 --- a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/PrimitiveRecursionPersistence.lean +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/PrimitiveRecursionPersistence.lean @@ -178,7 +178,7 @@ theorem tagSix_read_payload₂ [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : /-- With positive fuel and a tag reading of `6`, the cell value is the value of the primitive-recursion branch. The first comparison of the dispatcher, with `4`, and the second, with `5`, both fail, and the third, with `6`, succeeds. -/ -private theorem tagSix_prec_branch [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (dtable dn : Code r) (v : Fin r → M) +theorem tagSix_prec_branch [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (dtable dn : Code r) (v : Fin r → M) (z k : M) (hk : Semiformula.Evalb (k :> v) (code (codeUnpair₁ (codeListLength dtable)))) (hkpos : 0 < k) (htag : @@ -264,12 +264,12 @@ private theorem tagSix_prec_branch [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} /-- The dispatcher evaluates the branch at the decremented fuel `k - 1`; for positive `k`, its successor, the key of the base lookup, is `k`. -/ -private theorem tagSix_succ_pred [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : M} (hk : 0 < k) : k - 1 + 1 = k := +theorem tagSix_succ_pred [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : M} (hk : 0 < k) : k - 1 + 1 = k := FFL.FirstOrder.Arithmetic.sub_add_self_of_le (FFL.FirstOrder.Arithmetic.one_le_of_zero_lt k hk) /-- The decremented fuel, as the dispatcher computes it. -/ -private theorem tagSix_decremented_fuel [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] +theorem tagSix_decremented_fuel [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] (s qCode u : M) : Semiformula.Evalb ((s - 1) :> ![s, qCode, u]) (code @@ -286,7 +286,7 @@ private theorem tagSix_decremented_fuel [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ (eval_codeEvaluatorCell_fuel s qCode u) hone /-- The key of the base lookup is the fuel. -/ -private theorem tagSix_base_key [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] +theorem tagSix_base_key [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] (s qCode u : M) (hs : 0 < s) : Semiformula.Evalb (s :> ![s, qCode, u]) (code @@ -304,7 +304,8 @@ The branch reads its table, key, query and argument through decoded codes; the history bridges use the fuel key, a constant query and the argument itself. The four congruences below prove that the two forms have the same values. -/ -private theorem tagSix_table_congr [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (s qCode u z x : M) : +/-- The branch table readings agree when the caller argument changes. -/ +theorem tagSix_table_congr [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (s qCode u z x : M) : Semiformula.Evalb (x :> ![s, qCode, u]) (code codeEvaluatorHistoryBeforeCell) ↔ Semiformula.Evalb (x :> ![s, qCode, z]) (code codeEvaluatorHistoryBeforeCell) := by @@ -332,7 +333,8 @@ private theorem tagSix_table_congr [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒ have : w 0 = FFL.FirstOrder.Arithmetic.pair s qCode := eval_unique h0 (hpair z) simpa [this] using hpair u -private theorem tagSix_key_congr [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] +/-- The branch key reading agrees with the source-stage constant. -/ +theorem tagSix_key_congr [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] (s qCode u z : M) (hs : 0 < s) (x : M) : Semiformula.Evalb (x :> ![s, qCode, u]) (code @@ -352,7 +354,8 @@ private theorem tagSix_key_congr [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ rw [hxs] exact tagSix_base_key s qCode u hs -private theorem tagSix_query_congr [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] +/-- The decoded base-program query agrees with its constant index. -/ +theorem tagSix_query_congr [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] (s u z : M) (q : ℕ) (hq : partrecCodeTag q = 6) (x : M) : Semiformula.Evalb (x :> ![s, ((q : ℕ) : M), u]) (code @@ -375,7 +378,8 @@ private theorem tagSix_query_congr [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒ rw [hxv] exact hleft -private theorem tagSix_argument_congr [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (s qCode z x : M) : +/-- The base-program argument agrees with the caller pair first component. -/ +theorem tagSix_argument_congr [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (s qCode z x : M) : Semiformula.Evalb (x :> ![s, qCode, FFL.FirstOrder.Arithmetic.pair z 0]) (code (codeUnpair₁ (Code.proj (2 : Fin 3)))) ↔ Semiformula.Evalb (x :> ![s, qCode, z]) (code (Code.proj (2 : Fin 3))) := @@ -649,7 +653,7 @@ private theorem tagSix_predecessor_argument [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M /-- The step lookup reads the argument `pair z (pair a x)` in the lifted environment, where the intermediate value `x` is the new head. -/ -private theorem tagSix_step_argument [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (s qCode z a x : M) : +theorem tagSix_step_argument [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (s qCode z a x : M) : Semiformula.Evalb ((FFL.FirstOrder.Arithmetic.pair z (FFL.FirstOrder.Arithmetic.pair a x)) :> (x :> ![s, qCode, FFL.FirstOrder.Arithmetic.pair z (a + 1)])) diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteRecursionGraph.lean b/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteRecursionGraph.lean index 8076fd010..b22d63419 100644 --- a/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteRecursionGraph.lean +++ b/LeanPool/PointwiseComposition/FailureOfComposition/ConcreteRecursionGraph.lean @@ -35,305 +35,6 @@ namespace ConcreteEvaluator variable {M : Type*} [ORingStructure M] -/-! -### The constructor-6 branch of the eager dispatcher -/ - -/-- With positive fuel and a tag reading of `6`, the cell value is the value of -the primitive-recursion branch. The first comparison of the dispatcher, with -`4`, and the second, with `5`, both fail, and the third, with `6`, succeeds. -/ -private theorem tagSix_prec_branch [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (dtable dn : Code r) (v : Fin r → M) - (z k : M) (hk : Semiformula.Evalb (k :> v) (code (codeUnpair₁ (codeListLength dtable)))) - (hkpos : 0 < k) - (htag : - Semiformula.Evalb ((6 : M) :> v) - (code (codePartrecTag (codeUnpair₂ (codeListLength dtable))))) - (hcell : Semiformula.Evalb (z :> v) (code (codeEvaluatorCell dtable dn))) : - Semiformula.Evalb (z :> v) - (code - (codePrecEvaluatorCell dtable - (codeSub (codeUnpair₁ (codeListLength dtable)) (codeConst 1)) - (codeUnpair₂ (codeListLength dtable)) - (codePartrecPayload₁ (codeUnpair₂ (codeListLength dtable))) - (codePartrecPayload₂ (codeUnpair₂ (codeListLength dtable))) dn)) := - by - have hconst : - ∀ (m : ℕ) (x : M), - Semiformula.Evalb (x :> v) (code (codeConst (n := r) m)) → x = ((m : ℕ) : M) := - fun m x hx => eval_unique hx (eval_codeConst m v) - have hcast4 : ((4 : ℕ) : M) = (4 : M) := by simp - have hcast5 : ((5 : ℕ) : M) = (5 : M) := by simp - have hcast6 : ((6 : ℕ) : M) = (6 : M) := by simp - have hne64 : ¬((6 : M) = ((4 : ℕ) : M)) := - by - rw [hcast4] - exact fun hc => - absurd hc.symm - (_root_.ne_of_lt - (by - simpa [FFL.FirstOrder.Arithmetic.numeral_eq_natCast] using - (FFL.FirstOrder.Arithmetic.numeral_lt_of_lt (M := M) (by omega : 4 < 6)))) - have hne65 : ¬((6 : M) = ((5 : ℕ) : M)) := - by - rw [hcast5] - exact fun hc => - absurd hc.symm - (_root_.ne_of_lt - (by - simpa [FFL.FirstOrder.Arithmetic.numeral_eq_natCast] using - (FFL.FirstOrder.Arithmetic.numeral_lt_of_lt (M := M) (by omega : 5 < 6)))) - simp only [codeEvaluatorCell] at hcell - obtain ⟨kf, hkf, hkcase⟩ := eval_codeIfPos_cases _ _ _ z v hcell - have hkfk : kf = k := eval_unique hkf hk - rcases hkcase with ⟨-, hafterFuel⟩ | ⟨h0, -⟩ - swap - · exact absurd (hkfk ▸ h0 : k = 0) (ne_of_gt hkpos) - obtain ⟨e4, he4, h4case⟩ := eval_codeIfPos_cases _ _ _ z v hafterFuel - rw [eval_codeEq_iff] at he4 - obtain ⟨a4, b4, ha4, hb4, hc4⟩ := he4 - have ha46 : a4 = (6 : M) := eval_unique ha4 htag - have hb44 : b4 = ((4 : ℕ) : M) := hconst 4 b4 hb4 - have he40 : e4 = 0 := by - rcases hc4 with ⟨heq, -⟩ | ⟨-, h0⟩ - · exact absurd (by rw [← ha46, ← hb44]; exact heq) hne64 - · exact h0 - rcases h4case with ⟨hpos, -⟩ | ⟨-, hafterFour⟩ - · exact absurd (he40 ▸ hpos) (_root_.lt_irrefl 0) - obtain ⟨e5, he5, h5case⟩ := eval_codeIfPos_cases _ _ _ z v hafterFour - rw [eval_codeEq_iff] at he5 - obtain ⟨a5, b5, ha5, hb5, hc5⟩ := he5 - have ha56 : a5 = (6 : M) := eval_unique ha5 htag - have hb55 : b5 = ((5 : ℕ) : M) := hconst 5 b5 hb5 - have he50 : e5 = 0 := by - rcases hc5 with ⟨heq, -⟩ | ⟨-, h0⟩ - · exact absurd (by rw [← ha56, ← hb55]; exact heq) hne65 - · exact h0 - rcases h5case with ⟨hpos, -⟩ | ⟨-, hafterFive⟩ - · exact absurd (he50 ▸ hpos) (_root_.lt_irrefl 0) - obtain ⟨e6, he6, h6case⟩ := eval_codeIfPos_cases _ _ _ z v hafterFive - rw [eval_codeEq_iff] at he6 - obtain ⟨a6, b6, ha6, hb6, hc6⟩ := he6 - have ha66 : a6 = (6 : M) := eval_unique ha6 htag - have hb66 : b6 = ((6 : ℕ) : M) := hconst 6 b6 hb6 - have he61 : e6 = 1 := by - rcases hc6 with ⟨-, h1⟩ | ⟨hne, -⟩ - · exact h1 - · exact absurd (by rw [ha66, hb66, hcast6]) hne - rcases h6case with ⟨-, hprec⟩ | ⟨h0, -⟩ - · exact hprec - · exact absurd (he61 ▸ h0 : (1 : M) = 0) _root_.one_ne_zero - -/-! -### Fuel arithmetic and the readings the branch uses -/ - -/-- The dispatcher evaluates the branch at the decremented fuel `k - 1`; for -positive `k`, its successor, the key of the base lookup, is `k`. -/ -private theorem tagSix_succ_pred [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : M} (hk : 0 < k) : k - 1 + 1 = k := - FFL.FirstOrder.Arithmetic.sub_add_self_of_le - (FFL.FirstOrder.Arithmetic.one_le_of_zero_lt k hk) - -/-- The decremented fuel, as the dispatcher computes it. -/ -private theorem tagSix_decremented_fuel [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] - (s qCode u : M) : - Semiformula.Evalb ((s - 1) :> ![s, qCode, u]) - (code - (codeSub (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell)) - (codeConst 1))) := - by - have hone : Semiformula.Evalb ((1 : M) :> ![s, qCode, u]) (code (codeConst (n := 3) 1)) := - by - have h := eval_codeConst (M := M) (k := 3) 1 ![s, qCode, u] - have hcast : (((1 : ℕ)) : M) = (1 : M) := by simp - rwa [hcast] at h - exact - eval_codeSub _ (codeConst 1) s (1 : M) ![s, qCode, u] - (eval_codeEvaluatorCell_fuel s qCode u) hone - -/-- The key of the base lookup is the fuel. -/ -private theorem tagSix_base_key [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] - (s qCode u : M) (hs : 0 < s) : - Semiformula.Evalb (s :> ![s, qCode, u]) - (code - (codeSucc - (codeSub (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell)) - (codeConst 1)))) := - by - refine (eval_codeSucc_iff _ _ _).mpr ⟨s - 1, tagSix_decremented_fuel s qCode u, ?_⟩ - exact (tagSix_succ_pred hs).symm - -/-! -### Relating the base lookup of the branch to the history bridges - -The branch reads its table, key, query and argument through decoded codes; the -history bridges use the fuel key, a constant query and the argument itself. The -four congruences below prove that the two forms have the same values. -/ - -private theorem tagSix_table_congr [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (s qCode u z x : M) : - Semiformula.Evalb (x :> ![s, qCode, u]) (code codeEvaluatorHistoryBeforeCell) ↔ - Semiformula.Evalb (x :> ![s, qCode, z]) (code codeEvaluatorHistoryBeforeCell) := - by - have hpair : - ∀ c : M, - Semiformula.Evalb (FFL.FirstOrder.Arithmetic.pair s qCode :> ![s, qCode, c]) - (code (codePair (Code.proj (0 : Fin 3)) (Code.proj (1 : Fin 3)))) := - fun c => - eval_codePair _ _ s qCode ![s, qCode, c] ((eval_proj_iff _ _ _).mpr rfl) - ((eval_proj_iff _ _ _).mpr rfl) - rw [codeEvaluatorHistoryBeforeCell, eval_comp_iff, eval_comp_iff] - constructor - · rintro ⟨w, hw, hcomp⟩ - refine ⟨w, hw, ?_⟩ - intro i - refine Fin.cases ?_ (fun j => Fin.elim0 j) i - have h0 := hcomp 0 - have : w 0 = FFL.FirstOrder.Arithmetic.pair s qCode := eval_unique h0 (hpair u) - simpa [this] using hpair z - · rintro ⟨w, hw, hcomp⟩ - refine ⟨w, hw, ?_⟩ - intro i - refine Fin.cases ?_ (fun j => Fin.elim0 j) i - have h0 := hcomp 0 - have : w 0 = FFL.FirstOrder.Arithmetic.pair s qCode := eval_unique h0 (hpair z) - simpa [this] using hpair u - -private theorem tagSix_key_congr [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] - (s qCode u z : M) (hs : 0 < s) (x : M) : - Semiformula.Evalb (x :> ![s, qCode, u]) - (code - (codeSucc - (codeSub (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell)) - (codeConst 1)))) ↔ - Semiformula.Evalb (x :> ![s, qCode, z]) - (code (codeUnpair₁ (codeListLength codeEvaluatorHistoryBeforeCell))) := - by - constructor - · intro hx - have hxs : x = s := eval_unique hx (tagSix_base_key s qCode u hs) - rw [hxs] - exact eval_codeEvaluatorCell_fuel s qCode z - · intro hx - have hxs : x = s := eval_unique hx (eval_codeEvaluatorCell_fuel s qCode z) - rw [hxs] - exact tagSix_base_key s qCode u hs - -private theorem tagSix_query_congr [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] - (s u z : M) (q : ℕ) (hq : partrecCodeTag q = 6) (x : M) : - Semiformula.Evalb (x :> ![s, ((q : ℕ) : M), u]) - (code - (codePartrecPayload₁ (codeUnpair₂ (codeListLength codeEvaluatorHistoryBeforeCell)))) ↔ - Semiformula.Evalb (x :> ![s, ((q : ℕ) : M), z]) - (code (codeConst (n := 3) (partrecCodePayload₁ q))) := - by - have hleft := tagSix_read_payload₁ _ q hq _ (eval_codeEvaluatorCell_index s ((q : ℕ) : M) u) - have hright : - Semiformula.Evalb (((partrecCodePayload₁ q : ℕ) : M) :> ![s, ((q : ℕ) : M), z]) - (code (codeConst (n := 3) (partrecCodePayload₁ q))) := - eval_codeConst _ ![s, ((q : ℕ) : M), z] - constructor - · intro hx - have hxv : x = ((partrecCodePayload₁ q : ℕ) : M) := eval_unique hx hleft - rw [hxv] - exact hright - · intro hx - have hxv : x = ((partrecCodePayload₁ q : ℕ) : M) := eval_unique hx hright - rw [hxv] - exact hleft - -private theorem tagSix_argument_congr [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (s qCode z x : M) : - Semiformula.Evalb (x :> ![s, qCode, FFL.FirstOrder.Arithmetic.pair z 0]) - (code (codeUnpair₁ (Code.proj (2 : Fin 3)))) ↔ - Semiformula.Evalb (x :> ![s, qCode, z]) (code (Code.proj (2 : Fin 3))) := - by - have hleft : - Semiformula.Evalb (z :> ![s, qCode, FFL.FirstOrder.Arithmetic.pair z 0]) - (code (codeUnpair₁ (Code.proj (2 : Fin 3)))) := - by - have h := - eval_codeUnpair₁ (Code.proj (2 : Fin 3)) (FFL.FirstOrder.Arithmetic.pair z 0) - ![s, qCode, FFL.FirstOrder.Arithmetic.pair z 0] ((eval_proj_iff _ _ _).mpr rfl) - rwa [FFL.FirstOrder.Arithmetic.pi₁_pair] at h - have hright : Semiformula.Evalb (z :> ![s, qCode, z]) (code (Code.proj (2 : Fin 3))) := - (eval_proj_iff _ _ _).mpr rfl - constructor - · intro hx - have hxz : x = z := eval_unique hx hleft - rw [hxz] - exact hright - · intro hx - have hxz : x = z := eval_unique hx hright - rw [hxz] - exact hleft - -/-- The predecessor lookup reads the argument `pair z a` from `pair z (a + 1)`. -/ -private theorem tagSix_predecessor_argument [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] - (s qCode z a : M) : - Semiformula.Evalb - ((FFL.FirstOrder.Arithmetic.pair z a) :> - ![s, qCode, FFL.FirstOrder.Arithmetic.pair z (a + 1)]) - (code - (codePair (codeUnpair₁ (Code.proj (2 : Fin 3))) - (codeSub (codeUnpair₂ (Code.proj (2 : Fin 3))) (codeConst 1)))) := - by - let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) - have hproj : - Semiformula.Evalb - (FFL.FirstOrder.Arithmetic.pair z (a + 1) :> - ![s, qCode, FFL.FirstOrder.Arithmetic.pair z (a + 1)]) - (code (Code.proj (2 : Fin 3))) := - (eval_proj_iff _ _ _).mpr rfl - have h1 := eval_codeUnpair₁ (Code.proj (2 : Fin 3)) _ _ hproj - rw [FFL.FirstOrder.Arithmetic.pi₁_pair] at h1 - have h2 := eval_codeUnpair₂ (Code.proj (2 : Fin 3)) _ _ hproj - rw [FFL.FirstOrder.Arithmetic.pi₂_pair] at h2 - have hone : - Semiformula.Evalb ((1 : M) :> ![s, qCode, FFL.FirstOrder.Arithmetic.pair z (a + 1)]) - (code (codeConst (n := 3) 1)) := - by rw [eval_codeConst_iff]; simp - have h3 := eval_codeSub _ (codeConst 1) (a + 1) 1 _ h2 hone - rw [add_sub_self] at h3 - exact eval_codePair _ _ z a _ h1 h3 - -/-- The step lookup reads the argument `pair z (pair a x)` in the lifted -environment, where the intermediate value `x` is the new head. -/ -private theorem tagSix_step_argument [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (s qCode z a x : M) : - Semiformula.Evalb - ((FFL.FirstOrder.Arithmetic.pair z (FFL.FirstOrder.Arithmetic.pair a x)) :> - (x :> ![s, qCode, FFL.FirstOrder.Arithmetic.pair z (a + 1)])) - (code - (codePair (codeLift (codeUnpair₁ (Code.proj (2 : Fin 3)))) - (codePair (codeLift (codeSub (codeUnpair₂ (Code.proj (2 : Fin 3))) (codeConst 1))) - (codeHead (n := 3))))) := - by - let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) - have hproj : - Semiformula.Evalb - (FFL.FirstOrder.Arithmetic.pair z (a + 1) :> - ![s, qCode, FFL.FirstOrder.Arithmetic.pair z (a + 1)]) - (code (Code.proj (2 : Fin 3))) := - (eval_proj_iff _ _ _).mpr rfl - have h1 := eval_codeUnpair₁ (Code.proj (2 : Fin 3)) _ _ hproj - rw [FFL.FirstOrder.Arithmetic.pi₁_pair] at h1 - have h2 := eval_codeUnpair₂ (Code.proj (2 : Fin 3)) _ _ hproj - rw [FFL.FirstOrder.Arithmetic.pi₂_pair] at h2 - have hone : - Semiformula.Evalb ((1 : M) :> ![s, qCode, FFL.FirstOrder.Arithmetic.pair z (a + 1)]) - (code (codeConst (n := 3) 1)) := - by rw [eval_codeConst_iff]; simp - have h3 := eval_codeSub _ (codeConst 1) (a + 1) 1 _ h2 hone - rw [add_sub_self] at h3 - have hz : - Semiformula.Evalb (z :> (x :> ![s, qCode, FFL.FirstOrder.Arithmetic.pair z (a + 1)])) - (code (codeLift (codeUnpair₁ (Code.proj (2 : Fin 3))))) := - (eval_codeLift_iff _ _ _ _).mpr h1 - have ha : - Semiformula.Evalb (a :> (x :> ![s, qCode, FFL.FirstOrder.Arithmetic.pair z (a + 1)])) - (code (codeLift (codeSub (codeUnpair₂ (Code.proj (2 : Fin 3))) (codeConst 1)))) := - (eval_codeLift_iff _ _ _ _).mpr h3 - have hx : - Semiformula.Evalb (x :> (x :> ![s, qCode, FFL.FirstOrder.Arithmetic.pair z (a + 1)])) - (code (codeHead (n := 3))) := - (eval_codeHead_iff _ _).mpr rfl - exact eval_codePair _ _ z _ _ hz (eval_codePair _ _ a x _ ha hx) - /-- At a positive stage, zero-argument primitive recursion is the base program, with the caller's argument bound imposed by the concrete evaluator. -/ theorem evaln_tag_six_zero_iff [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] (q : ℕ) diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/GeneratedSoundness.lean b/LeanPool/PointwiseComposition/FailureOfComposition/GeneratedSoundness.lean index 65931719d..f3aa28101 100644 --- a/LeanPool/PointwiseComposition/FailureOfComposition/GeneratedSoundness.lean +++ b/LeanPool/PointwiseComposition/FailureOfComposition/GeneratedSoundness.lean @@ -50,21 +50,6 @@ theorem sigmaOneSound_iff_nonempty_soundOnHierarchy (T : ArithmeticTheory) : · rintro ⟨h⟩ σ hσ hp exact h.sound hp hσ -private theorem ground_proof_of_pointwise (T : ArithmeticTheory) [𝐏𝐀 ≼ T] (F G : Graph) - (hFG : Pointwise T F G) (n m : ℕ) (hF : F.val.Evalb ![n, m]) : T ⊢ graphInstance G n m := - by - have hpF : T ⊢ graphInstance F n m := WeakerThan.pbl (true_graph_instance_provable F n m hF) - apply complete.{0} T - intro M _ _ - have : M↓[ℒₒᵣ] ⊧* 𝐏𝐀 := models_of_subtheory (U := T) inferInstance - have : M↓[ℒₒᵣ] ⊧* 𝐈Σ₁ := models_of_subtheory (U := 𝐏𝐀) inferInstance - have hEq : M↓[ℒₒᵣ] ⊧ eqAt F G n := - consequence_iff.mp (Theory.Proof.sound (hFG n)) M inferInstance - have hVal : M↓[ℒₒᵣ] ⊧ graphInstance F n m := - consequence_iff.mp (Theory.Proof.sound hpF) M inferInstance - simp only [models_iff, eqAt_eval] at hEq - simp only [models_iff, graphInstance_eval] at hVal ⊢ - exact (hEq (m : M)).mp hVal /-- Sigma-one soundness turns each pointwise proof into equality of standard graphs, without assuming that either graph is functional. -/ diff --git a/LeanPool/PointwiseComposition/FailureOfComposition/PiOneExtensionality.lean b/LeanPool/PointwiseComposition/FailureOfComposition/PiOneExtensionality.lean index 691df3990..b8f5f33d0 100644 --- a/LeanPool/PointwiseComposition/FailureOfComposition/PiOneExtensionality.lean +++ b/LeanPool/PointwiseComposition/FailureOfComposition/PiOneExtensionality.lean @@ -76,7 +76,8 @@ theorem true_graph_instance_provable (F : Graph) (n m : ℕ) (h : F.val.Evalb ![ apply sigma_one_completeness (graphInstance_sigma_one F n m) simpa only [models_iff, graphInstance_eval, natCast_nat] using h -private theorem ground_proof_of_pointwise (T : ArithmeticTheory) [𝐏𝐀 ≼ T] (F G : Graph) +/-- Pointwise provability transports a true ground graph instance to a proof in the theory. -/ +theorem ground_proof_of_pointwise (T : ArithmeticTheory) [𝐏𝐀 ≼ T] (F G : Graph) (hFG : Pointwise T F G) (n m : ℕ) (hF : F.val.Evalb ![n, m]) : T ⊢ graphInstance G n m := by have hpF : T ⊢ graphInstance F n m := WeakerThan.pbl (true_graph_instance_provable F n m hF) diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/CutFree.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/CutFree.lean index a36449374..47d141078 100644 --- a/LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/CutFree.lean +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/LK/CutFree.lean @@ -48,91 +48,59 @@ attribute [simp] IsCutFree.identity IsCutFree.verum variable {Γ Δ : LK.Sequent L} -@[simp] -lemma isCutFree_or_iff {d : ⊢ᴸᴷ¹ Γ + ⦃φ, ψ⦄} : IsCutFree d.or ↔ IsCutFree d := - by +-- One characterization avoids repeated dependent elimination through quotient-indexed contexts. +private def cutFreeStep {Γ : LK.Sequent L} : (⊢ᴸᴷ¹ Γ) → Prop + | .identity _ _ => True + | .verum => True + | .or d => IsCutFree d + | .and d e => IsCutFree d ∧ IsCutFree e + | .all d => IsCutFree d + | .exs d => IsCutFree d + | .contraction d => IsCutFree d + | .weakening d => IsCutFree d + | .cut _ _ => False + +private theorem isCutFree_iff_step {Γ : LK.Sequent L} (d : ⊢ᴸᴷ¹ Γ) : + IsCutFree d ↔ cutFreeStep d := by constructor · intro h - refine - h.rec (motive := fun {_} d _ ↦ - match d with - | .or d => IsCutFree d - | _ => True) - ?_ ?_ ?_ ?_ ?_ ?_ ?_ ?_ - all_goals simp_all - · exact .or + induction h <;> first | exact True.intro | assumption | constructor <;> assumption + · intro h + cases d with + | identity r v => exact .identity r v + | verum => exact .verum + | or d => exact .or h + | and d e => exact .and h.1 h.2 + | all d => exact .all h + | exs d => exact .exs _ h + | contraction d => exact .contraction h + | weakening d => exact .weakening h + | cut d e => exact False.elim h + +@[simp] +lemma isCutFree_or_iff {d : ⊢ᴸᴷ¹ Γ + ⦃φ, ψ⦄} : IsCutFree d.or ↔ IsCutFree d := + isCutFree_iff_step d.or @[simp] lemma isCutFree_and_iff {dφ : ⊢ᴸᴷ¹ Γ + ⦃φ⦄} {dψ : ⊢ᴸᴷ¹ Γ + ⦃ψ⦄} : IsCutFree (dφ.and dψ) ↔ IsCutFree dφ ∧ IsCutFree dψ := - by - constructor - · rintro h - refine - h.rec (motive := fun {_} d _ ↦ - match d with - | .and dφ dψ => IsCutFree dφ ∧ IsCutFree dψ - | _ => True) - ?_ ?_ ?_ ?_ ?_ ?_ ?_ ?_ - all_goals simp_all - · rintro ⟨hφ, hψ⟩ - exact hφ.and hψ + isCutFree_iff_step (dφ.and dψ) @[simp] lemma isCutFree_all_iff {d : ⊢ᴸᴷ¹ Γ⁺ + ⦃Rewriting.free φ⦄} : IsCutFree d.all ↔ IsCutFree d := - by - constructor - · intro h - refine - h.rec (motive := fun {_} d _ ↦ - match d with - | .all d => IsCutFree d - | _ => True) - ?_ ?_ ?_ ?_ ?_ ?_ ?_ ?_ - all_goals simp_all - · exact .all + isCutFree_iff_step d.all @[simp] lemma isCutFree_exs_iff {d : ⊢ᴸᴷ¹ Γ + ⦃φ/[t]⦄} : IsCutFree d.exs ↔ IsCutFree d := - by - constructor - · intro h - refine - h.rec (motive := fun {_} d _ ↦ - match d with - | .exs d => IsCutFree d - | _ => True) - ?_ ?_ ?_ ?_ ?_ ?_ ?_ ?_ - all_goals simp_all - · exact .exs t + isCutFree_iff_step d.exs @[simp] lemma isCutFree_contraction_iff {d : ⊢ᴸᴷ¹ Γ + ⦃φ, φ⦄} : IsCutFree d.contraction ↔ IsCutFree d := - by - constructor - · intro h - refine - h.rec (motive := fun {_} d _ ↦ - match d with - | .contraction d => IsCutFree d - | _ => True) - ?_ ?_ ?_ ?_ ?_ ?_ ?_ ?_ - all_goals simp_all - · exact .contraction + isCutFree_iff_step d.contraction @[simp] lemma isCutFree_weakening_iff {d : ⊢ᴸᴷ¹ Γ} : IsCutFree (d.weakening (φ := φ)) ↔ IsCutFree d := - by - constructor; - · intro h; - refine - h.rec (motive := fun {_} d _ ↦ - match d with - | .weakening d => IsCutFree d - | _ => True) - ?_ ?_ ?_ ?_ ?_ ?_ ?_ ?_; - all_goals simp_all; - · exact .weakening; + isCutFree_iff_step (d.weakening (φ := φ)) @[simp] lemma IsCutFree.cast {d : ⊢ᴸᴷ¹ Γ} {e : Γ = Δ} : IsCutFree (.cast d e) ↔ IsCutFree d := by @@ -140,15 +108,7 @@ lemma IsCutFree.cast {d : ⊢ᴸᴷ¹ Γ} {e : Γ = Δ} : IsCutFree (.cast d e) @[simp] lemma IsCutFree.not_cut (dp : ⊢ᴸᴷ¹ Γ + ⦃φ⦄) (dn : ⊢ᴸᴷ¹ Δ + ⦃∼φ⦄) : ¬IsCutFree (dp.cut dn) := - by - intro h - refine - h.rec (motive := fun {_} d _ ↦ - match d with - | .cut _ _ => False - | _ => True) - ?_ ?_ ?_ ?_ ?_ ?_ ?_ ?_ - all_goals simp + (isCutFree_iff_step (dp.cut dn)).mp @[simp] lemma isCutFree_rewrite_iff_isCutFree {f : ℕ → SyntacticTerm L} {d : ⊢ᴸᴷ¹ Γ} : From f5169e0d6d5db196c6f27ffd0ed09ce0edabe934 Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Mon, 19 Oct 2026 20:16:32 +0000 Subject: [PATCH 4/5] Share evaluator decoders, graph proofs, and structural induction --- .../ArithmeticCode/EncodedListEvaluation.lean | 58 +---- .../ArithmeticCode/NumeralEvaluation.lean | 112 +++++++++ .../ArithmeticCode/RecursionEvaluation.lean | 46 ++-- .../Evaluator/CellEvaluation.lean | 20 +- .../Evaluator/CompositionDispatch.lean | 73 +----- .../PrimitiveRecursionPersistence.lean | 33 +-- .../PrimitiveRecursionStructuralBridges.lean | 217 ++++-------------- .../CanonicalComposition.lean | 94 ++------ .../Syntax/Formula/Functions.lean | 180 ++++++--------- 9 files changed, 286 insertions(+), 547 deletions(-) diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/EncodedListEvaluation.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/EncodedListEvaluation.lean index 49fa0dc31..5edde5bb5 100644 --- a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/EncodedListEvaluation.lean +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/EncodedListEvaluation.lean @@ -185,30 +185,11 @@ private theorem definable_code_head_slot {m : ℕ} (A : Code (m + 1)) (out : M) (par : Fin m → M) : Σ-[1].DefinablePred (fun c : M => Semiformula.Evalb (out :> c :> par) (code A)) := by - refine - ⟨HierarchySymbol.Semiformula.mkSigma - ((Rew.embSubsts - ((&out : Semiterm ℒₒᵣ M 1) :> - (#0 : Semiterm ℒₒᵣ M 1) :> fun j => (&(par j) : Semiterm ℒₒᵣ M 1))) ▹ - (code A)) - (Hierarchy.rew _ (code_sigma_one A)), - ?_⟩ - intro w - simp only [HierarchySymbol.Semiformula.val_mkSigma, Semiformula.eval_embSubsts] - have hv : - (Semiterm.val w id ∘ - ((&out : Semiterm ℒₒᵣ M 1) :> - (#0 : Semiterm ℒₒᵣ M 1) :> fun j => (&(par j) : Semiterm ℒₒᵣ M 1))) = - (out :> w 0 :> par) := - by - funext j - refine Fin.cases ?_ ?_ j - · simp - · intro j1 - refine Fin.cases ?_ ?_ j1 - · simp - · intro j2; simp - rw [hv] + simpa only [Nat.succ_eq_add_one, Fin.isValue, Function.comp_def, Matrix.comp_vecCons', + Semiterm.val_fvar, id_eq, Semiterm.val_bvar] using + definable_code_graph_arguments A + ((&out : Semiterm ℒₒᵣ M 1) :> + (#0 : Semiterm ℒₒᵣ M 1) :> fun j => (&(par j) : Semiterm ℒₒᵣ M 1)) open HierarchySymbol in /-- Varying the output and the first argument of the graph formula of a code, @@ -216,30 +197,11 @@ with the remaining arguments fixed as parameters, is a Sigma-one condition. -/ private theorem definable_code_out_head_slot {m : ℕ} (A : Code (m + 1)) (par : Fin m → M) : Σ-[1].Definable (fun w : Fin 2 → M => Semiformula.Evalb (w 0 :> w 1 :> par) (code A)) := by - refine - ⟨HierarchySymbol.Semiformula.mkSigma - ((Rew.embSubsts - ((#0 : Semiterm ℒₒᵣ M 2) :> - (#1 : Semiterm ℒₒᵣ M 2) :> fun j => (&(par j) : Semiterm ℒₒᵣ M 2))) ▹ - (code A)) - (Hierarchy.rew _ (code_sigma_one A)), - ?_⟩ - intro w - simp only [HierarchySymbol.Semiformula.val_mkSigma, Semiformula.eval_embSubsts] - have hv : - (Semiterm.val w id ∘ - ((#0 : Semiterm ℒₒᵣ M 2) :> - (#1 : Semiterm ℒₒᵣ M 2) :> fun j => (&(par j) : Semiterm ℒₒᵣ M 2))) = - (w 0 :> w 1 :> par) := - by - funext j - refine Fin.cases ?_ ?_ j - · simp - · intro j1 - refine Fin.cases ?_ ?_ j1 - · simp - · intro j2; simp - rw [hv] + simpa only [Nat.succ_eq_add_one, Fin.isValue, Function.comp_def, Matrix.comp_vecCons', + Semiterm.val_fvar, id_eq, Semiterm.val_bvar] using + definable_code_graph_arguments A + ((#0 : Semiterm ℒₒᵣ M 2) :> + (#1 : Semiterm ℒₒᵣ M 2) :> fun j => (&(par j) : Semiterm ℒₒᵣ M 2)) /-! ### The iterated tail decreases -/ diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/NumeralEvaluation.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/NumeralEvaluation.lean index c42372595..bd1f9a719 100644 --- a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/NumeralEvaluation.lean +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/NumeralEvaluation.lean @@ -1162,6 +1162,118 @@ theorem eval_codeBeta_of_values [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] {k : simp only [codeBeta] exact eval_codeRem _ _ _ _ v h1 hsucc +/-- The eager conditional has a value once its test and both of its branches +have one. Both branches are evaluated whichever way the test goes. -/ +theorem eval_codeIfPos_exists [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {n : ℕ} (df dg dh : Code n) + (v : Fin n → M) (hf : ∃ f : M, Semiformula.Evalb (f :> v) (code df)) + (hg : ∃ g : M, Semiformula.Evalb (g :> v) (code dg)) + (hh : ∃ h : M, Semiformula.Evalb (h :> v) (code dh)) : + ∃ z : M, Semiformula.Evalb (z :> v) (code (codeIfPos df dg dh)) := + by + obtain ⟨f, hf⟩ := hf + obtain ⟨g, hg⟩ := hg + obtain ⟨h, hh⟩ := hh + by_cases hpos : 0 < f + · exact ⟨g, eval_codeIfPos_of _ _ _ f g h g v hf hg hh (Or.inl ⟨hpos, rfl⟩)⟩ + · exact + ⟨h, + eval_codeIfPos_of _ _ _ f g h h v hf hg hh + (Or.inr ⟨le_antisymm (not_lt.mp hpos) (by simp), rfl⟩)⟩ + +namespace IndexDecoder + +/-- The parity bit as a remainder. -/ +private theorem bodd_toNat_eq_mod_two (n : ℕ) : n.bodd.toNat = n % 2 := by + rw [Nat.mod_two_of_bodd] + +/-- The production tag decoder, written with remainders. -/ +theorem partrecCodeTag_eq (q : ℕ) : + partrecCodeTag q = if q < 4 then q else 4 + 2 * ((q - 4) % 2) + Nat.div2 (q - 4) % 2 := by + simp only [partrecCodeTag, bodd_toNat_eq_mod_two] + +/-- The constructor number of a standard index, read inside a model. -/ +theorem eval_codePartrecTag_natCast [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) + (v : Fin r → M) (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : + Semiformula.Evalb (((partrecCodeTag q : ℕ) : M) :> v) (code (codePartrecTag d)) := + by + have h4 : Semiformula.Evalb (((4 : ℕ) : M) :> v) (code (codeConst (n := r) 4)) := + eval_codeConst 4 v + have h2 : Semiformula.Evalb (((2 : ℕ) : M) :> v) (code (codeConst (n := r) 2)) := + eval_codeConst 2 v + have hrr := eval_codeSub_natCast d (codeConst 4) q 4 v hd (by simpa using h4) + have hbodd0 := eval_codeBodd_natCast (codeSub d (codeConst 4)) (q - 4) v hrr + have hbodd1 := + eval_codeBodd_natCast (codeDiv2 (codeSub d (codeConst 4))) (Nat.div2 (q - 4)) v + (eval_codeDiv2_natCast _ (q - 4) v hrr) + have hmul : + Semiformula.Evalb ((((2 * ((q - 4) % 2) : ℕ)) : M) :> v) + (code (codeMul (codeConst 2) (codeBodd (codeSub d (codeConst 4))))) := + by + refine (eval_codeMul_iff _ _ _ v).mpr ⟨_, _, h2, hbodd0, ?_⟩ + push_cast + norm_num + have hadd1 : + Semiformula.Evalb ((((4 + 2 * ((q - 4) % 2) : ℕ)) : M) :> v) + (code + (codeAdd (codeConst 4) (codeMul (codeConst 2) (codeBodd (codeSub d (codeConst 4)))))) := + by + refine (eval_codeAdd_iff _ _ _ v).mpr ⟨_, _, h4, hmul, ?_⟩ + push_cast + norm_num + have hbig : + Semiformula.Evalb ((((4 + 2 * ((q - 4) % 2) + Nat.div2 (q - 4) % 2 : ℕ)) : M) :> v) + (code + (codeAdd + (codeAdd (codeConst 4) (codeMul (codeConst 2) (codeBodd (codeSub d (codeConst 4))))) + (codeBodd (codeDiv2 (codeSub d (codeConst 4)))))) := + by + refine (eval_codeAdd_iff _ _ _ v).mpr ⟨_, _, hadd1, hbodd1, ?_⟩ + push_cast + norm_num + rw [partrecCodeTag_eq] + simp only [codePartrecTag] + by_cases hq : q < 4 + · have hlt1 : Semiformula.Evalb ((1 : M) :> v) (code (codeLt d (codeConst 4))) := + by + refine (eval_codeLt_iff _ _ _ v).mpr ⟨_, _, hd, by simpa using h4, Or.inl ⟨?_, rfl⟩⟩ + exact_mod_cast hq + rw [ite_eq_left hq] + exact + eval_codeIfPos_of _ _ _ (1 : M) (((q : ℕ)) : M) _ _ v hlt1 hd hbig + (Or.inl ⟨_root_.zero_lt_one, rfl⟩) + · have hlt0 : Semiformula.Evalb ((0 : M) :> v) (code (codeLt d (codeConst 4))) := + by + refine (eval_codeLt_iff _ _ _ v).mpr ⟨_, _, hd, by simpa using h4, Or.inr ⟨?_, rfl⟩⟩ + intro hc + exact hq (by exact_mod_cast hc) + rw [ite_eq_right hq] + exact eval_codeIfPos_of _ _ _ (0 : M) (((q : ℕ)) : M) _ _ v hlt0 hd hbig (Or.inr ⟨rfl, rfl⟩) + +/-- The payload of a standard compound index, read inside a model. -/ +theorem eval_codePartrecPayload_natCast [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) + (v : Fin r → M) (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : + Semiformula.Evalb (((partrecCodePayload q : ℕ) : M) :> v) (code (codePartrecPayload d)) := + by + have h4 : Semiformula.Evalb (((4 : ℕ) : M) :> v) (code (codeConst (n := r) 4)) := + eval_codeConst 4 v + have hrr := eval_codeSub_natCast d (codeConst 4) q 4 v hd (by simpa using h4) + simpa only [codePartrecPayload, partrecCodePayload] using + eval_codeDiv2_natCast _ _ v (eval_codeDiv2_natCast _ (q - 4) v hrr) + +/-- The first subcode of a standard index, read inside a model. -/ +theorem eval_codePartrecPayload₁_natCast [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) + (v : Fin r → M) (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : + Semiformula.Evalb (((partrecCodePayload₁ q : ℕ) : M) :> v) (code (codePartrecPayload₁ d)) := + eval_codeUnpair₁_natCast (codePartrecPayload d) _ v (eval_codePartrecPayload_natCast d q v hd) + +/-- The second subcode of a standard index, read inside a model. -/ +theorem eval_codePartrecPayload₂_natCast [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) + (v : Fin r → M) (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : + Semiformula.Evalb (((partrecCodePayload₂ q : ℕ) : M) :> v) (code (codePartrecPayload₂ d)) := + eval_codeUnpair₂_natCast (codePartrecPayload d) _ v (eval_codePartrecPayload_natCast d q v hd) + +end IndexDecoder + end ArithmeticCode end CategoricalRiceShapiro diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/RecursionEvaluation.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/RecursionEvaluation.lean index b882f7b6e..305ebd063 100644 --- a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/RecursionEvaluation.lean +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/RecursionEvaluation.lean @@ -1659,6 +1659,17 @@ private theorem beta_to_pair [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {l : ℕ} (N' I' /-! ### Sigma-one definability of a literal code graph in two argument slots -/ +open HierarchySymbol in +/-- Substituting terms with model parameters into a code graph preserves Sigma-one definability. -/ +theorem definable_code_graph_arguments {k n : ℕ} (A : Code k) + (arguments : Fin (k + 1) → Semiterm ℒₒᵣ M n) : + Σ-[1].Definable (fun w : Fin n → M => + Semiformula.Evalb (Semiterm.val w id ∘ arguments) (code A)) := by + refine ⟨HierarchySymbol.Semiformula.mkSigma ((Rew.embSubsts arguments) ▹ code A) + (Hierarchy.rew _ (code_sigma_one A)), ?_⟩ + intro w + simp only [HierarchySymbol.Semiformula.val_mkSigma, Semiformula.eval_embSubsts] + open HierarchySymbol in /-- Varying the first two arguments of the graph formula of a code, with the output and the remaining arguments fixed as parameters, is a Sigma-one @@ -1668,35 +1679,12 @@ private theorem definable_code_two_slots {m : ℕ} (A : Code (m + 2)) (out : M) Σ-[1].Definable (fun w : Fin 2 → M => Semiformula.Evalb (out :> w 0 :> w 1 :> par) (code A)) := by - refine - ⟨HierarchySymbol.Semiformula.mkSigma - ((Rew.embSubsts - ((&out : Semiterm ℒₒᵣ M 2) :> - (#0 : Semiterm ℒₒᵣ M 2) :> - (#1 : Semiterm ℒₒᵣ M 2) :> fun j => (&(par j) : Semiterm ℒₒᵣ M 2))) ▹ - (code A)) - (Hierarchy.rew _ (code_sigma_one A)), - ?_⟩ - intro w - simp only [HierarchySymbol.Semiformula.val_mkSigma, Semiformula.eval_embSubsts] - have hv : - (Semiterm.val w id ∘ - ((&out : Semiterm ℒₒᵣ M 2) :> - (#0 : Semiterm ℒₒᵣ M 2) :> - (#1 : Semiterm ℒₒᵣ M 2) :> fun j => (&(par j) : Semiterm ℒₒᵣ M 2))) = - (out :> w 0 :> w 1 :> par) := - by - funext j - refine Fin.cases ?_ ?_ j - · simp - · intro j1 - refine Fin.cases ?_ ?_ j1 - · simp - · intro j2 - refine Fin.cases ?_ ?_ j2 - · simp - · intro j3; simp - rw [hv] + simpa only [Nat.succ_eq_add_one, Fin.isValue, Function.comp_def, Matrix.comp_vecCons', + Semiterm.val_fvar, id_eq, Semiterm.val_bvar] using + definable_code_graph_arguments A + ((&out : Semiterm ℒₒᵣ M 2) :> + (#0 : Semiterm ℒₒᵣ M 2) :> + (#1 : Semiterm ℒₒᵣ M 2) :> fun j => (&(par j) : Semiterm ℒₒᵣ M 2)) open HierarchySymbol in /-- Existence of a history at which a literal code graph holds is a Sigma-one diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/CellEvaluation.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/CellEvaluation.lean index 2fd02987b..1ad5acba9 100644 --- a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/CellEvaluation.lean +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/CellEvaluation.lean @@ -231,24 +231,6 @@ theorem eval_codeCompEvaluatorCell_succ_iff [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] { /-! ### Totality of an evaluator cell -/ -/-- The eager conditional has a value once its test and both of its branches -have one. Both branches are evaluated whichever way the test goes. -/ -private theorem eval_codeIfPos_exists [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {n : ℕ} (df dg dh : Code n) - (v : Fin n → M) (hf : ∃ f : M, Semiformula.Evalb (f :> v) (code df)) - (hg : ∃ g : M, Semiformula.Evalb (g :> v) (code dg)) - (hh : ∃ h : M, Semiformula.Evalb (h :> v) (code dh)) : - ∃ z : M, Semiformula.Evalb (z :> v) (code (codeIfPos df dg dh)) := - by - obtain ⟨f, hf⟩ := hf - obtain ⟨g, hg⟩ := hg - obtain ⟨h, hh⟩ := hh - by_cases hpos : 0 < f - · exact ⟨g, eval_codeIfPos_of _ _ _ f g h g v hf hg hh (Or.inl ⟨hpos, rfl⟩)⟩ - · exact - ⟨h, - eval_codeIfPos_of _ _ _ f g h h v hf hg hh - (Or.inr ⟨le_antisymm (not_lt.mp hpos) (by simp), rfl⟩)⟩ - /-- The characteristic value of an equality exists once both sides have one. -/ private theorem eval_codeEq_exists [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {n : ℕ} (A B : Code n) (a b : M) (v : Fin n → M) (hA : Semiformula.Evalb (a :> v) (code A)) @@ -363,7 +345,7 @@ private theorem eval_codeCompEvaluatorCell_exists [M↓[ℒₒᵣ] ⊧* 𝐏𝐀 /-- The primitive-recursion cell has a value. Both arms of its eager conditional are evaluated: the step lookup with its continuation, and the base lookup. -/ -private theorem eval_codePrecEvaluatorCell_exists [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] {r : ℕ} +theorem eval_codePrecEvaluatorCell_exists [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] {r : ℕ} (dtable dk' dq dcf dcg dn : Code r) (table k' qv cf cg index : M) (v : Fin r → M) (htable : Semiformula.Evalb (table :> v) (code dtable)) (hk' : Semiformula.Evalb (k' :> v) (code dk')) (hq : Semiformula.Evalb (qv :> v) (code dq)) diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/CompositionDispatch.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/CompositionDispatch.lean index 6a0a47228..bd7ea6e31 100644 --- a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/CompositionDispatch.lean +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/CompositionDispatch.lean @@ -385,95 +385,36 @@ theorem eval_codeEvaluatorCell_succ_of_component_lookups {M : Type*} [ORingStruc variable {M : Type*} [ORingStructure M] -/-- The parity bit as a remainder. -/ -private theorem bodd_toNat_eq_mod_two (n : ℕ) : n.bodd.toNat = n % 2 := by - rw [Nat.mod_two_of_bodd] +-- Keep the existing evaluator names for clients of the relocated arithmetic API. /-- The production tag decoder, written with remainders. -/ theorem partrecCodeTag_eq (q : ℕ) : - partrecCodeTag q = if q < 4 then q else 4 + 2 * ((q - 4) % 2) + Nat.div2 (q - 4) % 2 := by - simp only [partrecCodeTag, bodd_toNat_eq_mod_two] + partrecCodeTag q = if q < 4 then q else 4 + 2 * ((q - 4) % 2) + Nat.div2 (q - 4) % 2 := + IndexDecoder.partrecCodeTag_eq q /-- The constructor number of a standard index, read inside a model. -/ theorem eval_codePartrecTag_natCast [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) (v : Fin r → M) (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : Semiformula.Evalb (((partrecCodeTag q : ℕ) : M) :> v) (code (codePartrecTag d)) := - by - have h4 : Semiformula.Evalb (((4 : ℕ) : M) :> v) (code (codeConst (n := r) 4)) := - eval_codeConst 4 v - have h2 : Semiformula.Evalb (((2 : ℕ) : M) :> v) (code (codeConst (n := r) 2)) := - eval_codeConst 2 v - have hrr := eval_codeSub_natCast d (codeConst 4) q 4 v hd (by simpa using h4) - have hbodd0 := eval_codeBodd_natCast (codeSub d (codeConst 4)) (q - 4) v hrr - have hbodd1 := - eval_codeBodd_natCast (codeDiv2 (codeSub d (codeConst 4))) (Nat.div2 (q - 4)) v - (eval_codeDiv2_natCast _ (q - 4) v hrr) - have hmul : - Semiformula.Evalb ((((2 * ((q - 4) % 2) : ℕ)) : M) :> v) - (code (codeMul (codeConst 2) (codeBodd (codeSub d (codeConst 4))))) := - by - refine (eval_codeMul_iff _ _ _ v).mpr ⟨_, _, h2, hbodd0, ?_⟩ - push_cast - norm_num - have hadd1 : - Semiformula.Evalb ((((4 + 2 * ((q - 4) % 2) : ℕ)) : M) :> v) - (code - (codeAdd (codeConst 4) (codeMul (codeConst 2) (codeBodd (codeSub d (codeConst 4)))))) := - by - refine (eval_codeAdd_iff _ _ _ v).mpr ⟨_, _, h4, hmul, ?_⟩ - push_cast - norm_num - have hbig : - Semiformula.Evalb ((((4 + 2 * ((q - 4) % 2) + Nat.div2 (q - 4) % 2 : ℕ)) : M) :> v) - (code - (codeAdd - (codeAdd (codeConst 4) (codeMul (codeConst 2) (codeBodd (codeSub d (codeConst 4))))) - (codeBodd (codeDiv2 (codeSub d (codeConst 4)))))) := - by - refine (eval_codeAdd_iff _ _ _ v).mpr ⟨_, _, hadd1, hbodd1, ?_⟩ - push_cast - norm_num - rw [partrecCodeTag_eq] - simp only [codePartrecTag] - by_cases hq : q < 4 - · have hlt1 : Semiformula.Evalb ((1 : M) :> v) (code (codeLt d (codeConst 4))) := - by - refine (eval_codeLt_iff _ _ _ v).mpr ⟨_, _, hd, by simpa using h4, Or.inl ⟨?_, rfl⟩⟩ - exact_mod_cast hq - rw [ite_eq_left hq] - exact - eval_codeIfPos_of _ _ _ (1 : M) (((q : ℕ)) : M) _ _ v hlt1 hd hbig - (Or.inl ⟨_root_.zero_lt_one, rfl⟩) - · have hlt0 : Semiformula.Evalb ((0 : M) :> v) (code (codeLt d (codeConst 4))) := - by - refine (eval_codeLt_iff _ _ _ v).mpr ⟨_, _, hd, by simpa using h4, Or.inr ⟨?_, rfl⟩⟩ - intro hc - exact hq (by exact_mod_cast hc) - rw [ite_eq_right hq] - exact eval_codeIfPos_of _ _ _ (0 : M) (((q : ℕ)) : M) _ _ v hlt0 hd hbig (Or.inr ⟨rfl, rfl⟩) + IndexDecoder.eval_codePartrecTag_natCast d q v hd /-- The payload of a standard compound index, read inside a model. -/ theorem eval_codePartrecPayload_natCast [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) (v : Fin r → M) (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : Semiformula.Evalb (((partrecCodePayload q : ℕ) : M) :> v) (code (codePartrecPayload d)) := - by - have h4 : Semiformula.Evalb (((4 : ℕ) : M) :> v) (code (codeConst (n := r) 4)) := - eval_codeConst 4 v - have hrr := eval_codeSub_natCast d (codeConst 4) q 4 v hd (by simpa using h4) - simpa only [codePartrecPayload, partrecCodePayload] using - eval_codeDiv2_natCast _ _ v (eval_codeDiv2_natCast _ (q - 4) v hrr) + IndexDecoder.eval_codePartrecPayload_natCast d q v hd /-- The first subcode of a standard index, read inside a model. -/ theorem eval_codePartrecPayload₁_natCast [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) (v : Fin r → M) (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : Semiformula.Evalb (((partrecCodePayload₁ q : ℕ) : M) :> v) (code (codePartrecPayload₁ d)) := - eval_codeUnpair₁_natCast (codePartrecPayload d) _ v (eval_codePartrecPayload_natCast d q v hd) + IndexDecoder.eval_codePartrecPayload₁_natCast d q v hd /-- The second subcode of a standard index, read inside a model. -/ theorem eval_codePartrecPayload₂_natCast [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (q : ℕ) (v : Fin r → M) (hd : Semiformula.Evalb (((q : ℕ) : M) :> v) (code d)) : Semiformula.Evalb (((partrecCodePayload₂ q : ℕ) : M) :> v) (code (codePartrecPayload₂ d)) := - eval_codeUnpair₂_natCast (codePartrecPayload d) _ v (eval_codePartrecPayload_natCast d q v hd) + IndexDecoder.eval_codePartrecPayload₂_natCast d q v hd /-- A successful evaluator cell whose constructor number is `4` is the value of the pairing branch. Adapted from the accepted external tag-4 probe. -/ diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/PrimitiveRecursionPersistence.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/PrimitiveRecursionPersistence.lean index 087c4cf72..7f6be0b89 100644 --- a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/PrimitiveRecursionPersistence.lean +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/PrimitiveRecursionPersistence.lean @@ -620,36 +620,7 @@ theorem evalnCertificateFormula_natCode_persist_of_tag_six_zero [M↓[ℒₒᵣ] target_history /-! -### The two argument readings of the successor branch -/ - -/-- The predecessor lookup reads the argument `pair z a` from `pair z (a + 1)`. -/ -private theorem tagSix_predecessor_argument [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] - (s qCode z a : M) : - Semiformula.Evalb - ((FFL.FirstOrder.Arithmetic.pair z a) :> - ![s, qCode, FFL.FirstOrder.Arithmetic.pair z (a + 1)]) - (code - (codePair (codeUnpair₁ (Code.proj (2 : Fin 3))) - (codeSub (codeUnpair₂ (Code.proj (2 : Fin 3))) (codeConst 1)))) := - by - let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) - have hproj : - Semiformula.Evalb - (FFL.FirstOrder.Arithmetic.pair z (a + 1) :> - ![s, qCode, FFL.FirstOrder.Arithmetic.pair z (a + 1)]) - (code (Code.proj (2 : Fin 3))) := - (eval_proj_iff _ _ _).mpr rfl - have h1 := eval_codeUnpair₁ (Code.proj (2 : Fin 3)) _ _ hproj - rw [FFL.FirstOrder.Arithmetic.pi₁_pair] at h1 - have h2 := eval_codeUnpair₂ (Code.proj (2 : Fin 3)) _ _ hproj - rw [FFL.FirstOrder.Arithmetic.pi₂_pair] at h2 - have hone : - Semiformula.Evalb ((1 : M) :> ![s, qCode, FFL.FirstOrder.Arithmetic.pair z (a + 1)]) - (code (codeConst (n := 3) 1)) := - by rw [eval_codeConst_iff]; simp - have h3 := eval_codeSub _ (codeConst 1) (a + 1) 1 _ h2 hone - rw [add_sub_self] at h3 - exact eval_codePair _ _ z a _ h1 h3 +### The step argument of the successor branch -/ /-- The step lookup reads the argument `pair z (pair a x)` in the lifted environment, where the intermediate value `x` is the new head. -/ @@ -829,7 +800,7 @@ theorem evalnCertificateFormula_natCode_persist_of_tag_six_succ_step [M↓[ℒ (FFL.FirstOrder.Arithmetic.pair_lt_pair_left htpred_lt _) hHt (tagSix_decremented_fuel t ((q : ℕ) : M) u) hidx_t - (tagSix_predecessor_argument t ((q : ℕ) : M) z a)).mpr + (eval_prec_predecessor_argument t ((q : ℕ) : M) z a)).mpr hist_pred_tgt have hpayload₂_lt : partrecCodePayload₂ q < q := (partrecCodePayloads_lt_of_tag_six q hq).2 have hrow_step : diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/PrimitiveRecursionStructuralBridges.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/PrimitiveRecursionStructuralBridges.lean index 0eda69e9d..71dabce70 100644 --- a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/PrimitiveRecursionStructuralBridges.lean +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/Evaluator/PrimitiveRecursionStructuralBridges.lean @@ -182,15 +182,8 @@ theorem eval_codePartrecPayload_canonicalPartrecPrecIndex {M : Type*} [ORingStru (hd : Semiformula.Evalb ((canonicalPartrecPrecIndex fCode gCode : M) :> v) (code d)) : Semiformula.Evalb (((Nat.pair fCode gCode : ℕ) : M) :> v) (code (codePartrecPayload d)) := by - have hrr := - eval_codeSub_natCast d (codeConst 4) (canonicalPartrecPrecIndex fCode gCode) 4 v hd - (by simpa using eval_codeConst (M := M) 4 v) - have hq2 := eval_codeDiv2_natCast _ _ v (eval_codeDiv2_natCast _ _ v hrr) - have hval : - Nat.div2 (Nat.div2 (canonicalPartrecPrecIndex fCode gCode - 4)) = Nat.pair fCode gCode := - partrecCodePayload_canonicalPartrecPrecIndex fCode gCode - rw [hval] at hq2 - simpa only [codePartrecPayload] using hq2 + simpa only [partrecCodePayload_canonicalPartrecPrecIndex] using + IndexDecoder.eval_codePartrecPayload_natCast d (canonicalPartrecPrecIndex fCode gCode) v hd /-- The constructor number of the canonical primitive-recursion index, read inside a model: it is `6`, the number of primitive recursion. -/ @@ -199,90 +192,29 @@ theorem eval_codePartrecTag_canonicalPartrecPrecIndex {M : Type*} [ORingStructur (hd : Semiformula.Evalb ((canonicalPartrecPrecIndex fCode gCode : M) :> v) (code d)) : Semiformula.Evalb ((6 : M) :> v) (code (codePartrecTag d)) := by - set c := canonicalPartrecPrecIndex fCode gCode with hcdef - have hceq : c = 2 * (2 * Nat.pair fCode gCode) + 1 + 4 := - canonicalPartrecPrecIndex_eq fCode gCode - have hsub : c - 4 = 2 * (2 * Nat.pair fCode gCode) + 1 := by rw [hceq]; omega - have hnlt : ¬c < 4 := by rw [hceq]; omega - have hb1 : (c - 4) % 2 = 1 := by rw [hsub]; omega - have hd2 : Nat.div2 (c - 4) = 2 * Nat.pair fCode gCode := - by - rw [hsub] - simp only [Nat.div2_val] - omega - have hb0 : Nat.div2 (c - 4) % 2 = 0 := by rw [hd2]; omega - have h4 : Semiformula.Evalb (((4 : ℕ) : M) :> v) (code (codeConst (n := r) 4)) := - eval_codeConst 4 v - have h2 : Semiformula.Evalb (((2 : ℕ) : M) :> v) (code (codeConst (n := r) 2)) := - eval_codeConst 2 v - have hrr := eval_codeSub_natCast d (codeConst 4) c 4 v hd (by simpa using h4) - have hboddLow : - Semiformula.Evalb (((1 : ℕ) : M) :> v) (code (codeBodd (codeSub d (codeConst 4)))) := - by - have := eval_codeBodd_natCast _ (c - 4) v hrr - rwa [hb1] at this - have hboddHigh : - Semiformula.Evalb (((0 : ℕ) : M) :> v) - (code (codeBodd (codeDiv2 (codeSub d (codeConst 4))))) := - by - have := eval_codeBodd_natCast _ (Nat.div2 (c - 4)) v (eval_codeDiv2_natCast _ (c - 4) v hrr) - rwa [hb0] at this - have hmul : - Semiformula.Evalb ((((2 * 1 : ℕ)) : M) :> v) - (code (codeMul (codeConst 2) (codeBodd (codeSub d (codeConst 4))))) := - by - refine (eval_codeMul_iff _ _ _ _).mpr ⟨_, _, h2, hboddLow, ?_⟩ - push_cast - norm_num - have hadd1 : - Semiformula.Evalb ((((4 + 2 * 1 : ℕ)) : M) :> v) - (code - (codeAdd (codeConst 4) (codeMul (codeConst 2) (codeBodd (codeSub d (codeConst 4)))))) := - by - refine (eval_codeAdd_iff _ _ _ _).mpr ⟨_, _, h4, hmul, ?_⟩ - push_cast - norm_num - have hbig : - Semiformula.Evalb ((((4 + 2 * 1 + 0 : ℕ)) : M) :> v) - (code - (codeAdd - (codeAdd (codeConst 4) (codeMul (codeConst 2) (codeBodd (codeSub d (codeConst 4))))) - (codeBodd (codeDiv2 (codeSub d (codeConst 4)))))) := - by - refine (eval_codeAdd_iff _ _ _ _).mpr ⟨_, _, hadd1, hboddHigh, ?_⟩ - push_cast - norm_num - have hsix : (((4 + 2 * 1 + 0 : ℕ)) : M) = (6 : M) := by norm_num - rw [hsix] at hbig - have hlt0 : Semiformula.Evalb ((0 : M) :> v) (code (codeLt d (codeConst 4))) := - by - refine (eval_codeLt_iff _ _ _ _).mpr ⟨_, _, hd, by simpa using h4, Or.inr ⟨?_, rfl⟩⟩ - intro hc - have : c < 4 := by exact_mod_cast hc - exact hnlt this - simp only [codePartrecTag] - exact - eval_codeIfPos_of _ _ _ (0 : M) ((c : ℕ) : M) (6 : M) _ v hlt0 hd hbig (Or.inr ⟨rfl, rfl⟩) + simpa only [Nat.succ_eq_add_one, canonicalPartrecPrecIndex_constructor_number, + Nat.cast_ofNat] using + IndexDecoder.eval_codePartrecTag_natCast d (canonicalPartrecPrecIndex fCode gCode) v hd /-- The base subcode of the canonical primitive-recursion index, read inside a model. -/ theorem eval_codePartrecPayload₁_canonicalPartrecPrecIndex {M : Type*} [ORingStructure M] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (fCode gCode : ℕ) (v : Fin r → M) (hd : Semiformula.Evalb ((canonicalPartrecPrecIndex fCode gCode : M) :> v) (code d)) : - Semiformula.Evalb (((fCode : ℕ) : M) :> v) (code (codePartrecPayload₁ d)) := by - simpa only [codePartrecPayload₁, Nat.unpair_pair] using - eval_codeUnpair₁_natCast (M := M) (codePartrecPayload d) (Nat.pair fCode gCode) v - (eval_codePartrecPayload_canonicalPartrecPrecIndex d fCode gCode v hd) + Semiformula.Evalb (((fCode : ℕ) : M) :> v) (code (codePartrecPayload₁ d)) := + by + simpa only [canonicalPartrecPrecIndex_base_index] using + IndexDecoder.eval_codePartrecPayload₁_natCast d (canonicalPartrecPrecIndex fCode gCode) v hd /-- The step subcode of the canonical primitive-recursion index, read inside a model. -/ theorem eval_codePartrecPayload₂_canonicalPartrecPrecIndex {M : Type*} [ORingStructure M] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (fCode gCode : ℕ) (v : Fin r → M) (hd : Semiformula.Evalb ((canonicalPartrecPrecIndex fCode gCode : M) :> v) (code d)) : - Semiformula.Evalb (((gCode : ℕ) : M) :> v) (code (codePartrecPayload₂ d)) := by - simpa only [codePartrecPayload₂, Nat.unpair_pair] using - eval_codeUnpair₂_natCast (M := M) (codePartrecPayload d) (Nat.pair fCode gCode) v - (eval_codePartrecPayload_canonicalPartrecPrecIndex d fCode gCode v hd) + Semiformula.Evalb (((gCode : ℕ) : M) :> v) (code (codePartrecPayload₂ d)) := + by + simpa only [canonicalPartrecPrecIndex_step_index] using + IndexDecoder.eval_codePartrecPayload₂_natCast d (canonicalPartrecPrecIndex fCode gCode) v hd end PartialRecursive end CategoricalRiceShapiro @@ -303,67 +235,6 @@ open Nat.ArithPart₁ variable {M : Type*} [ORingStructure M] -/-- The eager conditional has a value once its test and both branches have one. -/ -private theorem precProbe_ifPos_exists [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {n : ℕ} (df dg dh : Code n) - (v : Fin n → M) (hf : ∃ f : M, Semiformula.Evalb (f :> v) (code df)) - (hg : ∃ g : M, Semiformula.Evalb (g :> v) (code dg)) - (hh : ∃ h : M, Semiformula.Evalb (h :> v) (code dh)) : - ∃ z : M, Semiformula.Evalb (z :> v) (code (codeIfPos df dg dh)) := - by - obtain ⟨f, hf⟩ := hf - obtain ⟨g, hg⟩ := hg - obtain ⟨h, hh⟩ := hh - by_cases hpos : 0 < f - · exact ⟨g, eval_codeIfPos_of _ _ _ f g h g v hf hg hh (Or.inl ⟨hpos, rfl⟩)⟩ - · exact - ⟨h, - eval_codeIfPos_of _ _ _ f g h h v hf hg hh - (Or.inr ⟨le_antisymm (not_lt.mp hpos) (by simp), rfl⟩)⟩ - -/-- The primitive-recursion cell has a value: both arms of its eager -conditional are evaluated from the supplied code values. -/ -private theorem precProbe_cell_exists [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] {r : ℕ} - (dtable dk' dq dcf dcg dn : Code r) (table k' qv cf cg index : M) (v : Fin r → M) - (htable : Semiformula.Evalb (table :> v) (code dtable)) - (hk' : Semiformula.Evalb (k' :> v) (code dk')) (hq : Semiformula.Evalb (qv :> v) (code dq)) - (hcf : Semiformula.Evalb (cf :> v) (code dcf)) - (hcg : Semiformula.Evalb (cg :> v) (code dcg)) - (hn : Semiformula.Evalb (index :> v) (code dn)) : - ∃ z : M, - Semiformula.Evalb (z :> v) (code (codePrecEvaluatorCell dtable dk' dq dcf dcg dn)) := - by - have hz := eval_codeUnpair₁ dn index v hn - have ht := eval_codeUnpair₂ dn index v hn - have hy := eval_codeSub (codeUnpair₂ dn) (codeConst 1) _ _ v ht (eval_codeConst 1 v) - have hdk : Semiformula.Evalb ((k' + 1) :> v) (code (codeSucc dk')) := - (eval_codeSucc_iff _ _ _).mpr ⟨k', hk', rfl⟩ - have hzy := - eval_codePair (codeUnpair₁ dn) (codeSub (codeUnpair₂ dn) (codeConst 1)) _ _ v hz hy - refine precProbe_ifPos_exists _ _ _ v ⟨_, ht⟩ ?_ ?_ - · obtain ⟨o₁, ho₁⟩ := - eval_codeTableLookup_exists_of_values dtable dk' dq - (codePair (codeUnpair₁ dn) (codeSub (codeUnpair₂ dn) (codeConst 1))) table k' qv _ v - htable hk' hq hzy - refine eval_codeOptionBind_exists_of_value _ _ o₁ v ho₁ ?_ - have hL : - ∀ (X : Code r) (x : M), - Semiformula.Evalb (x :> v) (code X) → - Semiformula.Evalb (x :> (o₁ - 1) :> v) (code (codeLift X)) := - fun X x hx => (eval_codeLift_iff X x (o₁ - 1) v).mpr hx - have hinner := - eval_codePair (codeLift (codeSub (codeUnpair₂ dn) (codeConst 1))) (codeHead (n := r)) _ - (o₁ - 1) ((o₁ - 1) :> v) (hL _ _ hy) ((eval_codeHead_iff _ _).mpr rfl) - exact - eval_codeTableLookup_exists_of_values (codeLift dtable) (codeLift (codeSucc dk')) - (codeLift dcg) - (codePair (codeLift (codeUnpair₁ dn)) - (codePair (codeLift (codeSub (codeUnpair₂ dn) (codeConst 1))) (codeHead (n := r)))) - table (k' + 1) cg _ ((o₁ - 1) :> v) (hL _ _ htable) (hL _ _ hdk) (hL _ _ hcg) - (eval_codePair _ _ _ _ ((o₁ - 1) :> v) (hL _ _ hz) hinner) - · exact - eval_codeTableLookup_exists_of_values dtable (codeSucc dk') dcf (codeUnpair₁ dn) table - (k' + 1) cf _ v htable hdk hcf hz - /-- **Zero recursion argument.** When the argument code `dn` evaluates to `⟪z, 0⟫`, the primitive-recursion cell succeeds with output `y + 1` exactly when the base lookup succeeds with output `y + 1`: the table at fuel `k' + 1`, the @@ -393,8 +264,8 @@ theorem eval_codePrecEvaluatorCell_succ_iff_of_zero [M↓[ℒₒᵣ] ⊧* 𝐏 · exact hbase · intro hbase obtain ⟨w, hw⟩ := - precProbe_cell_exists dtable dk' dq dcf dcg dn table k' qv cf cg _ v htable hk' hq hcf hcg - hn + eval_codePrecEvaluatorCell_exists dtable dk' dq dcf dcg dn table k' qv cf cg _ v htable + hk' hq hcf hcg hn have hw' := hw simp only [codePrecEvaluatorCell] at hw' obtain ⟨f, hf, hcase⟩ := eval_codeIfPos_cases _ _ _ _ v hw' @@ -446,8 +317,8 @@ theorem eval_codePrecEvaluatorCell_succ_iff_of_succ [M↓[ℒₒᵣ] ⊧* 𝐏 · intro hx have hstep := (eval_codeOptionBind_succ_iff _ _ y v).mpr hx obtain ⟨w, hw⟩ := - precProbe_cell_exists dtable dk' dq dcf dcg dn table k' qv cf cg _ v htable hk' hq hcf hcg - hn + eval_codePrecEvaluatorCell_exists dtable dk' dq dcf dcg dn table k' qv cf cg _ v htable + hk' hq hcf hcg hn have hw' := hw simp only [codePrecEvaluatorCell] at hw' obtain ⟨f, hf, hcase⟩ := eval_codeIfPos_cases _ _ _ _ v hw' @@ -458,6 +329,36 @@ theorem eval_codePrecEvaluatorCell_succ_iff_of_succ [M↓[ℒₒᵣ] ⊧* 𝐏 exact hw · exact absurd (by rw [← hfa]; exact hf0) hnz +/-- The predecessor lookup reads the argument `pair z a` from `pair z (a + 1)`. -/ +theorem eval_prec_predecessor_argument [M↓[ℒₒᵣ] ⊧* 𝐏𝐀] [M↓[ℒₒᵣ] ⊧* 𝐈𝐎𝐩𝐞𝐧] + (s qCode z a : M) : + Semiformula.Evalb + ((FFL.FirstOrder.Arithmetic.pair z a) :> + ![s, qCode, FFL.FirstOrder.Arithmetic.pair z (a + 1)]) + (code + (codePair (codeUnpair₁ (Code.proj (2 : Fin 3))) + (codeSub (codeUnpair₂ (Code.proj (2 : Fin 3))) (codeConst 1)))) := + by + let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) + have hproj : + Semiformula.Evalb + (FFL.FirstOrder.Arithmetic.pair z (a + 1) :> + ![s, qCode, FFL.FirstOrder.Arithmetic.pair z (a + 1)]) + (code (Code.proj (2 : Fin 3))) := + (eval_proj_iff _ _ _).mpr rfl + have h1 := eval_codeUnpair₁ (Code.proj (2 : Fin 3)) _ _ hproj + rw [FFL.FirstOrder.Arithmetic.pi₁_pair] at h1 + have h2 := eval_codeUnpair₂ (Code.proj (2 : Fin 3)) _ _ hproj + rw [FFL.FirstOrder.Arithmetic.pi₂_pair] at h2 + have hone : + Semiformula.Evalb ((1 : M) :> ![s, qCode, FFL.FirstOrder.Arithmetic.pair z (a + 1)]) + (code (codeConst (n := 3) 1)) := + by rw [eval_codeConst_iff]; simp + have h3 := eval_codeSub _ (codeConst 1) (a + 1) 1 _ h2 hone + rw [add_sub_self] at h3 + exact eval_codePair _ _ z a _ h1 h3 + + /-! ### The same-index lookup of the successor branch -/ @@ -481,28 +382,8 @@ theorem eval_prec_predecessor_lookup_succ_iff_codeHistoryEvaluator [M↓[ℒₒ (codeSub (codeUnpair₂ (Code.proj (2 : Fin 3))) (codeConst 1))))) ↔ Semiformula.Evalb ![x + 1, k, ((q : ℕ) : M), FFL.FirstOrder.Arithmetic.pair z a] (code codeHistoryEvaluator) := - by - let : M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻ := models_of_subtheory (show M↓[ℒₒᵣ] ⊧* 𝐏𝐀 from inferInstance) - have hproj : - Semiformula.Evalb - (FFL.FirstOrder.Arithmetic.pair z (a + 1) :> - ![k + 1, ((q : ℕ) : M), FFL.FirstOrder.Arithmetic.pair z (a + 1)]) - (code (Code.proj (2 : Fin 3))) := - (eval_proj_iff _ _ _).mpr rfl - have h1 := eval_codeUnpair₁ (Code.proj (2 : Fin 3)) _ _ hproj - rw [FFL.FirstOrder.Arithmetic.pi₁_pair] at h1 - have h2 := eval_codeUnpair₂ (Code.proj (2 : Fin 3)) _ _ hproj - rw [FFL.FirstOrder.Arithmetic.pi₂_pair] at h2 - have hone : - Semiformula.Evalb - ((1 : M) :> ![k + 1, ((q : ℕ) : M), FFL.FirstOrder.Arithmetic.pair z (a + 1)]) - (code (codeConst (n := 3) 1)) := - by rw [eval_codeConst_iff]; simp - have h3 := eval_codeSub _ (codeConst 1) (a + 1) 1 _ h2 hone - rw [add_sub_self] at h3 - exact - eval_predecessor_lookup_succ_iff_codeHistoryEvaluator k _ _ x q _ - (eval_codePair _ _ z a _ h1 h3) + eval_predecessor_lookup_succ_iff_codeHistoryEvaluator k _ _ x q _ + (eval_prec_predecessor_argument (k + 1) ((q : ℕ) : M) z a) end Evaluator end CategoricalRiceShapiro diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/PartialRecursive/CanonicalComposition.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/PartialRecursive/CanonicalComposition.lean index be05ced29..9ff3ffb9f 100644 --- a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/PartialRecursive/CanonicalComposition.lean +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/PartialRecursive/CanonicalComposition.lean @@ -119,15 +119,8 @@ theorem eval_codePartrecPayload_canonicalPartrecCompIndex {M : Type*} [ORingStru (hd : Semiformula.Evalb ((canonicalPartrecCompIndex fCode gCode : M) :> v) (code d)) : Semiformula.Evalb (((Nat.pair fCode gCode : ℕ) : M) :> v) (code (codePartrecPayload d)) := by - have hrr := - eval_codeSub_natCast d (codeConst 4) (canonicalPartrecCompIndex fCode gCode) 4 v hd - (by simpa using eval_codeConst (M := M) 4 v) - have hq2 := eval_codeDiv2_natCast _ _ v (eval_codeDiv2_natCast _ _ v hrr) - have hval : - Nat.div2 (Nat.div2 (canonicalPartrecCompIndex fCode gCode - 4)) = Nat.pair fCode gCode := - partrecCodePayload_canonicalPartrecCompIndex fCode gCode - rw [hval] at hq2 - simpa only [codePartrecPayload] using hq2 + simpa only [partrecCodePayload_canonicalPartrecCompIndex] using + IndexDecoder.eval_codePartrecPayload_natCast d (canonicalPartrecCompIndex fCode gCode) v hd /-- The constructor number of the canonical composition index, read inside a model: it is `5`, the number of composition. -/ @@ -136,88 +129,27 @@ theorem eval_codePartrecTag_canonicalPartrecCompIndex {M : Type*} [ORingStructur (hd : Semiformula.Evalb ((canonicalPartrecCompIndex fCode gCode : M) :> v) (code d)) : Semiformula.Evalb ((5 : M) :> v) (code (codePartrecTag d)) := by - set c := canonicalPartrecCompIndex fCode gCode with hcdef - have hceq : c = 2 * (2 * Nat.pair fCode gCode + 1) + 4 := - canonicalPartrecCompIndex_eq fCode gCode - have hsub : c - 4 = 2 * (2 * Nat.pair fCode gCode + 1) := by rw [hceq]; omega - have hnlt : ¬c < 4 := by rw [hceq]; omega - have hb0 : (c - 4) % 2 = 0 := by rw [hsub]; omega - have hd2 : Nat.div2 (c - 4) = 2 * Nat.pair fCode gCode + 1 := - by - rw [hsub] - simp only [Nat.div2_val] - omega - have hb1 : Nat.div2 (c - 4) % 2 = 1 := by rw [hd2]; omega - have h4 : Semiformula.Evalb (((4 : ℕ) : M) :> v) (code (codeConst (n := r) 4)) := - eval_codeConst 4 v - have h2 : Semiformula.Evalb (((2 : ℕ) : M) :> v) (code (codeConst (n := r) 2)) := - eval_codeConst 2 v - have hrr := eval_codeSub_natCast d (codeConst 4) c 4 v hd (by simpa using h4) - have hbodd0 : - Semiformula.Evalb (((0 : ℕ) : M) :> v) (code (codeBodd (codeSub d (codeConst 4)))) := - by - have := eval_codeBodd_natCast _ (c - 4) v hrr - rwa [hb0] at this - have hbodd1 : - Semiformula.Evalb (((1 : ℕ) : M) :> v) - (code (codeBodd (codeDiv2 (codeSub d (codeConst 4))))) := - by - have := eval_codeBodd_natCast _ (Nat.div2 (c - 4)) v (eval_codeDiv2_natCast _ (c - 4) v hrr) - rwa [hb1] at this - have hmul : - Semiformula.Evalb ((((2 * 0 : ℕ)) : M) :> v) - (code (codeMul (codeConst 2) (codeBodd (codeSub d (codeConst 4))))) := - by - refine (eval_codeMul_iff _ _ _ _).mpr ⟨_, _, h2, hbodd0, ?_⟩ - push_cast - norm_num - have hadd1 : - Semiformula.Evalb ((((4 + 2 * 0 : ℕ)) : M) :> v) - (code - (codeAdd (codeConst 4) (codeMul (codeConst 2) (codeBodd (codeSub d (codeConst 4)))))) := - by - refine (eval_codeAdd_iff _ _ _ _).mpr ⟨_, _, h4, hmul, ?_⟩ - push_cast - norm_num - have hbig : - Semiformula.Evalb ((((4 + 2 * 0 + 1 : ℕ)) : M) :> v) - (code - (codeAdd - (codeAdd (codeConst 4) (codeMul (codeConst 2) (codeBodd (codeSub d (codeConst 4))))) - (codeBodd (codeDiv2 (codeSub d (codeConst 4)))))) := - by - refine (eval_codeAdd_iff _ _ _ _).mpr ⟨_, _, hadd1, hbodd1, ?_⟩ - push_cast - norm_num - have hfive : (((4 + 2 * 0 + 1 : ℕ)) : M) = (5 : M) := by norm_num - rw [hfive] at hbig - have hlt0 : Semiformula.Evalb ((0 : M) :> v) (code (codeLt d (codeConst 4))) := - by - refine (eval_codeLt_iff _ _ _ _).mpr ⟨_, _, hd, by simpa using h4, Or.inr ⟨?_, rfl⟩⟩ - intro hc - have : c < 4 := by exact_mod_cast hc - exact hnlt this - simp only [codePartrecTag] - exact - eval_codeIfPos_of _ _ _ (0 : M) ((c : ℕ) : M) (5 : M) _ v hlt0 hd hbig (Or.inr ⟨rfl, rfl⟩) + simpa only [Nat.succ_eq_add_one, canonicalPartrecCompIndex_constructor_number, + Nat.cast_ofNat] using + IndexDecoder.eval_codePartrecTag_natCast d (canonicalPartrecCompIndex fCode gCode) v hd /-- The outer subcode of the canonical composition index, read inside a model. -/ theorem eval_codePartrecPayload₁_canonicalPartrecCompIndex {M : Type*} [ORingStructure M] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (fCode gCode : ℕ) (v : Fin r → M) (hd : Semiformula.Evalb ((canonicalPartrecCompIndex fCode gCode : M) :> v) (code d)) : - Semiformula.Evalb (((fCode : ℕ) : M) :> v) (code (codePartrecPayload₁ d)) := by - simpa only [codePartrecPayload₁, Nat.unpair_pair] using - eval_codeUnpair₁_natCast (M := M) (codePartrecPayload d) (Nat.pair fCode gCode) v - (eval_codePartrecPayload_canonicalPartrecCompIndex d fCode gCode v hd) + Semiformula.Evalb (((fCode : ℕ) : M) :> v) (code (codePartrecPayload₁ d)) := + by + simpa only [canonicalPartrecCompIndex_outer_index] using + IndexDecoder.eval_codePartrecPayload₁_natCast d (canonicalPartrecCompIndex fCode gCode) v hd /-- The inner subcode of the canonical composition index, read inside a model. -/ theorem eval_codePartrecPayload₂_canonicalPartrecCompIndex {M : Type*} [ORingStructure M] [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {r : ℕ} (d : Code r) (fCode gCode : ℕ) (v : Fin r → M) (hd : Semiformula.Evalb ((canonicalPartrecCompIndex fCode gCode : M) :> v) (code d)) : - Semiformula.Evalb (((gCode : ℕ) : M) :> v) (code (codePartrecPayload₂ d)) := by - simpa only [codePartrecPayload₂, Nat.unpair_pair] using - eval_codeUnpair₂_natCast (M := M) (codePartrecPayload d) (Nat.pair fCode gCode) v - (eval_codePartrecPayload_canonicalPartrecCompIndex d fCode gCode v hd) + Semiformula.Evalb (((gCode : ℕ) : M) :> v) (code (codePartrecPayload₂ d)) := + by + simpa only [canonicalPartrecCompIndex_inner_index] using + IndexDecoder.eval_codePartrecPayload₂_natCast d (canonicalPartrecCompIndex fCode gCode) v hd end PartialRecursive end CategoricalRiceShapiro diff --git a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Formula/Functions.lean b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Formula/Functions.lean index b551cbb4a..2fef9de6b 100644 --- a/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Formula/Functions.lean +++ b/LeanPool/PointwiseComposition/Foundation/FirstOrder/Arithmetic/Bootstrapping/Syntax/Formula/Functions.lean @@ -1222,16 +1222,26 @@ lemma lt_max_succ_right (a b : V) : b < max a b + 1 := /-! A structural induction correspondence to `FFL.FirstOrder.Semiformula.formulaRec`. -/ -lemma IsFormula.sigma1_structural_induction {P : V → Prop} (hP : Σ₁-Predicate P) - (hrel : ∀ k r v, L.IsRel k r → IsTermVec L k v → P (^rel k r v)) - (hnrel : ∀ k r v, L.IsRel k r → IsTermVec L k v → P (^nrel k r v)) (hverum : P ^⊤) - (hfalsum : P ^⊥) (hand : ∀ p q, IsFormula L p → IsFormula L q → P p → P q → P (p ^⋏ q)) - (hor : ∀ p q, IsFormula L p → IsFormula L q → P p → P q → P (p ^⋎ q)) - (hall : ∀ p, IsSemiformula L 1 p → P (free L p) → P (^∀ p)) - (hexs : ∀ p, IsSemiformula L 1 p → P (free L p) → P (^∃ p)) {p} : IsFormula L p → P p := - by +/-- Structural induction at any variable bound, using a Sigma-one definable opening that +lowers that bound by one and preserves formula complexity. -/ +theorem IsSemiformula.sigma1_structural_induction_of_opening + (n : V) (opening : V → V) + (hOpening : Σ₁-Function₁ opening) + (hClosed : ∀ {p}, IsSemiformula L (n + 1) p → IsSemiformula L n (opening p)) + (hComplexity : ∀ {p}, IsSemiformula L (n + 1) p → + formulaComplexity L (opening p) = formulaComplexity L p) + {P : V → Prop} (hP : Σ₁-Predicate P) + (hrel : ∀ k r v, L.IsRel k r → IsSemitermVec L k n v → P (^rel k r v)) + (hnrel : ∀ k r v, L.IsRel k r → IsSemitermVec L k n v → P (^nrel k r v)) + (hverum : P ^⊤) (hfalsum : P ^⊥) + (hand : ∀ p q, IsSemiformula L n p → IsSemiformula L n q → P p → P q → P (p ^⋏ q)) + (hor : ∀ p q, IsSemiformula L n p → IsSemiformula L n q → P p → P q → P (p ^⋎ q)) + (hall : ∀ p, IsSemiformula L (n + 1) p → P (opening p) → P (^∀ p)) + (hexs : ∀ p, IsSemiformula L (n + 1) p → P (opening p) → P (^∃ p)) + {p} : IsSemiformula L n p → P p := by + let : Σ₁-Function₁ opening := hOpening have hm : Σ₁-Function₁[V] formulaComplexity L := inferInstance - let f : V → V := fun p ↦ max p (free L (π₂(p - 1))) + let f : V → V := fun p ↦ max p (opening (π₂(p - 1))) have hf : Σ₁-Function₁ f := by unfold f; definability apply measured_bounded_sigma1_order_induction hm hf ?_ ?_ p · definability @@ -1257,17 +1267,36 @@ lemma IsFormula.sigma1_structural_induction {P : V → Prop} (hP : Σ₁-Predica ih p₂ (by simp only [le_sup_iff, f]; left; exact le_of_lt <| by simp) (by simp [h₁.isUFormula, h₂.isUFormula]) h₂ exact hor _ _ h₁ h₂ ih₁ ih₂ - · have h₁ : IsSemiformula L 1 p₁ := by simpa using h₁ - have : P (free L p₁) := - ih (free L p₁) (by simp only [le_sup_iff, f]; right; simp [qqAll]) - (by simp [fomulaComplexity_free h₁, h₁.isUFormula]) (h₁.free) + · have : P (opening p₁) := + ih (opening p₁) (by simp only [le_sup_iff, f]; right; simp [qqAll]) + (by rw [hComplexity h₁]; simp [h₁.isUFormula]) (hClosed h₁) exact hall _ h₁ this - · have h₁ : IsSemiformula L 1 p₁ := by simpa using h₁ - have : P (free L p₁) := - ih (free L p₁) (by simp only [le_sup_iff, f]; right; simp [qqExs]) - (by simp [fomulaComplexity_free h₁, h₁.isUFormula]) (h₁.free) + · have : P (opening p₁) := + ih (opening p₁) (by simp only [le_sup_iff, f]; right; simp [qqExs]) + (by rw [hComplexity h₁]; simp [h₁.isUFormula]) (hClosed h₁) exact hexs _ h₁ this +lemma IsFormula.sigma1_structural_induction {P : V → Prop} (hP : Σ₁-Predicate P) + (hrel : ∀ k r v, L.IsRel k r → IsTermVec L k v → P (^rel k r v)) + (hnrel : ∀ k r v, L.IsRel k r → IsTermVec L k v → P (^nrel k r v)) (hverum : P ^⊤) + (hfalsum : P ^⊥) (hand : ∀ p q, IsFormula L p → IsFormula L q → P p → P q → P (p ^⋏ q)) + (hor : ∀ p q, IsFormula L p → IsFormula L q → P p → P q → P (p ^⋎ q)) + (hall : ∀ p, IsSemiformula L 1 p → P (free L p) → P (^∀ p)) + (hexs : ∀ p, IsSemiformula L 1 p → P (free L p) → P (^∃ p)) {p} : IsFormula L p → P p := by + refine IsSemiformula.sigma1_structural_induction_of_opening (L := L) (p := p) + 0 (free L) (by definability) + ?_ ?_ hP hrel hnrel hverum hfalsum hand hor ?_ ?_ + · intro q hq + have hq : IsSemiformula L 1 q := by simpa only [zero_add] using hq + exact hq.free + · intro q hq + have hq : IsSemiformula L 1 q := by simpa only [zero_add] using hq + exact fomulaComplexity_free hq + · intro q hq ih + exact hall q (by simpa only [zero_add] using hq) ih + · intro q hq ih + exact hexs q (by simpa only [zero_add] using hq) ih + lemma IsFormula.sigma1_structural_induction₂ {P : V → Prop} (hP : Σ₁-Predicate P) (hrel : ∀ k r v, L.IsRel k r → IsSemitermVec L k 1 v → P (^rel k r v)) (hnrel : ∀ k r v, L.IsRel k r → IsSemitermVec L k 1 v → P (^nrel k r v)) (hverum : P ^⊤) @@ -1276,45 +1305,20 @@ lemma IsFormula.sigma1_structural_induction₂ {P : V → Prop} (hP : Σ₁-Pred (hor : ∀ p q, IsSemiformula L 1 p → IsSemiformula L 1 q → P p → P q → P (p ^⋎ q)) (hall : ∀ p, IsSemiformula L 2 p → P (free1 L p) → P (^∀ p)) (hexs : ∀ p, IsSemiformula L 2 p → P (free1 L p) → P (^∃ p)) {p} : - IsSemiformula L 1 p → P p := - by - have hm : Σ₁-Function₁[V] formulaComplexity L := inferInstance - let f : V → V := fun p ↦ max p (free1 L (π₂(p - 1))) - have hf : Σ₁-Function₁ f := by unfold f; definability - apply measured_bounded_sigma1_order_induction hm hf ?_ ?_ p - · definability - intro p ih hp - rcases IsSemiformula.case_iff.mp hp with - (⟨k, R, v, hR, hv, rfl⟩ | ⟨k, R, v, hR, hv, rfl⟩ | rfl | rfl | ⟨p₁, p₂, h₁, h₂, rfl⟩ | - ⟨p₁, p₂, h₁, h₂, rfl⟩ | ⟨p₁, h₁, rfl⟩ | ⟨p₁, h₁, rfl⟩) - · exact hrel _ _ _ hR hv - · exact hnrel _ _ _ hR hv - · exact hverum - · exact hfalsum - · have ih₁ : P p₁ := - ih p₁ (by simp only [le_sup_iff, f]; left; exact le_of_lt <| by simp) - (by simp [h₁.isUFormula, h₂.isUFormula]) h₁ - have ih₂ : P p₂ := - ih p₂ (by simp only [le_sup_iff, f]; left; exact le_of_lt <| by simp) - (by simp [h₁.isUFormula, h₂.isUFormula]) h₂ - exact hand _ _ h₁ h₂ ih₁ ih₂ - · have ih₁ : P p₁ := - ih p₁ (by simp only [le_sup_iff, f]; left; exact le_of_lt <| by simp) - (by simp [h₁.isUFormula, h₂.isUFormula]) h₁ - have ih₂ : P p₂ := - ih p₂ (by simp only [le_sup_iff, f]; left; exact le_of_lt <| by simp) - (by simp [h₁.isUFormula, h₂.isUFormula]) h₂ - exact hor _ _ h₁ h₂ ih₁ ih₂ - · have h₁ : IsSemiformula L 2 p₁ := by simpa [one_add_one_eq_two] using h₁ - have : P (free1 L p₁) := - ih (free1 L p₁) (by simp only [le_sup_iff, f]; right; simp [qqAll]) - (by simp [fomulaComplexity_free1 h₁, h₁.isUFormula]) h₁.free1 - exact hall _ h₁ this - · have h₁ : IsSemiformula L 2 p₁ := by simpa [one_add_one_eq_two] using h₁ - have : P (free1 L p₁) := - ih (free1 L p₁) (by simp only [le_sup_iff, f]; right; simp [qqExs]) - (by simp [fomulaComplexity_free1 h₁, h₁.isUFormula]) h₁.free1 - exact hexs _ h₁ this + IsSemiformula L 1 p → P p := by + refine IsSemiformula.sigma1_structural_induction_of_opening (L := L) (p := p) + 1 (free1 L) (by definability) + ?_ ?_ hP hrel hnrel hverum hfalsum hand hor ?_ ?_ + · intro q hq + have hq : IsSemiformula L 2 q := by simpa only [one_add_one_eq_two] using hq + exact hq.free1 + · intro q hq + have hq : IsSemiformula L 2 q := by simpa only [one_add_one_eq_two] using hq + exact fomulaComplexity_free1 hq + · intro q hq ih + exact hall q (by simpa only [one_add_one_eq_two] using hq) ih + · intro q hq ih + exact hexs q (by simpa only [one_add_one_eq_two] using hq) ih lemma IsFormula.sigma1_structural_induction₂_ss {P : V → Prop} (hP : Σ₁-Predicate P) (hrel : ∀ k r v, L.IsRel k r → IsSemitermVec L k 1 v → P (^rel k r v)) @@ -1324,55 +1328,21 @@ lemma IsFormula.sigma1_structural_induction₂_ss {P : V → Prop} (hP : Σ₁-P (hor : ∀ p q, IsSemiformula L 1 p → IsSemiformula L 1 q → P p → P q → P (p ^⋎ q)) (hall : ∀ p, IsSemiformula L 2 p → P (free1 L <| shift L <| shift L <| p) → P (^∀ p)) (hexs : ∀ p, IsSemiformula L 2 p → P (free1 L <| shift L <| shift L <| p) → P (^∃ p)) {p} : - IsSemiformula L 1 p → P p := - by - have hm : Σ₁-Function₁[V] formulaComplexity L := inferInstance - let f : V → V := fun p ↦ max p (free1 L <| shift L <| shift L <| (π₂(p - 1))) - have hf : Σ₁-Function₁ f := by unfold f; definability - apply measured_bounded_sigma1_order_induction hm hf ?_ ?_ p - · definability - intro p ih hp - rcases IsSemiformula.case_iff.mp hp with - (⟨k, R, v, hR, hv, rfl⟩ | ⟨k, R, v, hR, hv, rfl⟩ | rfl | rfl | ⟨p₁, p₂, h₁, h₂, rfl⟩ | - ⟨p₁, p₂, h₁, h₂, rfl⟩ | ⟨p₁, h₁, rfl⟩ | ⟨p₁, h₁, rfl⟩) - · exact hrel _ _ _ hR hv - · exact hnrel _ _ _ hR hv - · exact hverum - · exact hfalsum - · have ih₁ : P p₁ := - ih p₁ (by simp only [le_sup_iff, f]; left; exact le_of_lt <| by simp) - (by simp [h₁.isUFormula, h₂.isUFormula]) h₁ - have ih₂ : P p₂ := - ih p₂ (by simp only [le_sup_iff, f]; left; exact le_of_lt <| by simp) - (by simp [h₁.isUFormula, h₂.isUFormula]) h₂ - exact hand _ _ h₁ h₂ ih₁ ih₂ - · have ih₁ : P p₁ := - ih p₁ (by simp only [le_sup_iff, f]; left; exact le_of_lt <| by simp) - (by simp [h₁.isUFormula, h₂.isUFormula]) h₁ - have ih₂ : P p₂ := - ih p₂ (by simp only [le_sup_iff, f]; left; exact le_of_lt <| by simp) - (by simp [h₁.isUFormula, h₂.isUFormula]) h₂ - exact hor _ _ h₁ h₂ ih₁ ih₂ - · have h₁ : IsSemiformula L 2 p₁ := by simpa [one_add_one_eq_two] using h₁ - have : P (free1 L <| shift L <| shift L <| p₁) := - ih (free1 L <| shift L <| shift L <| p₁) - (by simp only [le_sup_iff, f]; right; simp [qqAll]) - (by - rw [fomulaComplexity_free1 h₁.shift.shift, - formulaComplexity_shift h₁.shift.isUFormula, formulaComplexity_shift h₁.isUFormula]; - simp [h₁.isUFormula]) - h₁.shift.shift.free1 - exact hall _ h₁ this - · have h₁ : IsSemiformula L 2 p₁ := by simpa [one_add_one_eq_two] using h₁ - have : P (free1 L <| shift L <| shift L <| p₁) := - ih (free1 L <| shift L <| shift L <| p₁) - (by simp only [le_sup_iff, f]; right; simp [qqExs]) - (by - rw [fomulaComplexity_free1 h₁.shift.shift, - formulaComplexity_shift h₁.shift.isUFormula, formulaComplexity_shift h₁.isUFormula]; - simp [h₁.isUFormula]) - h₁.shift.shift.free1 - exact hexs _ h₁ this + IsSemiformula L 1 p → P p := by + refine IsSemiformula.sigma1_structural_induction_of_opening (L := L) (p := p) + 1 (fun q => free1 L (shift L (shift L q))) (by definability) + ?_ ?_ hP hrel hnrel hverum hfalsum hand hor ?_ ?_ + · intro q hq + have hq : IsSemiformula L 2 q := by simpa only [one_add_one_eq_two] using hq + exact hq.shift.shift.free1 + · intro q hq + have hq : IsSemiformula L 2 q := by simpa only [one_add_one_eq_two] using hq + rw [fomulaComplexity_free1 hq.shift.shift, + formulaComplexity_shift hq.shift.isUFormula, formulaComplexity_shift hq.isUFormula] + · intro q hq ih + exact hall q (by simpa only [one_add_one_eq_two] using hq) ih + · intro q hq ih + exact hexs q (by simpa only [one_add_one_eq_two] using hq) ih namespace ObjectArithmetic From b49235e6dc0fb2c388d260fdc6cbddec9b609bdd Mon Sep 17 00:00:00 2001 From: Vasily Ilin Date: Mon, 19 Oct 2026 21:13:36 +0000 Subject: [PATCH 5/5] Specialize congruence lemmas from shared graph equivalence --- .../ArithmeticCode/Evaluation.lean | 196 ++++++-- .../ArithmeticCode/EvaluationCongruence.lean | 461 +++++------------- 2 files changed, 270 insertions(+), 387 deletions(-) diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/Evaluation.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/Evaluation.lean index c5bf80f44..50f2e820e 100644 --- a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/Evaluation.lean +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/Evaluation.lean @@ -127,17 +127,6 @@ theorem eval_comp₂_iff {k : ℕ} (c : Code 2) (A B : Code k) (z : M) (v : Fin rw [eval_comp_iff] simp [Fin.forall_fin_two] -theorem eval_comp_congr {m k : ℕ} (c : Code m) (d e : Fin m → Code k) (z : M) (v : Fin k → M) - (h : - ∀ (i : Fin m) (x : M), - Semiformula.Evalb (x :> v) (FFL.FirstOrder.Arithmetic.code (d i)) ↔ - Semiformula.Evalb (x :> v) (FFL.FirstOrder.Arithmetic.code (e i))) : - Semiformula.Evalb (z :> v) (FFL.FirstOrder.Arithmetic.code (Code.comp c d)) ↔ - Semiformula.Evalb (z :> v) (FFL.FirstOrder.Arithmetic.code (Code.comp c e)) := - by - rw [eval_comp_iff, eval_comp_iff] - exact exists_congr fun w => and_congr_right fun _ => forall_congr' fun i => h i (w i) - /-! ### Derived constructors -/ @@ -387,6 +376,142 @@ theorem eval_codeLift_codeConst_iff {M : Type*} [ORingStructure M] [M↓[ℒₒ Semiformula.Evalb (z :> t :> v) (code (codeConst (n := r + 1) m)) := by rw [eval_codeLift_iff, eval_codeConst_iff, eval_codeConst_iff] +/-! +### Graph agreement across arities and assignments -/ + +/-- Two codes have the same graph, each under its own assignment. -/ +abbrev EvalEq {k l : ℕ} (A : Code k) (v : Fin k → M) (A' : Code l) (v' : Fin l → M) : + Prop := + ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v') (code A') + +/-- Projections agree when the selected assignment entries agree. -/ +theorem evalEq_proj {k l : ℕ} (i : Fin k) (j : Fin l) (v : Fin k → M) (v' : Fin l → M) + (h : v i = v' j) : EvalEq (Code.proj i) v (Code.proj j) v' := + by + intro x + rw [eval_proj_iff, eval_proj_iff, h] + +/-- Zero codes have the same graph under any two assignments. -/ +theorem evalEq_zero {k l : ℕ} (v : Fin k → M) (v' : Fin l → M) : + EvalEq (Code.zero k) v (Code.zero l) v' := + by + intro x + rw [eval_zero_iff, eval_zero_iff] + +/-- Head codes agree under assignments with the same head. -/ +theorem evalEq_codeHead {k l : ℕ} (t : M) (v : Fin k → M) (v' : Fin l → M) : + EvalEq (codeHead (n := k)) (t :> v) (codeHead (n := l)) (t :> v') := + evalEq_proj 0 0 _ _ rfl + +/-- Successor-code construction preserves heterogeneous graph agreement. -/ +theorem evalEq_codeSucc {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') : EvalEq (codeSucc A) v (codeSucc A') v' := + by + intro x + rw [eval_codeSucc_iff, eval_codeSucc_iff] + exact exists_congr fun a => and_congr (hA a) Iff.rfl + +/-- Positive-test code construction preserves heterogeneous graph agreement. -/ +theorem evalEq_codePos {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') : EvalEq (codePos A) v (codePos A') v' := + by + intro x + rw [eval_codePos_iff, eval_codePos_iff] + exact exists_congr fun a => and_congr (hA a) Iff.rfl + +/-- Boolean-inverse code construction preserves heterogeneous graph agreement. -/ +theorem evalEq_codeInv {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') : EvalEq (codeInv A) v (codeInv A') v' := + by + intro x + rw [eval_codeInv_iff, eval_codeInv_iff] + exact exists_congr fun a => and_congr (hA a) Iff.rfl + +/-- Addition-code construction preserves heterogeneous graph agreement. -/ +theorem evalEq_codeAdd {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : + EvalEq (codeAdd A B) v (codeAdd A' B') v' := + by + intro x + rw [eval_codeAdd_iff, eval_codeAdd_iff] + exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) + +/-- Multiplication-code construction preserves heterogeneous graph agreement. -/ +theorem evalEq_codeMul {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : + EvalEq (codeMul A B) v (codeMul A' B') v' := + by + intro x + rw [eval_codeMul_iff, eval_codeMul_iff] + exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) + +/-- Equality-test code construction preserves heterogeneous graph agreement. -/ +theorem evalEq_codeEq {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : + EvalEq (codeEq A B) v (codeEq A' B') v' := + by + intro x + rw [eval_codeEq_iff, eval_codeEq_iff] + exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) + +/-- Order-test code construction preserves heterogeneous graph agreement. -/ +theorem evalEq_codeLt {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : + EvalEq (codeLt A B) v (codeLt A' B') v' := + by + intro x + rw [eval_codeLt_iff, eval_codeLt_iff] + exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) + +/-- Conjunction-code construction preserves heterogeneous graph agreement. -/ +theorem evalEq_codeAnd {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : + EvalEq (codeAnd A B) v (codeAnd A' B') v' := + by + intro x + rw [eval_codeAnd_iff, eval_codeAnd_iff] + exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) + +/-- Disjunction-code construction preserves heterogeneous graph agreement. -/ +theorem evalEq_codeOr {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} + {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : + EvalEq (codeOr A B) v (codeOr A' B') v' := + by + intro x + rw [eval_codeOr_iff, eval_codeOr_iff] + exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) + +/-- A lift ignores its head, so the two heads need not agree. -/ +theorem evalEq_codeLift {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} + {v' : Fin l → M} (t t' : M) (hA : EvalEq A v A' v') : + EvalEq (codeLift A) (t :> v) (codeLift A') (t' :> v') := + by + intro x + rw [eval_codeLift_iff, eval_codeLift_iff] + exact hA x + +/-- One codes have the same graph under any two assignments. -/ +theorem evalEq_one {k l : ℕ} (v : Fin k → M) (v' : Fin l → M) : + EvalEq (Code.one k) v (Code.one l) v' := by intro x; rw [eval_one_iff, eval_one_iff] + +/-- Composition with a shared outer code. -/ +theorem evalEq_comp {k l m : ℕ} (c : Code m) (ds : Fin m → Code k) + (ds' : Fin m → Code l) {v : Fin k → M} {v' : Fin l → M} + (h : ∀ i, EvalEq (ds i) v (ds' i) v') : EvalEq (c.comp ds) v (c.comp ds') v' := + by + intro x + rw [eval_comp_iff, eval_comp_iff] + constructor + · rintro ⟨w, hw, hwi⟩; exact ⟨w, hw, fun i => (h i (w i)).mp (hwi i)⟩ + · rintro ⟨w, hw, hwi⟩; exact ⟨w, hw, fun i => (h i (w i)).mpr (hwi i)⟩ + +/-- Constant codes agree under assignments of any arities. -/ +theorem evalEq_codeConst {k l : ℕ} (m : ℕ) (v : Fin k → M) (v' : Fin l → M) : + EvalEq (codeConst (n := k) m) v (codeConst (n := l) m) v' := by + induction m with + | zero => exact evalEq_zero v v' + | succ m ih => exact evalEq_codeSucc ih + /-! ### Valuation-local congruence for the derived constructors @@ -396,83 +521,74 @@ of the constructed codes. No assignment other than `v` occurs, and no model assumption beyond `ORingStructure M` is used. Composition is already covered by `eval_comp_congr`. -/ +theorem eval_comp_congr {m k : ℕ} (c : Code m) (d e : Fin m → Code k) (z : M) (v : Fin k → M) + (h : + ∀ (i : Fin m) (x : M), + Semiformula.Evalb (x :> v) (FFL.FirstOrder.Arithmetic.code (d i)) ↔ + Semiformula.Evalb (x :> v) (FFL.FirstOrder.Arithmetic.code (e i))) : + Semiformula.Evalb (z :> v) (FFL.FirstOrder.Arithmetic.code (Code.comp c d)) ↔ + Semiformula.Evalb (z :> v) (FFL.FirstOrder.Arithmetic.code (Code.comp c e)) := + evalEq_comp c d e h z + theorem eval_codeSucc_congr {k : ℕ} (A A' : Code k) (z : M) (v : Fin k → M) (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) : Semiformula.Evalb (z :> v) (code (codeSucc A)) ↔ Semiformula.Evalb (z :> v) (code (codeSucc A')) := - by - rw [eval_codeSucc_iff, eval_codeSucc_iff] - exact exists_congr fun a => and_congr (hA a) Iff.rfl + evalEq_codeSucc hA z theorem eval_codePos_congr {k : ℕ} (A A' : Code k) (z : M) (v : Fin k → M) (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) : Semiformula.Evalb (z :> v) (code (codePos A)) ↔ Semiformula.Evalb (z :> v) (code (codePos A')) := - by - rw [eval_codePos_iff, eval_codePos_iff] - exact exists_congr fun a => and_congr (hA a) Iff.rfl + evalEq_codePos hA z theorem eval_codeInv_congr {k : ℕ} (A A' : Code k) (z : M) (v : Fin k → M) (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) : Semiformula.Evalb (z :> v) (code (codeInv A)) ↔ Semiformula.Evalb (z :> v) (code (codeInv A')) := - by - rw [eval_codeInv_iff, eval_codeInv_iff] - exact exists_congr fun a => and_congr (hA a) Iff.rfl + evalEq_codeInv hA z theorem eval_codeAdd_congr {k : ℕ} (A A' B B' : Code k) (z : M) (v : Fin k → M) (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) (hB : ∀ x : M, Semiformula.Evalb (x :> v) (code B) ↔ Semiformula.Evalb (x :> v) (code B')) : Semiformula.Evalb (z :> v) (code (codeAdd A B)) ↔ Semiformula.Evalb (z :> v) (code (codeAdd A' B')) := - by - rw [eval_codeAdd_iff, eval_codeAdd_iff] - exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) + evalEq_codeAdd hA hB z theorem eval_codeMul_congr {k : ℕ} (A A' B B' : Code k) (z : M) (v : Fin k → M) (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) (hB : ∀ x : M, Semiformula.Evalb (x :> v) (code B) ↔ Semiformula.Evalb (x :> v) (code B')) : Semiformula.Evalb (z :> v) (code (codeMul A B)) ↔ Semiformula.Evalb (z :> v) (code (codeMul A' B')) := - by - rw [eval_codeMul_iff, eval_codeMul_iff] - exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) + evalEq_codeMul hA hB z theorem eval_codeEq_congr {k : ℕ} (A A' B B' : Code k) (z : M) (v : Fin k → M) (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) (hB : ∀ x : M, Semiformula.Evalb (x :> v) (code B) ↔ Semiformula.Evalb (x :> v) (code B')) : Semiformula.Evalb (z :> v) (code (codeEq A B)) ↔ Semiformula.Evalb (z :> v) (code (codeEq A' B')) := - by - rw [eval_codeEq_iff, eval_codeEq_iff] - exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) + evalEq_codeEq hA hB z theorem eval_codeLt_congr {k : ℕ} (A A' B B' : Code k) (z : M) (v : Fin k → M) (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) (hB : ∀ x : M, Semiformula.Evalb (x :> v) (code B) ↔ Semiformula.Evalb (x :> v) (code B')) : Semiformula.Evalb (z :> v) (code (codeLt A B)) ↔ Semiformula.Evalb (z :> v) (code (codeLt A' B')) := - by - rw [eval_codeLt_iff, eval_codeLt_iff] - exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) + evalEq_codeLt hA hB z theorem eval_codeAnd_congr {k : ℕ} (A A' B B' : Code k) (z : M) (v : Fin k → M) (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) (hB : ∀ x : M, Semiformula.Evalb (x :> v) (code B) ↔ Semiformula.Evalb (x :> v) (code B')) : Semiformula.Evalb (z :> v) (code (codeAnd A B)) ↔ Semiformula.Evalb (z :> v) (code (codeAnd A' B')) := - by - rw [eval_codeAnd_iff, eval_codeAnd_iff] - exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) + evalEq_codeAnd hA hB z theorem eval_codeOr_congr {k : ℕ} (A A' B B' : Code k) (z : M) (v : Fin k → M) (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) (hB : ∀ x : M, Semiformula.Evalb (x :> v) (code B) ↔ Semiformula.Evalb (x :> v) (code B')) : Semiformula.Evalb (z :> v) (code (codeOr A B)) ↔ Semiformula.Evalb (z :> v) (code (codeOr A' B')) := - by - rw [eval_codeOr_iff, eval_codeOr_iff] - exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) + evalEq_codeOr hA hB z /-- An equivalence at `v` lifts to an equivalence at every assignment extending `v` by one value. -/ @@ -480,9 +596,7 @@ theorem eval_codeLift_congr {k : ℕ} (A A' : Code k) (z t : M) (v : Fin k → M (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) : Semiformula.Evalb (z :> t :> v) (code (codeLift A)) ↔ Semiformula.Evalb (z :> t :> v) (code (codeLift A')) := - by - rw [eval_codeLift_iff, eval_codeLift_iff] - exact hA z + evalEq_codeLift t t hA z end ArithmeticCode end CategoricalRiceShapiro diff --git a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/EvaluationCongruence.lean b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/EvaluationCongruence.lean index 3d28e6fa9..71bf5400d 100644 --- a/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/EvaluationCongruence.lean +++ b/LeanPool/PointwiseComposition/CategoricalRiceShapiro/ArithmeticCode/EvaluationCongruence.lean @@ -24,9 +24,9 @@ assignment for composition and for the constructors built directly from the primitives. This module continues the same discipline through the constructors defined by minimization. -Every statement fixes one assignment `v`, quantifies the hypothesis over the -possible values of the argument codes, and assumes only `ORingStructure M`. No -result here assumes `𝐏𝐀⁻`, and none quantifies over assignments. +The congruence laws assume only `ORingStructure M`. The general laws compare +two arities and assignments; their fixed-assignment specializations quantify +only over possible values of the argument codes. The minimization step is the substantive one. `Nat.ArithPart₁.Code.rfind` translates to a conjunction of two occurrences of the body formula, one at the @@ -65,20 +65,6 @@ private theorem eval_rfind_iff {k : ℕ} (c : Code (k + 1)) (z : M) (v : Fin k simp only [evalb_iff_evalf] simp [codeAux, Semiformula.eval_rew, Function.comp_def, Matrix.empty_eq, Matrix.comp_vecCons'] -/-- Equivalent search bodies determine equivalent searches. -/ -private theorem eval_rfind_congr {k : ℕ} (c c' : Code (k + 1)) (z : M) (v : Fin k → M) - (h : - ∀ x t : M, - Semiformula.Evalb (x :> t :> v) (code c) ↔ Semiformula.Evalb (x :> t :> v) (code c')) : - Semiformula.Evalb (z :> v) (code (Code.rfind c)) ↔ - Semiformula.Evalb (z :> v) (code (Code.rfind c')) := - by - rw [eval_rfind_iff, eval_rfind_iff] - exact - and_congr (h 0 z) - (forall_congr' fun t => - imp_congr Iff.rfl (exists_congr fun x => and_congr Iff.rfl (h x t))) - /-- Evaluation of a substitution: the body holds at the value the substituted code takes. @@ -174,205 +160,10 @@ theorem eval_codeRfindPos_iff [M↓[ℒₒᵣ] ⊧* 𝐏𝐀⁻] {k : ℕ} (d : · intro hd exact ⟨1, _root_.one_ne_zero, (hinv 1 (t :> v)).mpr (Or.inl ⟨rfl, hd⟩)⟩ -/-- Equivalent bodies determine equivalent minimizations. - -This is the congruence law for the minimization context, stated at the -assignment `v` and quantified over the value and the search argument. -/ -theorem eval_codeRfindPos_congr {k : ℕ} (A A' : Code (k + 1)) (z : M) (v : Fin k → M) - (hA : - ∀ x t : M, - Semiformula.Evalb (x :> t :> v) (code A) ↔ Semiformula.Evalb (x :> t :> v) (code A')) : - Semiformula.Evalb (z :> v) (code (codeRfindPos A)) ↔ - Semiformula.Evalb (z :> v) (code (codeRfindPos A')) := - by - simp only [codeRfindPos] - refine eval_rfind_congr _ _ z v ?_ - intro x t - exact - eval_codeInv_congr _ _ x (t :> v) - (fun y => eval_codePos_congr _ _ y (t :> v) (fun w => hA w t)) - -/-! -### Constructors defined by minimization -/ - -theorem eval_codeSub_congr {k : ℕ} (A A' B B' : Code k) (z : M) (v : Fin k → M) - (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) - (hB : ∀ x : M, Semiformula.Evalb (x :> v) (code B) ↔ Semiformula.Evalb (x :> v) (code B')) : - Semiformula.Evalb (z :> v) (code (codeSub A B)) ↔ - Semiformula.Evalb (z :> v) (code (codeSub A' B')) := - by - simp only [codeSub] - refine eval_codeRfindPos_congr _ _ z v ?_ - intro x t - refine eval_codeOr_congr _ _ _ _ x (t :> v) ?_ ?_ - · intro y - exact - eval_codeEq_congr _ _ _ _ y (t :> v) - (fun w => - eval_codeAdd_congr _ _ _ _ w (t :> v) (fun _ => Iff.rfl) - (fun u => eval_codeLift_congr B B' u t v hB)) - (fun w => eval_codeLift_congr A A' w t v hA) - · intro y - exact - eval_codeAnd_congr _ _ _ _ y (t :> v) - (fun w => - eval_codeLt_congr _ _ _ _ w (t :> v) (fun u => eval_codeLift_congr A A' u t v hA) - (fun u => eval_codeLift_congr B B' u t v hB)) - (fun _ => Iff.rfl) - -theorem eval_codeSqrt_congr {k : ℕ} (A A' : Code k) (z : M) (v : Fin k → M) - (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) : - Semiformula.Evalb (z :> v) (code (codeSqrt A)) ↔ - Semiformula.Evalb (z :> v) (code (codeSqrt A')) := - by - simp only [codeSqrt] - refine eval_codeRfindPos_congr _ _ z v ?_ - intro x t - refine eval_codeAnd_congr _ _ _ _ x (t :> v) ?_ ?_ - · intro y - exact - eval_codeOr_congr _ _ _ _ y (t :> v) - (fun w => - eval_codeLt_congr _ _ _ _ w (t :> v) (fun _ => Iff.rfl) - (fun u => eval_codeLift_congr A A' u t v hA)) - (fun w => - eval_codeEq_congr _ _ _ _ w (t :> v) (fun _ => Iff.rfl) - (fun u => eval_codeLift_congr A A' u t v hA)) - · intro y - exact - eval_codeLt_congr _ _ _ _ y (t :> v) (fun u => eval_codeLift_congr A A' u t v hA) - (fun _ => Iff.rfl) - -theorem eval_codeIfPos_congr {k : ℕ} (F F' G G' H H' : Code k) (z : M) (v : Fin k → M) - (hF : ∀ x : M, Semiformula.Evalb (x :> v) (code F) ↔ Semiformula.Evalb (x :> v) (code F')) - (hG : ∀ x : M, Semiformula.Evalb (x :> v) (code G) ↔ Semiformula.Evalb (x :> v) (code G')) - (hH : ∀ x : M, Semiformula.Evalb (x :> v) (code H) ↔ Semiformula.Evalb (x :> v) (code H')) : - Semiformula.Evalb (z :> v) (code (codeIfPos F G H)) ↔ - Semiformula.Evalb (z :> v) (code (codeIfPos F' G' H')) := - by - simp only [codeIfPos] - exact - eval_codeAdd_congr _ _ _ _ z v - (fun x => eval_codeMul_congr _ _ _ _ x v (fun y => eval_codePos_congr _ _ y v hF) hG) - (fun x => eval_codeMul_congr _ _ _ _ x v (fun y => eval_codeInv_congr _ _ y v hF) hH) - -theorem eval_codeUnpair₁_congr {k : ℕ} (A A' : Code k) (z : M) (v : Fin k → M) - (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) : - Semiformula.Evalb (z :> v) (code (codeUnpair₁ A)) ↔ - Semiformula.Evalb (z :> v) (code (codeUnpair₁ A')) := - by - have hsq : - ∀ x : M, - Semiformula.Evalb (x :> v) (code (codeSqrt A)) ↔ - Semiformula.Evalb (x :> v) (code (codeSqrt A')) := - fun x => eval_codeSqrt_congr A A' x v hA - have hdiff : - ∀ x : M, - Semiformula.Evalb (x :> v) (code (codeSub A (codeMul (codeSqrt A) (codeSqrt A)))) ↔ - Semiformula.Evalb (x :> v) (code (codeSub A' (codeMul (codeSqrt A') (codeSqrt A')))) := - fun x => eval_codeSub_congr _ _ _ _ x v hA (fun y => eval_codeMul_congr _ _ _ _ y v hsq hsq) - simp only [codeUnpair₁] - exact - eval_codeIfPos_congr _ _ _ _ _ _ z v (fun x => eval_codeLt_congr _ _ _ _ x v hdiff hsq) - hdiff hsq - -theorem eval_codeUnpair₂_congr {k : ℕ} (A A' : Code k) (z : M) (v : Fin k → M) - (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) : - Semiformula.Evalb (z :> v) (code (codeUnpair₂ A)) ↔ - Semiformula.Evalb (z :> v) (code (codeUnpair₂ A')) := - by - have hsq : - ∀ x : M, - Semiformula.Evalb (x :> v) (code (codeSqrt A)) ↔ - Semiformula.Evalb (x :> v) (code (codeSqrt A')) := - fun x => eval_codeSqrt_congr A A' x v hA - have hdiff : - ∀ x : M, - Semiformula.Evalb (x :> v) (code (codeSub A (codeMul (codeSqrt A) (codeSqrt A)))) ↔ - Semiformula.Evalb (x :> v) (code (codeSub A' (codeMul (codeSqrt A') (codeSqrt A')))) := - fun x => eval_codeSub_congr _ _ _ _ x v hA (fun y => eval_codeMul_congr _ _ _ _ y v hsq hsq) - simp only [codeUnpair₂] - exact - eval_codeIfPos_congr _ _ _ _ _ _ z v (fun x => eval_codeLt_congr _ _ _ _ x v hdiff hsq) hsq - (fun x => eval_codeSub_congr _ _ _ _ x v hdiff hsq) - -/-! -### Pairing -/ - -theorem eval_codePair_congr {k : ℕ} (A A' B B' : Code k) (z : M) (v : Fin k → M) - (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) - (hB : ∀ x : M, Semiformula.Evalb (x :> v) (code B) ↔ Semiformula.Evalb (x :> v) (code B')) : - Semiformula.Evalb (z :> v) (code (codePair A B)) ↔ - Semiformula.Evalb (z :> v) (code (codePair A' B')) := - by - simp only [codePair] - exact - eval_codeIfPos_congr _ _ _ _ _ _ z v (fun x => eval_codeLt_congr _ _ _ _ x v hA hB) - (fun x => - eval_codeAdd_congr _ _ _ _ x v (fun y => eval_codeMul_congr _ _ _ _ y v hB hB) hA) - (fun x => - eval_codeAdd_congr _ _ _ _ x v - (fun y => - eval_codeAdd_congr _ _ _ _ y v (fun w => eval_codeMul_congr _ _ _ _ w v hA hA) hA) - hB) - -/-! -### Encoded lists -/ - -theorem eval_codeListHeadOptional_congr {k : ℕ} (A A' : Code k) (z : M) (v : Fin k → M) - (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) : - Semiformula.Evalb (z :> v) (code (codeListHeadOptional A)) ↔ - Semiformula.Evalb (z :> v) (code (codeListHeadOptional A')) := - by - simp only [codeListHeadOptional] - exact - eval_codeIfPos_congr _ _ _ _ _ _ z v hA - (fun x => - eval_codeSucc_congr _ _ x v - (fun y => - eval_codeUnpair₁_congr _ _ y v - (fun w => eval_codeSub_congr _ _ _ _ w v hA (fun _ => Iff.rfl)))) - (fun _ => Iff.rfl) - -theorem eval_codeListTail_congr {k : ℕ} (A A' : Code k) (z : M) (v : Fin k → M) - (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) : - Semiformula.Evalb (z :> v) (code (codeListTail A)) ↔ - Semiformula.Evalb (z :> v) (code (codeListTail A')) := - by - simp only [codeListTail] - exact - eval_codeUnpair₂_congr _ _ z v - (fun x => eval_codeSub_congr _ _ _ _ x v hA (fun _ => Iff.rfl)) - -theorem eval_codeListDrop_congr {k : ℕ} (L L' I I' : Code k) (z : M) (v : Fin k → M) - (hL : ∀ x : M, Semiformula.Evalb (x :> v) (code L) ↔ Semiformula.Evalb (x :> v) (code L')) - (hI : ∀ x : M, Semiformula.Evalb (x :> v) (code I) ↔ Semiformula.Evalb (x :> v) (code I')) : - Semiformula.Evalb (z :> v) (code (codeListDrop L I)) ↔ - Semiformula.Evalb (z :> v) (code (codeListDrop L' I')) := - by - rw [codeListDrop_eq_comp, codeListDrop_eq_comp] - refine eval_comp_congr _ _ _ z v ?_ - refine Fin.forall_fin_two.mpr ⟨?_, ?_⟩ - · intro x - simpa using hI x - · intro x - simpa using hL x - -theorem eval_codeListGetOptional_congr {k : ℕ} (L L' I I' : Code k) (z : M) (v : Fin k → M) - (hL : ∀ x : M, Semiformula.Evalb (x :> v) (code L) ↔ Semiformula.Evalb (x :> v) (code L')) - (hI : ∀ x : M, Semiformula.Evalb (x :> v) (code I) ↔ Semiformula.Evalb (x :> v) (code I')) : - Semiformula.Evalb (z :> v) (code (codeListGetOptional L I)) ↔ - Semiformula.Evalb (z :> v) (code (codeListGetOptional L' I')) := - by - simp only [codeListGetOptional] - exact - eval_codeListHeadOptional_congr _ _ z v - (fun x => eval_codeListDrop_congr L L' I I' x v hL hI) - /-! ### Congruence across two arities and two assignments -The congruence laws above compare two codes of one arity under one assignment. +Congruence at a fixed assignment compares two codes of one arity. Relating an entry that `codePrec` reads with the entry its step relation supplies needs more: the two `codeBeta` applications there have different argument codes, different arities and different assignments, and agree only through the values @@ -383,139 +174,6 @@ Nothing here evaluates a code in the model, and no arithmetic meaning is attached to remainder, unpairing or `codeBeta`; each is delta-reduced as a syntax tree. No arithmetic theory is assumed. -/ -/-- Two codes have the same graph, each under its own assignment. -/ -abbrev EvalEq {k l : ℕ} (A : Code k) (v : Fin k → M) (A' : Code l) (v' : Fin l → M) : - Prop := - ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v') (code A') - -/-- Projections agree when the selected assignment entries agree. -/ -theorem evalEq_proj {k l : ℕ} (i : Fin k) (j : Fin l) (v : Fin k → M) (v' : Fin l → M) - (h : v i = v' j) : EvalEq (Code.proj i) v (Code.proj j) v' := - by - intro x - rw [eval_proj_iff, eval_proj_iff, h] - -/-- Zero codes have the same graph under any two assignments. -/ -theorem evalEq_zero {k l : ℕ} (v : Fin k → M) (v' : Fin l → M) : - EvalEq (Code.zero k) v (Code.zero l) v' := - by - intro x - rw [eval_zero_iff, eval_zero_iff] - -/-- Head codes agree under assignments with the same head. -/ -theorem evalEq_codeHead {k l : ℕ} (t : M) (v : Fin k → M) (v' : Fin l → M) : - EvalEq (codeHead (n := k)) (t :> v) (codeHead (n := l)) (t :> v') := - evalEq_proj 0 0 _ _ rfl - -/-- Successor-code construction preserves heterogeneous graph agreement. -/ -theorem evalEq_codeSucc {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} - {v' : Fin l → M} (hA : EvalEq A v A' v') : EvalEq (codeSucc A) v (codeSucc A') v' := - by - intro x - rw [eval_codeSucc_iff, eval_codeSucc_iff] - exact exists_congr fun a => and_congr (hA a) Iff.rfl - -/-- Positive-test code construction preserves heterogeneous graph agreement. -/ -theorem evalEq_codePos {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} - {v' : Fin l → M} (hA : EvalEq A v A' v') : EvalEq (codePos A) v (codePos A') v' := - by - intro x - rw [eval_codePos_iff, eval_codePos_iff] - exact exists_congr fun a => and_congr (hA a) Iff.rfl - -/-- Boolean-inverse code construction preserves heterogeneous graph agreement. -/ -theorem evalEq_codeInv {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} - {v' : Fin l → M} (hA : EvalEq A v A' v') : EvalEq (codeInv A) v (codeInv A') v' := - by - intro x - rw [eval_codeInv_iff, eval_codeInv_iff] - exact exists_congr fun a => and_congr (hA a) Iff.rfl - -/-- Addition-code construction preserves heterogeneous graph agreement. -/ -theorem evalEq_codeAdd {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} - {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : - EvalEq (codeAdd A B) v (codeAdd A' B') v' := - by - intro x - rw [eval_codeAdd_iff, eval_codeAdd_iff] - exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) - -/-- Multiplication-code construction preserves heterogeneous graph agreement. -/ -theorem evalEq_codeMul {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} - {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : - EvalEq (codeMul A B) v (codeMul A' B') v' := - by - intro x - rw [eval_codeMul_iff, eval_codeMul_iff] - exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) - -/-- Equality-test code construction preserves heterogeneous graph agreement. -/ -theorem evalEq_codeEq {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} - {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : - EvalEq (codeEq A B) v (codeEq A' B') v' := - by - intro x - rw [eval_codeEq_iff, eval_codeEq_iff] - exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) - -/-- Order-test code construction preserves heterogeneous graph agreement. -/ -theorem evalEq_codeLt {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} - {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : - EvalEq (codeLt A B) v (codeLt A' B') v' := - by - intro x - rw [eval_codeLt_iff, eval_codeLt_iff] - exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) - -/-- Conjunction-code construction preserves heterogeneous graph agreement. -/ -theorem evalEq_codeAnd {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} - {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : - EvalEq (codeAnd A B) v (codeAnd A' B') v' := - by - intro x - rw [eval_codeAnd_iff, eval_codeAnd_iff] - exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) - -/-- Disjunction-code construction preserves heterogeneous graph agreement. -/ -theorem evalEq_codeOr {k l : ℕ} {A B : Code k} {A' B' : Code l} {v : Fin k → M} - {v' : Fin l → M} (hA : EvalEq A v A' v') (hB : EvalEq B v B' v') : - EvalEq (codeOr A B) v (codeOr A' B') v' := - by - intro x - rw [eval_codeOr_iff, eval_codeOr_iff] - exact exists_congr fun a => exists_congr fun b => and_congr (hA a) (and_congr (hB b) Iff.rfl) - -/-- A lift ignores its head, so the two heads need not agree. -/ -theorem evalEq_codeLift {k l : ℕ} {A : Code k} {A' : Code l} {v : Fin k → M} - {v' : Fin l → M} (t t' : M) (hA : EvalEq A v A' v') : - EvalEq (codeLift A) (t :> v) (codeLift A') (t' :> v') := - by - intro x - rw [eval_codeLift_iff, eval_codeLift_iff] - exact hA x - -/-- One codes have the same graph under any two assignments. -/ -theorem evalEq_one {k l : ℕ} (v : Fin k → M) (v' : Fin l → M) : - EvalEq (Code.one k) v (Code.one l) v' := by intro x; rw [eval_one_iff, eval_one_iff] - -/-- Composition with a shared outer code. -/ -theorem evalEq_comp {k l m : ℕ} (c : Code m) (ds : Fin m → Code k) - (ds' : Fin m → Code l) {v : Fin k → M} {v' : Fin l → M} - (h : ∀ i, EvalEq (ds i) v (ds' i) v') : EvalEq (c.comp ds) v (c.comp ds') v' := - by - intro x - rw [eval_comp_iff, eval_comp_iff] - constructor - · rintro ⟨w, hw, hwi⟩; exact ⟨w, hw, fun i => (h i (w i)).mp (hwi i)⟩ - · rintro ⟨w, hw, hwi⟩; exact ⟨w, hw, fun i => (h i (w i)).mpr (hwi i)⟩ - -/-- Constant codes agree under assignments of any arities. -/ -theorem evalEq_codeConst {k l : ℕ} (m : ℕ) (v : Fin k → M) (v' : Fin l → M) : - EvalEq (codeConst (n := k) m) v (codeConst (n := l) m) v' := by - induction m with - | zero => exact evalEq_zero v v' - | succ m ih => exact evalEq_codeSucc ih - /-- Minimization preserves graph agreement under every extra search input. -/ theorem evalEq_rfind {k l : ℕ} {A : Code (k + 1)} {A' : Code (l + 1)} {v : Fin k → M} {v' : Fin l → M} (hA : ∀ t : M, EvalEq A (t :> v) A' (t :> v')) : @@ -669,6 +327,117 @@ theorem eval_codeBeta_congr_at {k l : ℕ} (N I : Code k) (N' I' : Code l) (z : evalEq_codeRem (evalEq_codeUnpair₁ hN) (evalEq_codeSucc (evalEq_codeMul (evalEq_codeSucc hI) (evalEq_codeUnpair₂ hN))) z +/-- Equivalent bodies determine equivalent minimizations. + +This is the congruence law for the minimization context, stated at the +assignment `v` and quantified over the value and the search argument. -/ +theorem eval_codeRfindPos_congr {k : ℕ} (A A' : Code (k + 1)) (z : M) (v : Fin k → M) + (hA : + ∀ x t : M, + Semiformula.Evalb (x :> t :> v) (code A) ↔ Semiformula.Evalb (x :> t :> v) (code A')) : + Semiformula.Evalb (z :> v) (code (codeRfindPos A)) ↔ + Semiformula.Evalb (z :> v) (code (codeRfindPos A')) := + evalEq_codeRfindPos (fun t x => hA x t) z + +/-! +### Constructors defined by minimization -/ + +theorem eval_codeSub_congr {k : ℕ} (A A' B B' : Code k) (z : M) (v : Fin k → M) + (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) + (hB : ∀ x : M, Semiformula.Evalb (x :> v) (code B) ↔ Semiformula.Evalb (x :> v) (code B')) : + Semiformula.Evalb (z :> v) (code (codeSub A B)) ↔ + Semiformula.Evalb (z :> v) (code (codeSub A' B')) := + evalEq_codeSub hA hB z + +theorem eval_codeSqrt_congr {k : ℕ} (A A' : Code k) (z : M) (v : Fin k → M) + (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) : + Semiformula.Evalb (z :> v) (code (codeSqrt A)) ↔ + Semiformula.Evalb (z :> v) (code (codeSqrt A')) := + evalEq_codeSqrt hA z + +theorem eval_codeIfPos_congr {k : ℕ} (F F' G G' H H' : Code k) (z : M) (v : Fin k → M) + (hF : ∀ x : M, Semiformula.Evalb (x :> v) (code F) ↔ Semiformula.Evalb (x :> v) (code F')) + (hG : ∀ x : M, Semiformula.Evalb (x :> v) (code G) ↔ Semiformula.Evalb (x :> v) (code G')) + (hH : ∀ x : M, Semiformula.Evalb (x :> v) (code H) ↔ Semiformula.Evalb (x :> v) (code H')) : + Semiformula.Evalb (z :> v) (code (codeIfPos F G H)) ↔ + Semiformula.Evalb (z :> v) (code (codeIfPos F' G' H')) := + evalEq_codeIfPos hF hG hH z + +theorem eval_codeUnpair₁_congr {k : ℕ} (A A' : Code k) (z : M) (v : Fin k → M) + (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) : + Semiformula.Evalb (z :> v) (code (codeUnpair₁ A)) ↔ + Semiformula.Evalb (z :> v) (code (codeUnpair₁ A')) := + evalEq_codeUnpair₁ hA z + +theorem eval_codeUnpair₂_congr {k : ℕ} (A A' : Code k) (z : M) (v : Fin k → M) + (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) : + Semiformula.Evalb (z :> v) (code (codeUnpair₂ A)) ↔ + Semiformula.Evalb (z :> v) (code (codeUnpair₂ A')) := + evalEq_codeUnpair₂ hA z + +/-! +### Pairing -/ + +theorem eval_codePair_congr {k : ℕ} (A A' B B' : Code k) (z : M) (v : Fin k → M) + (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) + (hB : ∀ x : M, Semiformula.Evalb (x :> v) (code B) ↔ Semiformula.Evalb (x :> v) (code B')) : + Semiformula.Evalb (z :> v) (code (codePair A B)) ↔ + Semiformula.Evalb (z :> v) (code (codePair A' B')) := + evalEq_codePair hA hB z + +/-! +### Encoded lists -/ + +theorem eval_codeListHeadOptional_congr {k : ℕ} (A A' : Code k) (z : M) (v : Fin k → M) + (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) : + Semiformula.Evalb (z :> v) (code (codeListHeadOptional A)) ↔ + Semiformula.Evalb (z :> v) (code (codeListHeadOptional A')) := + by + simp only [codeListHeadOptional] + exact + eval_codeIfPos_congr _ _ _ _ _ _ z v hA + (fun x => + eval_codeSucc_congr _ _ x v + (fun y => + eval_codeUnpair₁_congr _ _ y v + (fun w => eval_codeSub_congr _ _ _ _ w v hA (fun _ => Iff.rfl)))) + (fun _ => Iff.rfl) + +theorem eval_codeListTail_congr {k : ℕ} (A A' : Code k) (z : M) (v : Fin k → M) + (hA : ∀ x : M, Semiformula.Evalb (x :> v) (code A) ↔ Semiformula.Evalb (x :> v) (code A')) : + Semiformula.Evalb (z :> v) (code (codeListTail A)) ↔ + Semiformula.Evalb (z :> v) (code (codeListTail A')) := + by + simp only [codeListTail] + exact + eval_codeUnpair₂_congr _ _ z v + (fun x => eval_codeSub_congr _ _ _ _ x v hA (fun _ => Iff.rfl)) + +theorem eval_codeListDrop_congr {k : ℕ} (L L' I I' : Code k) (z : M) (v : Fin k → M) + (hL : ∀ x : M, Semiformula.Evalb (x :> v) (code L) ↔ Semiformula.Evalb (x :> v) (code L')) + (hI : ∀ x : M, Semiformula.Evalb (x :> v) (code I) ↔ Semiformula.Evalb (x :> v) (code I')) : + Semiformula.Evalb (z :> v) (code (codeListDrop L I)) ↔ + Semiformula.Evalb (z :> v) (code (codeListDrop L' I')) := + by + rw [codeListDrop_eq_comp, codeListDrop_eq_comp] + refine eval_comp_congr _ _ _ z v ?_ + refine Fin.forall_fin_two.mpr ⟨?_, ?_⟩ + · intro x + simpa using hI x + · intro x + simpa using hL x + +theorem eval_codeListGetOptional_congr {k : ℕ} (L L' I I' : Code k) (z : M) (v : Fin k → M) + (hL : ∀ x : M, Semiformula.Evalb (x :> v) (code L) ↔ Semiformula.Evalb (x :> v) (code L')) + (hI : ∀ x : M, Semiformula.Evalb (x :> v) (code I) ↔ Semiformula.Evalb (x :> v) (code I')) : + Semiformula.Evalb (z :> v) (code (codeListGetOptional L I)) ↔ + Semiformula.Evalb (z :> v) (code (codeListGetOptional L' I')) := + by + simp only [codeListGetOptional] + exact + eval_codeListHeadOptional_congr _ _ z v + (fun x => eval_codeListDrop_congr L L' I I' x v hL hI) + end ArithmeticCode end CategoricalRiceShapiro